module Main where
import qualified Data.Text.Lazy as TextLazy
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Main.Apx (Apx (..))
import qualified Main.Composite as Composite
import qualified Main.DB as DB
import qualified Main.Gens as Gens
import qualified Main.IO as IO
import qualified Main.PTI as PTI
import Main.Prelude hiding (empty, isLeft, isRight, select)
import qualified Main.Properties as Properties
import qualified Main.TextEncoder as TextEncoder
import qualified PostgreSQL.Binary.Decoding as B
import qualified PostgreSQL.Binary.Encoding as A
import qualified PostgreSQL.Binary.Range as S
import Test.Tasty
import Test.Tasty.HUnit as HUnit
import Test.Tasty.QuickCheck as QuickCheck
main :: IO ()
main =
defaultMain (testGroup "" [binary, textual])
binary :: TestTree
binary =
testGroup "Binary format" testList
where
testList =
jsonb ++ other
where
jsonb =
if version >= 90400
then [primitiveRoundtrip "jsonb" Gens.aeson PTI.jsonb A.jsonb_ast B.jsonb_ast]
else []
other =
[ testProperty ("Composite roundtrip") $ \value ->
Composite.decodingProperty value (Composite.encodeToByteString value),
select "select (234 :: int8)" (const B.int) (234 :: Int32),
select "select (-234 :: int8)" (const B.int) (-234 :: Int32),
select "select (0 :: int8)" (const B.int) (0 :: Int32),
let sql =
"select (1, 'a')"
decoder _ =
B.composite ((,) <$> B.valueComposite B.int <*> B.valueComposite B.char)
expected =
(1 :: Int64, 'a')
in select sql decoder expected,
let sql =
"select (1, null)"
decoder _ =
B.composite ((,) <$> B.valueComposite B.int <*> B.nullableValueComposite B.char)
expected =
(1 :: Int64, Nothing :: Maybe Char)
in select sql decoder expected,
select
"SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval"
(bool B.interval_float B.interval_int)
(picosecondsToDiffTime (10 ^ 6 * (332211 + 10 ^ 6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12)))))))),
select
"SELECT '10 seconds' :: interval"
(bool B.interval_float B.interval_int)
(10 :: DiffTime),
HUnit.testCase "Interval encoder: 10 seconds"
$ let pti =
PTI.interval
encoder integerDatetimes =
(bool A.interval_float A.interval_int integerDatetimes)
decoder =
(bool B.interval_float B.interval_int)
value =
(10 :: DiffTime)
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
timeRoundtrip
"interval"
Gens.intervalDiffTime
PTI.interval
(bool A.interval_float A.interval_int)
(bool B.interval_float B.interval_int),
timeRoundtrip
"timestamp"
(fmap Apx Gens.auto)
PTI.timestamp
((. unApx) . bool A.timestamp_float A.timestamp_int)
(fmap Apx . bool B.timestamp_float B.timestamp_int),
HUnit.testCase "timestamptz offset" $ do
Right (textual, decoded) <-
DB.session $ do
integerDatetimes <- DB.integerDatetimes
let encoder = bool A.timestamptz_float A.timestamptz_int integerDatetimes
decoder = bool B.timestamptz_float B.timestamptz_int integerDatetimes
DB.unit "DROP TABLE IF EXISTS a" []
DB.unit "CREATE TABLE a (b TIMESTAMPTZ)" []
DB.unit "set timezone to 'America/Los_Angeles'" []
let p =
(,,)
(PTI.oidPQ (PTI.ptiOID PTI.timestamptz))
((A.encodingBytes . encoder) x)
(LibPQ.Binary)
x = read "2011-09-28 00:17:25Z"
DB.unit "insert into a (b) values ($1)" [Just p]
DB.unit "set timezone to 'Europe/Stockholm'" []
textual <- DB.oneRow "SELECT * FROM a" [] LibPQ.Text
decoded <- fmap (B.valueParser decoder) (DB.oneRow "SELECT * FROM a" [] LibPQ.Binary)
return (textual, decoded)
HUnit.assertEqual "" ("2011-09-28 02:17:25+02") textual
HUnit.assertEqual "" (Right (read "2011-09-28 00:17:25Z")) decoded,
timeRoundtrip
"timestamptz"
(fmap Apx Gens.auto)
PTI.timestamptz
((. unApx) . bool A.timestamptz_float A.timestamptz_int)
(fmap Apx . bool B.timestamptz_float B.timestamptz_int),
timeRoundtrip
"timetz"
(fmap Apx Gens.timetz)
PTI.timetz
((. unApx) . bool A.timetz_float A.timetz_int)
(fmap Apx . bool B.timetz_float B.timetz_int),
timeRoundtrip
"time"
(fmap Apx Gens.auto)
PTI.time
((. unApx) . bool A.time_float A.time_int)
(fmap Apx . bool B.time_float B.time_int),
primitiveRoundtrip "numeric" Gens.scientific PTI.numeric A.numeric B.numeric,
select "SELECT -1234560.789 :: numeric" (const B.numeric) (read "-1234560.789"),
select "SELECT -0.0789 :: numeric" (const B.numeric) (read "-0.0789"),
select "SELECT 10000 :: numeric" (const B.numeric) (read "10000"),
primitiveRoundtrip "float4" Gens.auto PTI.float4 A.float4 B.float4,
primitiveRoundtrip "float8" Gens.auto PTI.float8 A.float8 B.float8,
primitiveRoundtrip "char" Gens.char PTI.text A.char_utf8 B.char,
primitiveRoundtrip "text_strict" Gens.text PTI.text A.text_strict B.text_strict,
primitiveRoundtrip "text_lazy" (fmap TextLazy.fromStrict Gens.text) PTI.text A.text_lazy B.text_lazy,
primitiveRoundtrip "bytea_strict" Gens.auto PTI.bytea A.bytea_strict B.bytea_strict,
primitiveRoundtrip "bytea_lazy" Gens.auto PTI.bytea A.bytea_lazy B.bytea_lazy,
primitiveRoundtrip "uuid" Gens.uuid PTI.uuid A.uuid B.uuid,
primitiveRoundtrip "inet" Gens.inet PTI.inet A.inet B.inet,
select "SELECT '127.0.0.1' :: inet" (const B.inet) (read "127.0.0.1"),
select "SELECT '::1' :: inet" (const B.inet) (read "::1"),
primitiveRoundtrip "macaddr" Gens.macaddr PTI.macaddr A.macaddr B.macaddr,
select "SELECT '11:22:33:44:55:66' :: macaddr" (const B.macaddr) (0x11, 0x22, 0x33, 0x44, 0x55, 0x66),
primitiveRoundtrip "int2_int16" Gens.auto PTI.int2 A.int2_int16 B.int,
primitiveRoundtrip "int2_word16" Gens.auto PTI.int2 A.int2_word16 B.int,
primitiveRoundtrip "int4_int32" Gens.auto PTI.int4 A.int4_int32 B.int,
primitiveRoundtrip "int4_word32" Gens.auto PTI.int4 A.int4_word32 B.int,
primitiveRoundtrip "int8_int64" Gens.auto PTI.int8 A.int8_int64 B.int,
primitiveRoundtrip "int8_word64" Gens.auto PTI.int8 A.int8_word64 B.int,
primitiveRoundtrip "bool" Gens.auto PTI.bool A.bool B.bool,
primitiveRoundtrip "date" Gens.auto PTI.date A.date B.date,
let decoder =
B.array
$ B.dimensionArray replicateM
$ B.dimensionArray replicateM
$ B.valueArray
$ B.int
in select "SELECT ARRAY[ARRAY[1,2],ARRAY[3,4]]" (const decoder) ([[1, 2], [3, 4]] :: [[Int]]),
let encoder =
A.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) . arrayEncoder
where
arrayEncoder =
A.dimensionArray foldl'
$ A.dimensionArray foldl'
$ A.dimensionArray foldl'
$ A.encodingArray
. A.int8_int64
decoder =
B.array
$ B.dimensionArray replicateM
$ B.dimensionArray replicateM
$ B.dimensionArray replicateM
$ B.valueArray
$ B.int
in arrayCodec (Gens.array3 Gens.auto) encoder decoder,
let pti =
PTI.text
encoder =
A.array (PTI.oidWord32 (PTI.ptiOID pti)) . arrayEncoder
where
arrayEncoder =
A.dimensionArray foldl'
$ A.dimensionArray foldl'
$ A.dimensionArray foldl'
$ A.encodingArray
. A.text_strict
decoder =
B.array
$ B.dimensionArray replicateM
$ B.dimensionArray replicateM
$ B.dimensionArray replicateM
$ B.valueArray
$ B.text_strict
in arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder,
select "select ('[10, 20]' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) (S.Excl 21)),
select "select ('[10, 20)' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) (S.Excl 20)),
select "select ('(10, 20]' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) (S.Excl 21)),
select "select ('(10, 20)' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) (S.Excl 20)),
select "select ('[,20]' :: int4range)" (const B.int4range) (S.Range S.Inf (S.Excl 21)),
select "select ('[,20)' :: int4range)" (const B.int4range) (S.Range S.Inf (S.Excl 20)),
select "select ('[10,]' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) S.Inf),
select "select ('(10,]' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) S.Inf),
select "select ('(,)' :: int4range)" (const B.int4range) (S.Range S.Inf S.Inf),
select "select ('empty' :: int4range)" (const B.int4range) S.Empty,
HUnit.testCase "int4range encoder: [10, 20]"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Incl 10) (S.Incl 20)
normalized =
S.Range (S.Incl 10) (S.Excl 21)
in HUnit.assertEqual "" (Right normalized)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: [10, 20)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Incl 10) (S.Excl 20)
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (10, 20]"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Excl 10) (S.Incl 20)
normalized =
S.Range (S.Incl 11) (S.Excl 21)
in HUnit.assertEqual "" (Right normalized)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (10, 20)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Excl 10) (S.Excl 20)
normalized =
S.Range (S.Incl 11) (S.Excl 20)
in HUnit.assertEqual "" (Right normalized)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: [10,)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Incl 10) S.Inf
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (10,)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range (S.Excl 10) S.Inf
normalized =
S.Range (S.Incl 11) S.Inf
in HUnit.assertEqual "" (Right normalized)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (,20]"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range S.Inf (S.Incl 20)
normalized =
S.Range S.Inf (S.Excl 21)
in HUnit.assertEqual "" (Right normalized)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (,20)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range S.Inf (S.Excl 20)
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: empty"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Empty
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int4range encoder: (,)"
$ let pti =
PTI.int4range
encoder =
(const A.int4range)
decoder =
(const B.int4range)
value =
S.Range S.Inf S.Inf
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
select "select ('{[10, 20], [30, 40]}' :: int4multirange)" (const $ B.int4multirange) [S.Range (S.Incl 10) (S.Excl 21), S.Range (S.Incl 30) (S.Excl 41)],
HUnit.testCase "int4multirange encoder: {[10,20), [30,40)}"
$ let pti =
PTI.int4multirange
encoder =
(const A.int4multirange)
decoder =
(const B.int4multirange)
value =
[S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)]
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "int8multirange encoder: {[10,20), [30,40)}"
$ let pti =
PTI.int8multirange
encoder =
(const A.int8multirange)
decoder =
(const B.int8multirange)
value =
[S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)]
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,
HUnit.testCase "nummultirange encoder: {[10,20), [30,40)}"
$ let pti =
PTI.nummultirange
encoder =
(const A.nummultirange)
decoder =
(const B.nummultirange)
value =
[S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)]
in HUnit.assertEqual "" (Right value)
=<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value
]
textual :: TestTree
textual =
testGroup "Textual format"
$ [ test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const B.numeric),
test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const B.float4),
test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const B.float8),
test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const B.uuid),
test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const B.int),
test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const B.int),
test "int4_int32" Gens.auto PTI.int4 TextEncoder.int4_int32 (const B.int),
test "int4_word32" Gens.postgresInt PTI.int4 TextEncoder.int4_word32 (const B.int),
test "int8_int64" Gens.auto PTI.int8 TextEncoder.int8_int64 (const B.int),
test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const B.int),
test "bool" Gens.auto PTI.bool TextEncoder.bool (const B.bool)
]
where
test typeName gen pti encoder decoder =
QuickCheck.testProperty (typeName <> " roundtrip")
$ QuickCheck.forAll gen
$ Properties.textRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder
arrayCodec :: (Show t, Eq t) => Gen t -> (t -> A.Encoding) -> B.Value t -> TestTree
arrayCodec gen encoder decoder =
QuickCheck.testProperty ("Array codec")
$ QuickCheck.forAll gen
$ \value -> (QuickCheck.===) (Right value) (B.valueParser decoder ((A.encodingBytes . encoder) value))
arrayRoundtrip :: (Show a, Eq a) => Gen a -> PTI.PTI -> (a -> A.Encoding) -> B.Value a -> TestTree
arrayRoundtrip gen pti encoder decoder =
QuickCheck.testProperty ("Array roundtrip")
$ QuickCheck.forAll gen
$ Properties.stdRoundtrip (PTI.oidPQ (fromJust (PTI.ptiArrayOID pti))) encoder decoder
stdRoundtrip ::
(Eq a, Show a) =>
TestName ->
QuickCheck.Gen a ->
PTI.PTI ->
(a -> A.Encoding) ->
B.Value a ->
TestTree
stdRoundtrip typeName gen pti encoder decoder =
QuickCheck.testProperty (typeName <> " roundtrip")
$ QuickCheck.forAll gen
$ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder
primitiveRoundtrip :: (Eq a, Show a) => TestName -> Gen a -> PTI.PTI -> (a -> A.Encoding) -> B.Value a -> TestTree
primitiveRoundtrip typeName gen pti encoder decoder =
stdRoundtrip typeName gen pti (encoder) decoder
timeRoundtrip :: (Show a, Eq a) => TestName -> Gen a -> PTI.PTI -> (Bool -> a -> A.Encoding) -> (Bool -> B.Value a) -> TestTree
timeRoundtrip typeName gen pti encoder decoder =
QuickCheck.testProperty (typeName <> " roundtrip")
$ QuickCheck.forAll gen
$ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) (\x -> encoder x) decoder
select :: (Eq b, Show b) => ByteString -> (Bool -> B.Value b) -> b -> TestTree
select statement decoder value =
HUnit.testCase (show statement)
$ HUnit.assertEqual "" (Right value)
$ unsafePerformIO
$ IO.parameterlessStatement statement decoder value
{-# NOINLINE version #-}
version :: Int
version =
either (error . show) id
$ unsafePerformIO
$ DB.session
$ DB.serverVersion