diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# 0.15 + +## Breaking Changes + +- Made the Composite decoder check for exact field count match +- Dropped the Monad and MonadFail instances for it + +# 0.14 + +- Moved to "iproute" from "network-ip" for inet datatypes + +# 0.13 + +- Removed `PostgreSQL.Binary.Data`. Because it was causing Haddock in the dependant packages to unpredictably redirect to it instead of the original location regardless of whether they were imported from it. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/decoding/Main.hs b/decoding/Main.hs new file mode 100644 --- /dev/null +++ b/decoding/Main.hs @@ -0,0 +1,40 @@ +module Main where + +import Criterion +import Criterion.Main +import qualified PostgreSQL.Binary.Decoding as D +import qualified PostgreSQL.Binary.Encoding as E +import Prelude + +main :: IO () +main = + defaultMain + [ b "bool" D.bool ((E.encodingBytes . E.bool) True), + b "int2" (D.int :: D.Value Int16) ((E.encodingBytes . E.int2_int16) 1000), + b "int4" (D.int :: D.Value Int32) ((E.encodingBytes . E.int4_int32) 1000), + b "int8" (D.int :: D.Value Int64) ((E.encodingBytes . E.int8_int64) 1000), + b "float4" D.float4 ((E.encodingBytes . E.float4) 12.65468468), + b "float8" D.float8 ((E.encodingBytes . E.float8) 12.65468468), + b "numeric" D.numeric ((E.encodingBytes . E.numeric) (read "20.213290183")), + b "char" D.char ((E.encodingBytes . E.char_utf8) 'Я'), + b "text" D.text_strict ((E.encodingBytes . E.text_strict) "alsdjflskjдывлоаы оады"), + b "bytea" D.bytea_strict ((E.encodingBytes . E.bytea_strict) "alskdfj;dasjfl;dasjflksdj"), + b "date" D.date ((E.encodingBytes . E.date) (read "2000-01-19")), + b "time" D.time_int ((E.encodingBytes . E.time_int) (read "10:41:06")), + b "timetz" D.timetz_int ((E.encodingBytes . E.timetz_int) (read "(10:41:06, +0300)")), + b "timestamp" D.timestamp_int ((E.encodingBytes . E.timestamp_int) (read "2000-01-19 10:41:06")), + b "timestamptz" D.timestamptz_int ((E.encodingBytes . E.timestamptz_int) (read "2000-01-19 10:41:06")), + b "interval" D.interval_int ((E.encodingBytes . E.interval_int) (secondsToDiffTime 23472391128374)), + b "uuid" D.uuid ((E.encodingBytes . E.uuid) (read "550e8400-e29b-41d4-a716-446655440000")), + let encoder = + E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32) + decoder = + D.array + $ D.dimensionArray replicateM + $ D.valueArray + $ (D.int :: D.Value Int32) + in b "array" decoder (E.encodingBytes (encoder [1, 2, 3, 4])) + ] + where + b name decoder value = + bench name $ nf (D.valueParser decoder) value diff --git a/encoding/Main.hs b/encoding/Main.hs new file mode 100644 --- /dev/null +++ b/encoding/Main.hs @@ -0,0 +1,34 @@ +module Main where + +import Criterion +import Criterion.Main +import qualified PostgreSQL.Binary.Encoding as E +import Prelude + +main :: IO () +main = + defaultMain + [ value "bool" E.bool True, + value "int2" E.int2_int16 1000, + value "int4" E.int4_int32 1000, + value "int8" E.int8_int64 1000, + value "float4" E.float4 12.65468468, + value "float8" E.float8 12.65468468, + value "numeric" E.numeric (read "20.213290183"), + value "char_utf8" E.char_utf8 'Я', + value "text" E.text_strict "alsdjflskjдывлоаы оады", + value "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj", + value "date" E.date (read "2000-01-19"), + value "time" E.time_int (read "10:41:06"), + value "timetz" E.timetz_int (read "(10:41:06, +0300)"), + value "timestamp" E.timestamp_int (read "2000-01-19 10:41:06"), + value "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06"), + value "interval" E.interval_int (secondsToDiffTime 23472391128374), + value "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), + let encoder = + E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32) + in value "array" encoder [1, 2, 3, 4] + ] + where + value name encoder value = + bench name $ nf (E.encodingBytes . encoder) value diff --git a/executables/Decoding.hs b/executables/Decoding.hs deleted file mode 100644 --- a/executables/Decoding.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Main where - -import BasePrelude -import MTLPrelude -import Control.DeepSeq -import Criterion -import Criterion.Main -import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.Scientific (Scientific) -import Data.Time -import qualified PostgreSQLBinary.Encoder as E -import qualified PostgreSQLBinary.Decoder as D -import qualified PostgreSQLBinary.Array as Array - - -main = - defaultMain - [ - b "bool" D.bool (E.bool True), - b "int2" (D.int :: D.D Int16) (E.int2 (Left 1000)), - b "int4" (D.int :: D.D Int32) (E.int4 (Left 1000)), - b "int8" (D.int :: D.D Int64) (E.int8 (Left 1000)), - b "float4" D.float4 (E.float4 12.65468468), - b "float8" D.float8 (E.float8 12.65468468), - b "numeric" D.numeric (E.numeric (read "20.213290183")), - b "char" D.char (E.char 'Я'), - b "text" D.text (E.text (Left "alsdjflskjдывлоаы оады")), - b "bytea" D.bytea (E.bytea (Left "alskdfj;dasjfl;dasjflksdj")), - b "date" D.date (E.date (read "2000-01-19")), - b "time" (D.time True) (E.time True (read "10:41:06")), - b "timetz" (D.timetz True) (E.timetz True (read "(10:41:06, +0300)")), - b "timestamp" (D.timestamp True) (E.timestamp True (read "2000-01-19 10:41:06")), - b "timestamptz" (D.timestamptz True) (E.timestamptz True (read "2000-01-19 10:41:06")), - b "interval" (D.interval True) (E.interval True (secondsToDiffTime 23472391128374)), - b "uuid" D.uuid (E.uuid (read "550e8400-e29b-41d4-a716-446655440000")), - b "array" D.array (E.array - (Array.fromListUnsafe - [Array.fromSingleton (Just "dfs") True 0, - Array.fromSingleton Nothing True 0])) - ] - where - b name decoder value = - bench name $ nf decoder value diff --git a/executables/Encoding.hs b/executables/Encoding.hs deleted file mode 100644 --- a/executables/Encoding.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Main where - -import BasePrelude -import MTLPrelude -import Control.DeepSeq -import Criterion -import Criterion.Main -import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.Scientific (Scientific) -import Data.Time -import qualified PostgreSQLBinary.Encoder as E -import qualified PostgreSQLBinary.Decoder as D -import qualified PostgreSQLBinary.Array as Array - - -main = - defaultMain - [ - b "bool" E.bool True, - b "int2" E.int2 (Left 1000), - b "int4" E.int4 (Left 1000), - b "int8" E.int8 (Left 1000), - b "float4" E.float4 12.65468468, - b "float8" E.float8 12.65468468, - b "numeric" E.numeric (read "20.213290183"), - b "char" E.char 'Я', - b "text" E.text (Left "alsdjflskjдывлоаы оады"), - b "bytea" E.bytea (Left "alskdfj;dasjfl;dasjflksdj"), - b "date" E.date (read "2000-01-19"), - b "time" (E.time True) (read "10:41:06"), - b "timetz" (E.timetz True) (read "(10:41:06, +0300)"), - b "timestamp" (E.timestamp True) (read "2000-01-19 10:41:06"), - b "timestamptz" (E.timestamptz True) (read "2000-01-19 10:41:06"), - b "interval" (E.interval True) (secondsToDiffTime 23472391128374), - b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"), - b "array" E.array (Array.fromListUnsafe - [Array.fromSingleton (Just "dfs") True 0, - Array.fromSingleton Nothing True 0]) - ] - where - b name encoder value = - bench name $ nf encoder value diff --git a/executables/PostgreSQLBinary/PTI.hs b/executables/PostgreSQLBinary/PTI.hs deleted file mode 100644 --- a/executables/PostgreSQLBinary/PTI.hs +++ /dev/null @@ -1,77 +0,0 @@ -module PostgreSQLBinary.PTI where - -import BasePrelude - - --- | A Postgresql type info -data PTI = PTI { oidOf :: !Word32, arrayOIDOf :: !(Maybe Word32) } - -abstime = PTI 702 (Just 1023) -aclitem = PTI 1033 (Just 1034) -bit = PTI 1560 (Just 1561) -bool = PTI 16 (Just 1000) -box = PTI 603 (Just 1020) -bpchar = PTI 1042 (Just 1014) -bytea = PTI 17 (Just 1001) -char = PTI 18 (Just 1002) -cid = PTI 29 (Just 1012) -cidr = PTI 650 (Just 651) -circle = PTI 718 (Just 719) -cstring = PTI 2275 (Just 1263) -date = PTI 1082 (Just 1182) -daterange = PTI 3912 (Just 3913) -float4 = PTI 700 (Just 1021) -float8 = PTI 701 (Just 1022) -gtsvector = PTI 3642 (Just 3644) -inet = PTI 869 (Just 1041) -int2 = PTI 21 (Just 1005) -int2vector = PTI 22 (Just 1006) -int4 = PTI 23 (Just 1007) -int4range = PTI 3904 (Just 3905) -int8 = PTI 20 (Just 1016) -int8range = PTI 3926 (Just 3927) -interval = PTI 1186 (Just 1187) -json = PTI 114 (Just 199) -line = PTI 628 (Just 629) -lseg = PTI 601 (Just 1018) -macaddr = PTI 829 (Just 1040) -money = PTI 790 (Just 791) -name = PTI 19 (Just 1003) -numeric = PTI 1700 (Just 1231) -numrange = PTI 3906 (Just 3907) -oid = PTI 26 (Just 1028) -oidvector = PTI 30 (Just 1013) -path = PTI 602 (Just 1019) -point = PTI 600 (Just 1017) -polygon = PTI 604 (Just 1027) -record = PTI 2249 (Just 2287) -refcursor = PTI 1790 (Just 2201) -regclass = PTI 2205 (Just 2210) -regconfig = PTI 3734 (Just 3735) -regdictionary = PTI 3769 (Just 3770) -regoper = PTI 2203 (Just 2208) -regoperator = PTI 2204 (Just 2209) -regproc = PTI 24 (Just 1008) -regprocedure = PTI 2202 (Just 2207) -regtype = PTI 2206 (Just 2211) -reltime = PTI 703 (Just 1024) -text = PTI 25 (Just 1009) -tid = PTI 27 (Just 1010) -time = PTI 1083 (Just 1183) -timestamp = PTI 1114 (Just 1115) -timestamptz = PTI 1184 (Just 1185) -timetz = PTI 1266 (Just 1270) -tinterval = PTI 704 (Just 1025) -tsquery = PTI 3615 (Just 3645) -tsrange = PTI 3908 (Just 3909) -tstzrange = PTI 3910 (Just 3911) -tsvector = PTI 3614 (Just 3643) -txid_snapshot = PTI 2970 (Just 2949) -unknown = PTI 705 Nothing -uuid = PTI 2950 (Just 2951) -varbit = PTI 1562 (Just 1563) -varchar = PTI 1043 (Just 1015) -void = PTI 2278 Nothing -xid = PTI 28 (Just 1011) -xml = PTI 142 (Just 143) - diff --git a/executables/Tests.hs b/executables/Tests.hs deleted file mode 100644 --- a/executables/Tests.hs +++ /dev/null @@ -1,603 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} -module Main where - -import BasePrelude hiding (assert) -import Test.Framework -import Test.QuickCheck.Instances -import Data.Time -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified Database.PostgreSQL.LibPQ as PQ -import qualified PostgreSQLBinary.PTI as PTI -import qualified PostgreSQLBinary.Encoder as Encoder -import qualified PostgreSQLBinary.Decoder as Decoder -import qualified PostgreSQLBinary.Array as Array - - -type Text = T.Text -type LazyText = TL.Text -type ByteString = B.ByteString -type LazyByteString = BL.ByteString -type Scientific = Scientific.Scientific - -main = - htfMain $ htf_thisModulesTests - -floatEqProp :: RealFrac a => Show a => a -> a -> Property -floatEqProp a b = - counterexample (show a ++ " /~ " ++ show b) $ - a + error >= b && a - error <= b - where - error = max (abs a) 1 / 10^3 - -mappingP :: - (Show a, Eq a) => - Word32 -> (a -> Maybe ByteString) -> (Maybe ByteString -> Either Text a) -> a -> Property -mappingP oid encode decode v = - Right v === do - unsafePerformIO $ do - c <- connect - initConnection c - result <- - let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> encode v <*> pure PQ.Binary - in PQ.execParams c "SELECT $1" [param] PQ.Binary - case result of - Just result -> do - binaryResult <- PQ.getvalue result 0 0 - PQ.finish c - return $ decode binaryResult - Nothing -> do - m <- PQ.errorMessage c - fail $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> show m) m - -mappingTextP :: - (Show a, Eq a) => - Word32 -> (a -> Maybe ByteString) -> (a -> Maybe ByteString) -> a -> Property -mappingTextP oid encode render value = - render value === do unsafePerformIO $ checkText oid (encode value) - -checkText :: Word32 -> Maybe ByteString -> IO (Maybe ByteString) -checkText oid v = - do - c <- connect - initConnection c - Just result <- - let param = (,,) <$> pure (PQ.Oid $ fromIntegral oid) <*> v <*> pure PQ.Binary - in PQ.execParams c "SELECT $1" [param] PQ.Text - encodedResult <- PQ.getvalue result 0 0 - PQ.finish c - return $ encodedResult - -query :: ByteString -> [Maybe (PQ.Oid, ByteString, PQ.Format)] -> PQ.Format -> IO (Maybe ByteString) -query statement params outFormat = - do - connection <- connect - initConnection connection - Just result <- PQ.execParams connection statement params outFormat - encodedResult <- PQ.getvalue result 0 0 - PQ.finish connection - return $ encodedResult - -connect :: IO PQ.Connection -connect = - PQ.connectdb bs - where - bs = - B.intercalate " " components - where - components = - [ - "host=" <> host, - "port=" <> (fromString . show) port, - "user=" <> user, - "password=" <> password, - "dbname=" <> db - ] - where - host = "localhost" - port = 5432 - user = "postgres" - password = "" - db = "postgres" - -initConnection :: PQ.Connection -> IO () -initConnection c = - void $ PQ.exec c $ mconcat $ map (<> ";") $ - [ - "SET client_min_messages TO WARNING", - "SET client_encoding = 'UTF8'", - "SET intervalstyle = 'postgres'" - ] - -getIntegerDatetimes :: PQ.Connection -> IO Bool -getIntegerDatetimes c = - fmap parseResult $ PQ.parameterStatus c "integer_datetimes" - where - parseResult = - \case - Just "on" -> True - _ -> False - -nonNullParser p = - fromMaybe (Left "Unexpected NULL") . fmap p - -nonNullRenderer r = - return . r - --- * Generators -------------------------- - -scientificGen :: Gen Scientific -scientificGen = - Scientific.scientific <$> arbitrary <*> arbitrary - -microsTimeOfDayGen :: Gen TimeOfDay -microsTimeOfDayGen = - fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ - choose (0, (10^6)*24*60*60) - -microsLocalTimeGen :: Gen LocalTime -microsLocalTimeGen = - LocalTime <$> arbitrary <*> microsTimeOfDayGen - -microsUTCTimeGen :: Gen UTCTime -microsUTCTimeGen = - localTimeToUTC <$> timeZoneGen <*> microsLocalTimeGen - -intervalDiffTimeGen :: Gen DiffTime -intervalDiffTimeGen = do - unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer) - where - uMin = unsafeCoerce minInterval `div` 10^6 - uMax = unsafeCoerce maxInterval `div` 10^6 - -timeZoneGen :: Gen TimeZone -timeZoneGen = - minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12) - -uuidGen :: Gen UUID.UUID -uuidGen = - UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - -arrayGen :: Gen (Word32, Array.Data) -arrayGen = - do - ndims <- choose (1, 4) - dims <- replicateM ndims dimGen - (valueGen', oid, arrayOID) <- valueGen - values <- replicateM (dimsToNValues dims) valueGen' - let nulls = elem Nothing values - return (arrayOID, (dims, values, nulls, oid)) - where - dimGen = - (,) <$> choose (1, 7) <*> pure 1 - valueGen = - do - (pti, gen) <- elements [(PTI.int8, mkGen (Encoder.int8 . Left)), - (PTI.bool, mkGen Encoder.bool), - (PTI.date, mkGen Encoder.date), - (PTI.text, mkGen Encoder.text), - (PTI.bytea, mkGen Encoder.bytea)] - return (gen, PTI.oidOf pti, fromJust $ PTI.arrayOIDOf pti) - where - mkGen renderer = - fmap (fmap renderer) arbitrary - dimsToNValues = - product . map dimensionWidth - where - dimensionWidth (x, _) = fromIntegral x - --- * Constants -------------------------- - -maxInterval :: DiffTime = - unsafeCoerce $ - (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) - -minInterval :: DiffTime = - negate maxInterval - -integerDatetimes :: Bool -integerDatetimes = - unsafePerformIO $ do - connection <- connect - initConnection connection - integerDatetimes <- getIntegerDatetimes connection - PQ.finish connection - return integerDatetimes - --- * Misc -------------------------- - -timestamptzApxRep (UTCTime d d') = - (d, picoApxRep (unsafeCoerce d')) - -timestampApxRep (LocalTime d t) = - (d, timeApxRep t) - -timetzApxRep (t, tz) = - (timeApxRep t, tz) - -timeApxRep (TimeOfDay h m s) = - (h, m, picoApxRep s) - -picoApxRep :: Pico -> Integer -picoApxRep s = - let p = unsafeCoerce s :: Integer - in round (p % 10^6) - - --- * Tests -------------------------- - --- | This is a dummy, the sole point of which is to output the value of 'integer_datetimes' -test_integerDatetimes = - do - connection <- connect - initConnection connection - x <- getIntegerDatetimes connection - putStrLn $ "'integer_datetimes' is " <> show x - PQ.finish connection - -prop_uuid = - forAll uuidGen $ - mappingP (PTI.oidOf PTI.uuid) - (nonNullRenderer Encoder.uuid) - (nonNullParser Decoder.uuid) - -test_uuidParsing = - assertEqual (Right (read "550e8400-e29b-41d4-a716-446655440000" :: UUID.UUID)) =<< do - fmap (Decoder.uuid . fromJust) $ - query "SELECT '550e8400-e29b-41d4-a716-446655440000' :: uuid" [] PQ.Binary - -test_intervalParsing = - let p = 10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12)))))) - in - assertEqual (Just (Right (picosecondsToDiffTime p))) =<< do - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval" [] PQ.Binary - -prop_interval = - forAll intervalDiffTimeGen $ - mappingP (PTI.oidOf PTI.interval) - (nonNullRenderer (Encoder.interval integerDatetimes)) - (nonNullParser (Decoder.interval integerDatetimes)) - -test_maxInterval = - let x = maxInterval - in - assertEqual (Just (Right x)) =<< do - let - p = - (,,) - (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - ((Encoder.interval integerDatetimes) x) - (PQ.Binary) - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT $1" [Just p] PQ.Binary - -test_minInterval = - let x = minInterval - in - assertEqual (Just (Right x)) =<< do - let - p = - (,,) - (PQ.Oid (fromIntegral (PTI.oidOf PTI.interval))) - ((Encoder.interval integerDatetimes) x) - (PQ.Binary) - (fmap . fmap) (Decoder.interval integerDatetimes) $ - query "SELECT $1" [Just p] PQ.Binary - -prop_timestamp = - forAll microsLocalTimeGen $ \x -> - Just (Right (timestampApxRep x)) === do - unsafePerformIO $ do - let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamp) - (Encoder.timestamp integerDatetimes x) - (PQ.Binary) - in (fmap . fmap) (fmap timestampApxRep . Decoder.timestamp integerDatetimes) - (query "SELECT $1" [Just p] PQ.Binary) - -test_timestampParsing1 = - assertEqual (Right (read "2000-01-19 10:41:06" :: LocalTime)) =<< do - fmap (Decoder.timestamp integerDatetimes . fromJust) $ - query "SELECT '2000-01-19 10:41:06' :: timestamp" [] PQ.Binary - -test_timestamptzOffset = - do - c <- connect - initConnection c - PQ.exec c "DROP TABLE IF EXISTS a" - PQ.exec c "CREATE TABLE a (b TIMESTAMPTZ)" - PQ.exec c "set timezone to 'America/Los_Angeles'" - let p = (,,) (PQ.Oid $ fromIntegral o) - (Encoder.timestamptz integerDatetimes x) - (PQ.Binary) - o = PTI.oidOf PTI.timestamptz - x = read "2011-09-28 00:17:25" - PQ.execParams c "insert into a (b) values ($1)" [Just p] PQ.Text - PQ.exec c "set timezone to 'Europe/Stockholm'" - assertEqual (Just "2011-09-28 02:17:25+02") - =<< singleResult - =<< PQ.execParams c "SELECT * FROM a" [] PQ.Text - assertEqual (Just (Right x)) - =<< return . fmap (Decoder.timestamptz integerDatetimes) - =<< singleResult - =<< PQ.execParams c "SELECT * FROM a" [] PQ.Binary - where - singleResult r = PQ.getvalue (fromJust r) 0 0 - -prop_timestamptz = - forAll microsUTCTimeGen $ \x -> - Just (Right (timestamptzApxRep x)) === do - unsafePerformIO $ do - let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timestamptz) - (Encoder.timestamptz integerDatetimes x) - (PQ.Binary) - in (fmap . fmap) (fmap timestamptzApxRep . Decoder.timestamptz integerDatetimes) - (query "SELECT $1" [Just p] PQ.Binary) - -prop_timetz = - forAll ((,) <$> microsTimeOfDayGen <*> timeZoneGen) $ \x -> - Just (Right (timetzApxRep x)) === do - unsafePerformIO $ do - let p = (,,) (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.timetz) - (Encoder.timetz integerDatetimes x) - (PQ.Binary) - in (fmap . fmap) (fmap timetzApxRep . Decoder.timetz integerDatetimes) - (query "SELECT $1" [Just p] PQ.Binary) - -test_timetzParsing = - assertEqual (Right $ timetzApxRep (read "(10:41:06.002897, +0500)" :: (TimeOfDay, TimeZone))) =<< do - connection <- connect - initConnection connection - integerDatetimes <- getIntegerDatetimes connection - Just result <- PQ.execParams connection "SELECT '10:41:06.002897+05' :: timetz" [] PQ.Binary - encodedResult <- PQ.getvalue result 0 0 - PQ.finish connection - return $ fmap timetzApxRep $ - Decoder.timetz integerDatetimes (fromJust encodedResult) - -prop_timeFromIntegerIsomorphism = - forAll microsTimeOfDayGen $ \x -> - Right x === Decoder.time True (Encoder.time True x) - -prop_timeFromDoubleIsomorphism = - forAll microsTimeOfDayGen $ \x -> - let Right x' = Decoder.time False (Encoder.time False x) - in floatEqProp (toFloat x) (toFloat x') - where - toFloat (TimeOfDay h m s) = - s + fromIntegral (60 * (m + 60 * h)) - -prop_time = - forAll microsTimeOfDayGen $ \x -> - Right (timeApxRep x) === do - unsafePerformIO $ do - connection <- connect - initConnection connection - integerDatetimes <- getIntegerDatetimes connection - Just result <- - let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, Encoder.time integerDatetimes x, PQ.Binary)] - in PQ.execParams connection "SELECT $1" params PQ.Binary - encodedResult <- PQ.getvalue result 0 0 - PQ.finish connection - return $ fmap timeApxRep $ - Decoder.time integerDatetimes (fromJust encodedResult) - -prop_timeParsing = - forAll microsTimeOfDayGen $ \x -> - Right (timeApxRep x) === do - unsafePerformIO $ do - connection <- connect - initConnection connection - integerDatetimes <- getIntegerDatetimes connection - Just result <- - let params = [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.time, (fromString . show) x, PQ.Text)] - in PQ.execParams connection "SELECT $1" params PQ.Binary - encodedResult <- PQ.getvalue result 0 0 - PQ.finish connection - return $ fmap timeApxRep $ - Decoder.time integerDatetimes (fromJust encodedResult) - -prop_scientific (c, e) = - let x = Scientific.scientific c e - in - mappingP (PTI.oidOf PTI.numeric) - (nonNullRenderer Encoder.numeric) - (nonNullParser Decoder.numeric) - (x) - -test_scientificParsing1 = - assertEqual (Right (read "-1234560.789" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT -1234560.789 :: numeric" [] PQ.Binary - -test_scientificParsing2 = - assertEqual (Right (read "-0.0789" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT -0.0789 :: numeric" [] PQ.Binary - -test_scientificParsing3 = - assertEqual (Right (read "10000" :: Scientific)) =<< do - fmap (Decoder.numeric . fromJust) $ - query "SELECT 10000 :: numeric" [] PQ.Binary - -prop_scientificParsing (c, e) = - let x = Scientific.scientific c e - in - Right x === do - unsafePerformIO $ - fmap (Decoder.numeric . fromJust) $ - query "SELECT $1 :: numeric" - [Just (PQ.Oid $ fromIntegral $ PTI.oidOf PTI.numeric, (fromString . show) x, PQ.Text)] - PQ.Binary - -prop_float = - mappingP (PTI.oidOf PTI.float4) - (nonNullRenderer Encoder.float4) - (nonNullParser Decoder.float4) - -prop_floatText = - \x -> - floatEqProp x $ do - fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x) - where - pti = PTI.float4 - reader = read . BC.unpack - encoder = nonNullRenderer Encoder.float4 - -prop_double = - mappingP (PTI.oidOf PTI.float8) - (nonNullRenderer Encoder.float8) - (nonNullParser Decoder.float8) - -prop_doubleText = - \x -> - floatEqProp x $ do - fromJust $ unsafePerformIO $ (fmap . fmap) reader $ checkText (PTI.oidOf pti) (encoder x) - where - pti = PTI.float8 - reader = read . BC.unpack - encoder = nonNullRenderer Encoder.float8 - -prop_char x = - (x /= '\NUL') ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer Encoder.char) - (nonNullParser Decoder.char) - (x) - -prop_charText x = - (x /= '\NUL') ==> - mappingTextP (PTI.oidOf PTI.text) - (nonNullRenderer Encoder.char) - (Just . TE.encodeUtf8 . T.singleton) - (x) - -test_emptyArrayElements = - assertEqual [] (Array.elements ([], [], False, 0)) - -test_arrayElements = - assertEqual result (Array.elements arrayData) - where - arrayData = ([(3, 1)], [Just "1", Just "2", Just "3"], False, 0) - result = [([], [Just "1"], False, 0), ([], [Just "2"], False, 0), ([], [Just "3"], False, 0)] - -prop_arrayDataFromAndToListIsomporphism = - forAll arrayGen $ \(oid, x) -> - x === (Array.fromListUnsafe . Array.elements) x - -prop_byteString = - mappingP (PTI.oidOf PTI.bytea) - (nonNullRenderer (Encoder.bytea . Left)) - (nonNullParser Decoder.bytea) - -prop_lazyByteString = - mappingP (PTI.oidOf PTI.bytea) - (nonNullRenderer (Encoder.bytea . Right)) - (nonNullParser (fmap BL.fromStrict . Decoder.bytea)) - -prop_text v = - (isNothing $ T.find (== '\NUL') v) ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer (Encoder.text . Left)) - (nonNullParser Decoder.text) - (v) - -prop_lazyText v = - (isNothing $ TL.find (== '\NUL') v) ==> - mappingP (PTI.oidOf PTI.text) - (nonNullRenderer (Encoder.text . Right)) - (nonNullParser (fmap TL.fromStrict . Decoder.text)) - (v) - -prop_bool = - mappingP (PTI.oidOf PTI.bool) - (nonNullRenderer Encoder.bool) - (nonNullParser Decoder.bool) - -prop_int = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left) . (fromIntegral :: Int -> Int64)) - (nonNullParser Decoder.int) - -prop_int8 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Left) . (fromIntegral :: Int8 -> Int16)) - (nonNullParser Decoder.int) - -prop_int16 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Left)) - (nonNullParser Decoder.int) - -prop_int32 = - mappingP (PTI.oidOf PTI.int4) - (nonNullRenderer (Encoder.int4 . Left)) - (nonNullParser Decoder.int) - -prop_int64 = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left)) - (nonNullParser Decoder.int) - -prop_int64Text = - mappingTextP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Left)) - (Just . fromString . show) - -prop_word = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right) . (fromIntegral :: Word -> Word64)) - (nonNullParser Decoder.int) - -prop_word8 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Right) . (fromIntegral :: Word8 -> Word16)) - (nonNullParser Decoder.int) - -prop_word16 = - mappingP (PTI.oidOf PTI.int2) - (nonNullRenderer (Encoder.int2 . Right)) - (nonNullParser Decoder.int) - -prop_word32 = - mappingP (PTI.oidOf PTI.int4) - (nonNullRenderer (Encoder.int4 . Right)) - (nonNullParser Decoder.int) - -prop_word64 = - mappingP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right)) - (nonNullParser Decoder.int) - -prop_word64Text = - mappingTextP (PTI.oidOf PTI.int8) - (nonNullRenderer (Encoder.int8 . Right)) - (Just . fromString . show) - -prop_day = - mappingP (PTI.oidOf PTI.date) - (nonNullRenderer Encoder.date) - (nonNullParser Decoder.date) - -prop_dayText = - mappingTextP (PTI.oidOf PTI.date) - (nonNullRenderer Encoder.date) - (Just . fromString . show) - -prop_arrayData = - forAll arrayGen $ uncurry $ \oid -> - mappingP (oid) - (nonNullRenderer Encoder.array) - (nonNullParser Decoder.array) - diff --git a/library/PostgreSQL/Binary/BuilderPrim.hs b/library/PostgreSQL/Binary/BuilderPrim.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/BuilderPrim.hs @@ -0,0 +1,9 @@ +module PostgreSQL.Binary.BuilderPrim where + +import qualified Data.ByteString.Builder.Prim as A +import PostgreSQL.Binary.Prelude + +{-# INLINE nullByteIgnoringBoundedPrim #-} +nullByteIgnoringBoundedPrim :: A.BoundedPrim Word8 +nullByteIgnoringBoundedPrim = + A.condB (== 0) A.emptyB (A.liftFixedToBounded A.word8) diff --git a/library/PostgreSQL/Binary/Decoding.hs b/library/PostgreSQL/Binary/Decoding.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Decoding.hs @@ -0,0 +1,778 @@ +module PostgreSQL.Binary.Decoding + ( valueParser, + -- + Value, + + -- * Primitive + int, + float4, + float8, + bool, + bytea_strict, + bytea_lazy, + + -- * Textual + text_strict, + text_lazy, + char, + + -- * Misc + fn, + numeric, + uuid, + inet, + macaddr, + json_ast, + json_bytes, + jsonb_ast, + jsonb_bytes, + + -- * Time + date, + time_int, + time_float, + timetz_int, + timetz_float, + timestamp_int, + timestamp_float, + timestamptz_int, + timestamptz_float, + interval_int, + interval_float, + + -- * Exotic + + -- ** Array + Array, + array, + valueArray, + nullableValueArray, + dimensionArray, + + -- ** Composite + Composite, + composite, + valueComposite, + nullableValueComposite, + typedValueComposite, + typedNullableValueComposite, + + -- ** HStore + hstore, + enum, + refine, + + -- ** Range + int4range, + int8range, + numrange, + tsrange_int, + tsrange_float, + tstzrange_int, + tstzrange_float, + daterange, + + -- ** Multirange + int4multirange, + int8multirange, + nummultirange, + tsmultirange_int, + tsmultirange_float, + tstzmultirange_int, + tstzmultirange_float, + datemultirange, + ) +where + +import BinaryParser +import Control.Monad.Error.Class +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.IP as IP +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy.Encoding as LazyText +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector +import qualified PostgreSQL.Binary.Inet as Inet +import qualified PostgreSQL.Binary.Integral as Integral +import qualified PostgreSQL.Binary.Interval as Interval +import qualified PostgreSQL.Binary.Numeric as Numeric +import PostgreSQL.Binary.Prelude hiding (bool, drop, fail, state, take) +import qualified PostgreSQL.Binary.Range as Range +import qualified PostgreSQL.Binary.Time as Time + +type Value = + BinaryParser + +valueParser :: Value a -> ByteString -> Either Text a +valueParser = + BinaryParser.run + +-- * Helpers + +-- | +-- Any int number of a limited byte-size. +{-# INLINE intOfSize #-} +intOfSize :: (Integral a, Bits a) => Int -> Value a +intOfSize x = + fmap Integral.pack (bytesOfSize x) + +{-# INLINEABLE onContent #-} +onContent :: Value a -> Value (Maybe a) +onContent decoder = + size + >>= \case + (-1) -> pure Nothing + n -> fmap Just (sized (fromIntegral n) decoder) + where + size = + intOfSize 4 :: Value Int32 + +{-# INLINE nonNull #-} +nonNull :: Maybe a -> Value a +nonNull = + maybe (failure "Unexpected NULL") return + +-- * Primitive + +-- | +-- Lifts a custom decoder implementation. +{-# INLINE fn #-} +fn :: (ByteString -> Either Text a) -> Value a +fn fn = + BinaryParser.remainders >>= either BinaryParser.failure return . fn + +{-# INLINE int #-} +int :: (Integral a, Bits a) => Value a +int = + fmap Integral.pack remainders + +float4 :: Value Float +float4 = + unsafeCoerce (int :: Value Int32) + +float8 :: Value Double +float8 = + unsafeCoerce (int :: Value Int64) + +{-# INLINE bool #-} +bool :: Value Bool +bool = + fmap (== 1) byte + +{-# NOINLINE numeric #-} +numeric :: Value Scientific +numeric = + do + componentsAmount <- intOfSize 2 + pointIndex <- intOfSize 2 + signCode <- intOfSize 2 + unitOfSize 2 + components <- Vector.replicateM componentsAmount (intOfSize 2) + either failure return (Numeric.scientific pointIndex signCode components) + +{-# INLINEABLE uuid #-} +uuid :: Value UUID +uuid = + UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 + +{-# INLINE ip4 #-} +ip4 :: Value IP.IPv4 +ip4 = + IP.toIPv4w <$> intOfSize 4 + +{-# INLINE ip6 #-} +ip6 :: Value IP.IPv6 +ip6 = + IP.toIPv6w <$> ((,,,) <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4) + +{-# INLINEABLE inet #-} +inet :: Value IP.IPRange +inet = do + af <- intOfSize 1 + netmask <- intOfSize 1 + isCidr <- intOfSize 1 :: Value Int -- unused + ipSize <- intOfSize 1 :: Value Int -- unused + if + | af == Inet.inetAddressFamily -> + do + ip <- ip4 + return . IP.IPv4Range $ IP.makeAddrRange ip netmask + | af == Inet.inet6AddressFamily -> + do + ip <- ip6 + return . IP.IPv6Range $ IP.makeAddrRange ip netmask + | otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af)) + +{-# INLINEABLE macaddr #-} +macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8) +macaddr = + (,,,,,) <$> byte <*> byte <*> byte <*> byte <*> byte <*> byte + +{-# INLINEABLE json_ast #-} +json_ast :: Value Aeson.Value +json_ast = + bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict' + +-- | +-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, +-- produces a decoder. +{-# INLINEABLE json_bytes #-} +json_bytes :: (ByteString -> Either Text a) -> Value a +json_bytes cont = + getAllBytes >>= parseJSON + where + getAllBytes = + BinaryParser.remainders + parseJSON = + either BinaryParser.failure return . cont + +{-# INLINEABLE jsonb_ast #-} +jsonb_ast :: Value Aeson.Value +jsonb_ast = + jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict' + +-- | +-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, +-- produces a decoder. +-- +-- For those wondering, yes, +-- JSONB is encoded as plain JSON string in the binary format of Postgres. +-- Sad, but true. +{-# INLINEABLE jsonb_bytes #-} +jsonb_bytes :: (ByteString -> Either Text a) -> Value a +jsonb_bytes cont = + getAllBytes >>= trimBytes >>= parseJSON + where + getAllBytes = + BinaryParser.remainders + trimBytes = + maybe (BinaryParser.failure "Empty input") return + . fmap snd + . ByteString.uncons + parseJSON = + either BinaryParser.failure return . cont + +-- ** Textual + +-- | +-- A UTF-8-decoded char. +{-# INLINEABLE char #-} +char :: Value Char +char = + fmap Text.uncons text_strict >>= \case + Just (c, "") -> return c + Nothing -> failure "Empty input" + _ -> failure "Consumed too much" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINEABLE text_strict #-} +text_strict :: Value Text +text_strict = + do + input <- remainders + either (failure . exception input) return (Text.decodeUtf8' input) + where + exception input = + \case + Text.DecodeError _ _ -> fromString ("Failed to decode the following bytes in UTF-8: " <> show input) + _ -> error "Unexpected unicode exception" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINEABLE text_lazy #-} +text_lazy :: Value LazyText +text_lazy = + do + input <- bytea_lazy + either (failure . exception input) return (LazyText.decodeUtf8' input) + where + exception input = + \case + Text.DecodeError _ _ -> fromString ("Failed to decode the following bytes in UTF-8: " <> show input) + _ -> error "Unexpected unicode exception" + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_strict #-} +bytea_strict :: Value ByteString +bytea_strict = + remainders + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_lazy #-} +bytea_lazy :: Value LazyByteString +bytea_lazy = + fmap LazyByteString.fromStrict remainders + +-- * Date and Time + +-- | +-- @DATE@ values decoding. +date :: Value Day +date = + fmap (Time.postgresJulianToDay . fromIntegral) (int :: Value Int32) + +-- | +-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled. +time_int :: Value TimeOfDay +time_int = + fmap Time.microsToTimeOfDay int + +-- | +-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled. +time_float :: Value TimeOfDay +time_float = + fmap Time.secsToTimeOfDay float8 + +-- | +-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled. +timetz_int :: Value (TimeOfDay, TimeZone) +timetz_int = + (,) <$> sized 8 time_int <*> tz + +-- | +-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timetz_float :: Value (TimeOfDay, TimeZone) +timetz_float = + (,) <$> sized 8 time_float <*> tz + +{-# INLINE tz #-} +tz :: Value TimeZone +tz = + fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Value Int32) + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamp_int :: Value LocalTime +timestamp_int = + fmap Time.microsToLocalTime int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamp_float :: Value LocalTime +timestamp_float = + fmap Time.secsToLocalTime float8 + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamptz_int :: Value UTCTime +timestamptz_int = + fmap Time.microsToUTC int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamptz_float :: Value UTCTime +timestamptz_float = + fmap Time.secsToUTC float8 + +-- | +-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled. +interval_int :: Value DiffTime +interval_int = + do + u <- sized 8 int + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + +-- | +-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled. +interval_float :: Value DiffTime +interval_float = + do + u <- sized 8 (fmap (round . (* (10 ^ 6)) . toRational) float8) + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + +-- * Exotic + +-- | +-- A function for generic in place parsing of an HStore value. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines how to produce the final datastructure from the rows. +-- +-- * A decoder for keys. +-- +-- * A decoder for values. +-- +-- Here's how you can use it to produce a parser to list: +-- +-- @ +-- hstoreAsList :: Value [ ( Text , Maybe Text ) ] +-- hstoreAsList = +-- hstore replicateM text text +-- @ +{-# INLINEABLE hstore #-} +hstore :: (forall m. (Monad m) => Int -> m (k, Maybe v) -> m r) -> Value k -> Value v -> Value r +hstore replicateM keyContent valueContent = + do + componentsAmount <- intOfSize 4 + replicateM componentsAmount component + where + component = + (,) <$> key <*> value + where + key = + onContent keyContent >>= nonNull + value = + onContent valueContent + +-- * Composite + +data Composite a + = Composite + -- | Amount of fields. + Int + -- | Decoder for the fields by the current offset. + (Int -> BinaryParser.BinaryParser a) + deriving (Functor) + +instance Applicative Composite where + pure x = Composite 0 (\_ -> pure x) + Composite n f <*> Composite m x = + Composite (n + m) (\offset -> f offset <*> x (offset + n)) + +-- | +-- Unlift a 'Composite' to a value 'Value'. +{-# INLINE composite #-} +composite :: Composite a -> Value a +composite (Composite expectedFields body) = do + actualFields <- intOfSize 4 + if actualFields /= expectedFields + then failure ("Unexpected amount of fields available: " <> fromString (show expectedFields) <> ", expected at least " <> fromString (show (fromIntegral actualFields))) + else body 0 + +-- | +-- Nullable composite field. +{-# INLINE baseFieldValueComposite #-} +baseFieldValueComposite :: BinaryParser a -> Composite a +baseFieldValueComposite parser = + Composite + 1 + ( \fieldIndex -> + catchError + parser + ( \err -> + throwError + ( mconcat + [ "At field ", + fromString (show fieldIndex), + ": ", + err + ] + ) + ) + ) + +-- | +-- Nullable composite field. +{-# INLINE nullableValueComposite #-} +nullableValueComposite :: Value a -> Composite (Maybe a) +nullableValueComposite valueValue = + baseFieldValueComposite (skipOid *> onContent valueValue) + where + skipOid = + unitOfSize 4 + +-- | +-- Lift a non-nullable value 'Value' into 'Composite'. +{-# INLINE valueComposite #-} +valueComposite :: Value a -> Composite a +valueComposite valueValue = + baseFieldValueComposite + (skipOid *> onContent valueValue >>= maybe (failure "Unexpected NULL") return) + where + skipOid = + unitOfSize 4 + +-- | +-- Nullable composite field with a checked type OID. +{-# INLINE typedNullableValueComposite #-} +typedNullableValueComposite :: + -- | Expected type OID. + Word32 -> + Value a -> + Composite (Maybe a) +typedNullableValueComposite expectedOid valueParser = + baseFieldValueComposite + ( do + actualOid <- intOfSize 4 + if actualOid /= expectedOid + then throwError ("Unexpected OID: " <> fromString (show actualOid) <> ", expected " <> fromString (show expectedOid)) + else onContent valueParser + ) + +-- | +-- Non-nullable composite field with a checked type OID. +{-# INLINE typedValueComposite #-} +typedValueComposite :: + -- | Expected type OID. + Word32 -> + Value a -> + Composite a +typedValueComposite expectedOid valueParser = + baseFieldValueComposite + ( do + actualOid <- intOfSize 4 + if actualOid /= expectedOid + then throwError ("Unexpected OID: " <> fromString (show actualOid) <> ", expected " <> fromString (show expectedOid)) + else onContent valueParser >>= maybe (failure "Unexpected NULL") return + ) + +-- * Array + +-- | +-- An efficient generic array decoder, +-- which constructs the result value in place while parsing. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: Value [ [ Text ] ] +-- x = +-- array (dimensionArray replicateM (fmap catMaybes (dimensionArray replicateM (nullableValueArray text)))) +-- @ +newtype Array a + = Array ([Word32] -> Value a) + deriving (Functor) + +-- | +-- Unlift an 'Array' to a value 'Value'. +{-# INLINE array #-} +array :: Array a -> Value a +array (Array decoder) = + do + dimensionsAmount <- intOfSize 4 + if dimensionsAmount /= 0 + then do + unitOfSize (4 + 4) + dimensionSizes <- replicateM dimensionsAmount dimensionSize + decoder dimensionSizes + else decoder [0] + where + dimensionSize = + intOfSize 4 <* unitOfSize 4 + +-- | +-- A function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * A decoder of its components, which can be either another 'dimensionArray' or 'nullableValueArray'. +{-# INLINE dimensionArray #-} +dimensionArray :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b +dimensionArray replicateM (Array component) = + Array $ \case + head : tail -> replicateM (fromIntegral head) (component tail) + _ -> failure "A missing dimension length" + +-- | +-- Lift a value 'Value' into 'Array' for parsing of nullable leaf values. +{-# INLINE nullableValueArray #-} +nullableValueArray :: Value a -> Array (Maybe a) +nullableValueArray = + Array . const . onContent + +-- | +-- Lift a value 'Value' into 'Array' for parsing of non-nullable leaf values. +{-# INLINE valueArray #-} +valueArray :: Value a -> Array a +valueArray = + Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent + +-- * Enum + +-- | +-- Given a partial mapping from text to value, +-- produces a decoder of that value. +{-# INLINE enum #-} +enum :: (Text -> Maybe a) -> Value a +enum mapping = + text_strict >>= onText + where + onText text = + maybe onNothing onJust (mapping text) + where + onNothing = + failure ("No mapping for text \"" <> text <> "\"") + onJust = + pure + +-- * Refining values + +-- | Given additional constraints when +-- using an existing value decoder, produces +-- a decoder of that value. +{-# INLINE refine #-} +refine :: (a -> Either Text b) -> Value a -> Value b +refine fn m = m >>= (either failure pure . fn) + +-- * Range + +-- | +-- One of the range types: +-- +-- * @int4range@ +-- * @int8range@ +-- * @numrange@ +-- * @tsrange@ +-- * @tstzrange@ +-- * @daterange@ +{-# INLINE range #-} +range :: Value a -> Value (Range.Range a) +range decoder = + do + flags <- byte + let emptyRange = testBit flags 0 + lowerInclusive = testBit flags 1 + upperInclusive = testBit flags 2 + lowerInfinite = testBit flags 3 + upperInfinite = testBit flags 4 + if + | emptyRange -> + pure $ Range.Empty + | lowerInfinite && upperInfinite -> + pure $ Range.Range Range.Inf Range.Inf + | lowerInfinite -> + Range.Range <$> pure Range.Inf <*> bound upperInclusive decoder + | upperInfinite -> + Range.Range <$> bound lowerInclusive decoder <*> pure Range.Inf + | otherwise -> + Range.Range <$> bound lowerInclusive decoder <*> bound upperInclusive decoder + where + bound isIncl = + onContent + >=> nonNull + >=> if isIncl then pure . Range.Incl else pure . Range.Excl + +-- | +-- @int4range@ +{-# INLINE int4range #-} +int4range :: Value (Range.Range Int32) +int4range = range int + +-- | +-- @int8range@ +{-# INLINE int8range #-} +int8range :: Value (Range.Range Int64) +int8range = range int + +-- | +-- @numrange@ +{-# INLINE numrange #-} +numrange :: Value (Range.Range Scientific) +numrange = range numeric + +-- | +-- @tsrange@ +{-# INLINE tsrange_int #-} +tsrange_int :: Value (Range.Range LocalTime) +tsrange_int = range timestamp_int + +-- | +-- @tsrange@ +{-# INLINE tsrange_float #-} +tsrange_float :: Value (Range.Range LocalTime) +tsrange_float = range timestamp_float + +-- | +-- @tstzrange@ +{-# INLINE tstzrange_int #-} +tstzrange_int :: Value (Range.Range UTCTime) +tstzrange_int = range timestamptz_int + +-- | +-- @tstzrange@ +{-# INLINE tstzrange_float #-} +tstzrange_float :: Value (Range.Range UTCTime) +tstzrange_float = range timestamptz_float + +-- | +-- @daterange@ +{-# INLINE daterange #-} +daterange :: Value (Range.Range Day) +daterange = range date + +-- * Multirange + +-- | +-- One of the multirange types: +-- +-- * @int4multirange@ +-- * @int8multirange@ +-- * @nummultirange@ +-- * @tsmultirange@ +-- * @tstzmultirange@ +-- * @datemultirange@ +{-# INLINE multirange #-} +multirange :: Value a -> Value (Range.Multirange a) +multirange decoder = + do + rangeCount <- intOfSize 4 + replicateM rangeCount (onContent (range decoder) >>= nonNull) + +-- | +-- @int4multirange@ +{-# INLINE int4multirange #-} +int4multirange :: Value (Range.Multirange Int32) +int4multirange = multirange int + +-- | +-- @int8multirange@ +{-# INLINE int8multirange #-} +int8multirange :: Value (Range.Multirange Int64) +int8multirange = multirange int + +-- | +-- @nummultirange@ +{-# INLINE nummultirange #-} +nummultirange :: Value (Range.Multirange Scientific) +nummultirange = multirange numeric + +-- | +-- @tsmultirange@ +{-# INLINE tsmultirange_int #-} +tsmultirange_int :: Value (Range.Multirange LocalTime) +tsmultirange_int = multirange timestamp_int + +-- | +-- @tsmultirange@ +{-# INLINE tsmultirange_float #-} +tsmultirange_float :: Value (Range.Multirange LocalTime) +tsmultirange_float = multirange timestamp_float + +-- | +-- @tstzmultirange@ +{-# INLINE tstzmultirange_int #-} +tstzmultirange_int :: Value (Range.Multirange UTCTime) +tstzmultirange_int = multirange timestamptz_int + +-- | +-- @tstzmultirange@ +{-# INLINE tstzmultirange_float #-} +tstzmultirange_float :: Value (Range.Multirange UTCTime) +tstzmultirange_float = multirange timestamptz_float + +-- | +-- @datemultirange@ +{-# INLINE datemultirange #-} +datemultirange :: Value (Range.Multirange Day) +datemultirange = multirange date diff --git a/library/PostgreSQL/Binary/Encoding.hs b/library/PostgreSQL/Binary/Encoding.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Encoding.hs @@ -0,0 +1,463 @@ +module PostgreSQL.Binary.Encoding + ( -- * Encoding + Encoding, + encodingBytes, + composite, + array, + array_foldable, + array_vector, + nullableArray_vector, + hStore_foldable, + hStore_hashMap, + hStore_map, + + -- * Primitives + bool, + int2_int16, + int2_word16, + int4_int32, + int4_word32, + int8_int64, + int8_word64, + float4, + float8, + numeric, + uuid, + inet, + macaddr, + char_utf8, + text_strict, + text_lazy, + bytea_strict, + bytea_lazy, + + -- ** Time + + -- | Some of the functions in this section are distinguished based + -- on the @integer_datetimes@ setting of the server. + date, + time_int, + time_float, + timetz_int, + timetz_float, + timestamp_int, + timestamp_float, + timestamptz_int, + timestamptz_float, + interval_int, + interval_float, + + -- ** JSON + json_bytes, + json_bytes_lazy, + json_ast, + jsonb_bytes, + jsonb_bytes_lazy, + jsonb_ast, + + -- * Array + Array, + encodingArray, + nullArray, + dimensionArray, + + -- * Composite + Composite, + field, + nullField, + + -- * Range + int4range, + int8range, + numrange, + tsrange_int, + tsrange_float, + tstzrange_int, + tstzrange_float, + daterange, + + -- * Multirange + int4multirange, + int8multirange, + nummultirange, + tsmultirange_int, + tsmultirange_float, + tstzmultirange_int, + tstzmultirange_float, + datemultirange, + ) +where + +import qualified ByteString.StrictBuilder as C +import qualified Data.Aeson as R +import qualified Data.ByteString.Lazy as N +import qualified Data.IP as G +import qualified Data.Text.Lazy as L +import qualified PostgreSQL.Binary.Encoding.Builders as B +import PostgreSQL.Binary.Prelude hiding (bool, length) +import qualified PostgreSQL.Binary.Range as S + +type Encoding = + C.Builder + +{-# INLINE encodingBytes #-} +encodingBytes :: Encoding -> ByteString +encodingBytes = + C.builderBytes + +-- * Values + +{-# INLINE composite #-} +composite :: Composite -> Encoding +composite (Composite size fields) = + B.int4_int size <> fields + +-- | +-- Turn an array builder into final value. +-- The first parameter is OID of the element type. +{-# INLINE array #-} +array :: Word32 -> Array -> Encoding +array oid (Array payload dimensions nulls) = + B.array oid dimensions nulls payload + +-- | +-- A helper for encoding of arrays of single dimension from foldables. +-- The first parameter is OID of the element type. +{-# INLINE array_foldable #-} +array_foldable :: (Foldable foldable) => Word32 -> (element -> Maybe Encoding) -> foldable element -> Encoding +array_foldable oid elementBuilder = + array oid . dimensionArray foldl' (maybe nullArray encodingArray . elementBuilder) + +-- | +-- A helper for encoding of arrays of single dimension from vectors. +-- The first parameter is OID of the element type. +{-# INLINE array_vector #-} +array_vector :: Word32 -> (element -> Encoding) -> Vector element -> Encoding +array_vector oid elementBuilder vector = + B.array_vector oid elementBuilder vector + +-- | +-- A helper for encoding of arrays of single dimension from vectors. +-- The first parameter is OID of the element type. +{-# INLINE nullableArray_vector #-} +nullableArray_vector :: Word32 -> (element -> Encoding) -> Vector (Maybe element) -> Encoding +nullableArray_vector oid elementBuilder vector = + B.nullableArray_vector oid elementBuilder vector + +-- | +-- A polymorphic @HSTORE@ encoder. +{-# INLINE hStore_foldable #-} +hStore_foldable :: (Foldable foldable) => foldable (Text, Maybe Text) -> Encoding +hStore_foldable = + B.hStoreUsingFoldl foldl + +-- | +-- @HSTORE@ encoder from HashMap. +{-# INLINE hStore_hashMap #-} +hStore_hashMap :: HashMap Text (Maybe Text) -> Encoding +hStore_hashMap = + B.hStore_hashMap + +-- | +-- @HSTORE@ encoder from Map. +{-# INLINE hStore_map #-} +hStore_map :: Map Text (Maybe Text) -> Encoding +hStore_map = + B.hStore_map + +-- * Primitive + +{-# INLINE bool #-} +bool :: Bool -> Encoding +bool = + B.bool + +{-# INLINE int2_int16 #-} +int2_int16 :: Int16 -> Encoding +int2_int16 = + B.int2_int16 + +{-# INLINE int2_word16 #-} +int2_word16 :: Word16 -> Encoding +int2_word16 = + B.int2_word16 + +{-# INLINE int4_int32 #-} +int4_int32 :: Int32 -> Encoding +int4_int32 = + B.int4_int32 + +{-# INLINE int4_word32 #-} +int4_word32 :: Word32 -> Encoding +int4_word32 = + B.int4_word32 + +{-# INLINE int8_int64 #-} +int8_int64 :: Int64 -> Encoding +int8_int64 = + B.int8_int64 + +{-# INLINE int8_word64 #-} +int8_word64 :: Word64 -> Encoding +int8_word64 = + B.int8_word64 + +{-# INLINE float4 #-} +float4 :: Float -> Encoding +float4 = + B.float4 + +{-# INLINE float8 #-} +float8 :: Double -> Encoding +float8 = + B.float8 + +{-# INLINE numeric #-} +numeric :: Scientific -> Encoding +numeric = + B.numeric + +{-# INLINE uuid #-} +uuid :: UUID -> Encoding +uuid = + B.uuid + +{-# INLINE inet #-} +inet :: G.IPRange -> Encoding +inet = + B.inet + +{-# INLINE macaddr #-} +macaddr :: (Word8, Word8, Word8, Word8, Word8, Word8) -> Encoding +macaddr = + B.macaddr + +{-# INLINE char_utf8 #-} +char_utf8 :: Char -> Encoding +char_utf8 = + B.char_utf8 + +{-# INLINE text_strict #-} +text_strict :: Text -> Encoding +text_strict = + B.text_strict + +{-# INLINE text_lazy #-} +text_lazy :: L.Text -> Encoding +text_lazy = + B.text_lazy + +{-# INLINE bytea_strict #-} +bytea_strict :: ByteString -> Encoding +bytea_strict = + B.bytea_strict + +{-# INLINE bytea_lazy #-} +bytea_lazy :: N.ByteString -> Encoding +bytea_lazy = + B.bytea_lazy + +{-# INLINE date #-} +date :: Day -> Encoding +date = + B.date + +{-# INLINE time_int #-} +time_int :: TimeOfDay -> Encoding +time_int = + B.time_int + +{-# INLINE time_float #-} +time_float :: TimeOfDay -> Encoding +time_float = + B.time_float + +{-# INLINE timetz_int #-} +timetz_int :: (TimeOfDay, TimeZone) -> Encoding +timetz_int = + B.timetz_int + +{-# INLINE timetz_float #-} +timetz_float :: (TimeOfDay, TimeZone) -> Encoding +timetz_float = + B.timetz_float + +{-# INLINE timestamp_int #-} +timestamp_int :: LocalTime -> Encoding +timestamp_int = + B.timestamp_int + +{-# INLINE timestamp_float #-} +timestamp_float :: LocalTime -> Encoding +timestamp_float = + B.timestamp_float + +{-# INLINE timestamptz_int #-} +timestamptz_int :: UTCTime -> Encoding +timestamptz_int = + B.timestamptz_int + +{-# INLINE timestamptz_float #-} +timestamptz_float :: UTCTime -> Encoding +timestamptz_float = + B.timestamptz_float + +{-# INLINE interval_int #-} +interval_int :: DiffTime -> Encoding +interval_int = + B.interval_int + +{-# INLINE interval_float #-} +interval_float :: DiffTime -> Encoding +interval_float = + B.interval_float + +{-# INLINE json_bytes #-} +json_bytes :: ByteString -> Encoding +json_bytes = + B.json_bytes + +{-# INLINE json_bytes_lazy #-} +json_bytes_lazy :: N.ByteString -> Encoding +json_bytes_lazy = + B.json_bytes_lazy + +{-# INLINE json_ast #-} +json_ast :: R.Value -> Encoding +json_ast = + B.json_ast + +{-# INLINE jsonb_bytes #-} +jsonb_bytes :: ByteString -> Encoding +jsonb_bytes = + B.jsonb_bytes + +{-# INLINE jsonb_bytes_lazy #-} +jsonb_bytes_lazy :: N.ByteString -> Encoding +jsonb_bytes_lazy = + B.jsonb_bytes_lazy + +{-# INLINE jsonb_ast #-} +jsonb_ast :: R.Value -> Encoding +jsonb_ast = + B.jsonb_ast + +-- * Array + +-- | +-- Abstraction for encoding into multidimensional array. +data Array + = Array !Encoding ![Int32] !Bool + +encodingArray :: Encoding -> Array +encodingArray value = + Array (B.sized value) [] False + +nullArray :: Array +nullArray = + Array B.null4 [] True + +dimensionArray :: (forall b. (b -> a -> b) -> b -> c -> b) -> (a -> Array) -> c -> Array +dimensionArray foldl' elementArray input = + Array builder dimensions nulls + where + dimensions = + foldedLength : foldedDimensions + (builder, foldedDimensions, foldedLength, nulls) = + foldl' step init input + where + init = + (mempty, [], 0, False) + step (!builder, _, !length, !nulls) element = + (builder <> elementBuilder, elementDimensions, succ length, nulls || elementNulls) + where + Array elementBuilder elementDimensions elementNulls = + elementArray element + +-- * Composite + +data Composite + = Composite !Int !Encoding + +instance Semigroup Composite where + Composite lSize lFields <> Composite rSize rFields = + Composite (lSize + rSize) (lFields <> rFields) + +instance Monoid Composite where + mempty = Composite 0 mempty + +field :: Word32 -> Encoding -> Composite +field oid value = + Composite 1 (B.int4_word32 oid <> B.sized value) + +nullField :: Word32 -> Composite +nullField oid = + Composite 1 (B.int4_word32 oid <> B.null4) + +-- * Range + +{-# INLINE int4range #-} +int4range :: S.Range Int32 -> Encoding +int4range = B.range B.int4_int32 + +{-# INLINE int8range #-} +int8range :: S.Range Int64 -> Encoding +int8range = B.range B.int8_int64 + +{-# INLINE numrange #-} +numrange :: S.Range Scientific -> Encoding +numrange = B.range B.numeric + +{-# INLINE tsrange_int #-} +tsrange_int :: S.Range LocalTime -> Encoding +tsrange_int = B.range B.timestamp_int + +{-# INLINE tsrange_float #-} +tsrange_float :: S.Range LocalTime -> Encoding +tsrange_float = B.range B.timestamp_float + +{-# INLINE tstzrange_int #-} +tstzrange_int :: S.Range UTCTime -> Encoding +tstzrange_int = B.range B.timestamptz_int + +{-# INLINE tstzrange_float #-} +tstzrange_float :: S.Range UTCTime -> Encoding +tstzrange_float = B.range B.timestamptz_float + +{-# INLINE daterange #-} +daterange :: S.Range Day -> Encoding +daterange = B.range B.date + +-- * Multirange + +{-# INLINE int4multirange #-} +int4multirange :: S.Multirange Int32 -> Encoding +int4multirange = B.multirange B.int4_int32 + +{-# INLINE int8multirange #-} +int8multirange :: S.Multirange Int64 -> Encoding +int8multirange = B.multirange B.int8_int64 + +{-# INLINE nummultirange #-} +nummultirange :: S.Multirange Scientific -> Encoding +nummultirange = B.multirange B.numeric + +{-# INLINE tsmultirange_int #-} +tsmultirange_int :: S.Multirange LocalTime -> Encoding +tsmultirange_int = B.multirange B.timestamp_int + +{-# INLINE tsmultirange_float #-} +tsmultirange_float :: S.Multirange LocalTime -> Encoding +tsmultirange_float = B.multirange B.timestamp_float + +{-# INLINE tstzmultirange_int #-} +tstzmultirange_int :: S.Multirange UTCTime -> Encoding +tstzmultirange_int = B.multirange B.timestamptz_int + +{-# INLINE tstzmultirange_float #-} +tstzmultirange_float :: S.Multirange UTCTime -> Encoding +tstzmultirange_float = B.multirange B.timestamptz_float + +{-# INLINE datemultirange #-} +datemultirange :: S.Multirange Day -> Encoding +datemultirange = B.multirange B.date diff --git a/library/PostgreSQL/Binary/Encoding/Builders.hs b/library/PostgreSQL/Binary/Encoding/Builders.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Encoding/Builders.hs @@ -0,0 +1,487 @@ +module PostgreSQL.Binary.Encoding.Builders where + +import ByteString.StrictBuilder +import qualified Data.Aeson as R +import qualified Data.ByteString.Builder as M +import qualified Data.ByteString.Lazy as N +import qualified Data.HashMap.Strict as F +import qualified Data.IP as G +import qualified Data.Map.Strict as Q +import qualified Data.Scientific as D +import qualified Data.Text.Encoding as J +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Encoding as K +import qualified Data.UUID as E +import qualified Data.Vector as A +import qualified PostgreSQL.Binary.BuilderPrim as I +import qualified PostgreSQL.Binary.Inet as H +import qualified PostgreSQL.Binary.Interval as P +import qualified PostgreSQL.Binary.Numeric as C +import PostgreSQL.Binary.Prelude hiding (bool) +import qualified PostgreSQL.Binary.Prelude as B +import qualified PostgreSQL.Binary.Range as S +import qualified PostgreSQL.Binary.Time as O + +-- * Helpers + +{-# NOINLINE null4 #-} +null4 :: Builder +null4 = + int4_int (-1) + +{-# INLINE sized #-} +sized :: Builder -> Builder +sized payload = + int4_int (builderLength payload) + <> payload + +{-# INLINE sizedMaybe #-} +sizedMaybe :: (element -> Builder) -> Maybe element -> Builder +sizedMaybe elementBuilder = + B.maybe null4 (sized . elementBuilder) + +{-# NOINLINE true1 #-} +true1 :: Builder +true1 = + word8 1 + +{-# NOINLINE false1 #-} +false1 :: Builder +false1 = + word8 0 + +{-# NOINLINE true4 #-} +true4 :: Builder +true4 = + int4_word32 1 + +{-# NOINLINE false4 #-} +false4 :: Builder +false4 = + int4_word32 0 + +-- * Primitives + +{-# INLINE bool #-} +bool :: Bool -> Builder +bool = + B.bool false1 true1 + +{-# INLINE int2_int16 #-} +int2_int16 :: Int16 -> Builder +int2_int16 = + int16BE + +{-# INLINE int2_word16 #-} +int2_word16 :: Word16 -> Builder +int2_word16 = + word16BE + +{-# INLINE int4_int32 #-} +int4_int32 :: Int32 -> Builder +int4_int32 = + int32BE + +{-# INLINE int4_word32 #-} +int4_word32 :: Word32 -> Builder +int4_word32 = + word32BE + +{-# INLINE int4_int #-} +int4_int :: Int -> Builder +int4_int = + int4_int32 . fromIntegral + +{-# INLINE int8_int64 #-} +int8_int64 :: Int64 -> Builder +int8_int64 = + int64BE + +{-# INLINE int8_word64 #-} +int8_word64 :: Word64 -> Builder +int8_word64 = + word64BE + +{-# INLINE float4 #-} +float4 :: Float -> Builder +float4 = + int4_int32 . unsafeCoerce + +{-# INLINE float8 #-} +float8 :: Double -> Builder +float8 = + int8_int64 . unsafeCoerce + +{-# INLINEABLE numeric #-} +numeric :: Scientific -> Builder +numeric x = + word16BE (fromIntegral componentsAmount) + <> word16BE (fromIntegral pointIndex) + <> signCode + <> word16BE (fromIntegral trimmedExponent) + <> foldMap word16BE components + where + componentsAmount = + length components + coefficient = + D.coefficient x + exponent = + D.base10Exponent x + components = + C.extractComponents tunedCoefficient + pointIndex = + componentsAmount + (tunedExponent `div` 4) - 1 + (tunedCoefficient, tunedExponent) = + case mod exponent 4 of + 0 -> (coefficient, exponent) + x -> (coefficient * 10 ^ x, exponent - x) + trimmedExponent = + if tunedExponent >= 0 + then 0 + else negate tunedExponent + signCode = + if coefficient < 0 + then numericNegSignCode + else numericPosSignCode + +{-# NOINLINE numericNegSignCode #-} +numericNegSignCode :: Builder +numericNegSignCode = + int2_word16 C.negSignCode + +{-# NOINLINE numericPosSignCode #-} +numericPosSignCode :: Builder +numericPosSignCode = + int2_word16 C.posSignCode + +{-# INLINE uuid #-} +uuid :: UUID -> Builder +uuid uuid = + case E.toWords uuid of + (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 + +{-# INLINEABLE ip4 #-} +ip4 :: G.IPv4 -> Builder +ip4 = + int4_word32 . G.fromIPv4w + +{-# INLINEABLE ip6 #-} +ip6 :: G.IPv6 -> Builder +ip6 x = + case G.fromIPv6w x of + (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 + +{-# INLINEABLE ip4range #-} +ip4range :: G.AddrRange G.IPv4 -> Builder +ip4range x = + case G.addrRangePair x of + (addr, mlen) -> inetAddressFamily <> netLength mlen <> isCidr <> ip4Size <> ip4 addr + where + netLength = + word8 . fromIntegral + isCidr = + false1 + +{-# INLINEABLE ip6range #-} +ip6range :: G.AddrRange G.IPv6 -> Builder +ip6range x = + case G.addrRangePair x of + (addr, mlen) -> inet6AddressFamily <> netLength mlen <> isCidr <> ip6Size <> ip6 addr + where + netLength = + word8 . fromIntegral + isCidr = + false1 + +{-# INLINEABLE inet #-} +inet :: G.IPRange -> Builder +inet (G.IPv4Range x) = ip4range x +inet (G.IPv6Range x) = ip6range x + +{-# NOINLINE inetAddressFamily #-} +inetAddressFamily :: Builder +inetAddressFamily = + word8 H.inetAddressFamily + +{-# NOINLINE inet6AddressFamily #-} +inet6AddressFamily :: Builder +inet6AddressFamily = + word8 H.inet6AddressFamily + +{-# NOINLINE ip4Size #-} +ip4Size :: Builder +ip4Size = + word8 4 + +{-# NOINLINE ip6Size #-} +ip6Size :: Builder +ip6Size = + word8 16 + +{-# INLINEABLE macaddr #-} +macaddr :: (Word8, Word8, Word8, Word8, Word8, Word8) -> Builder +macaddr (a, b, c, d, e, f) = + word8 a <> word8 b <> word8 c <> word8 d <> word8 e <> word8 f + +-- * Text + +-- | +-- A UTF-8-encoded char. +-- +-- Note that since it's UTF-8-encoded +-- not the \"char\" but the \"text\" OID should be used with it. +{-# INLINE char_utf8 #-} +char_utf8 :: Char -> Builder +char_utf8 = + utf8Char + +{-# INLINE text_strict #-} +text_strict :: Text -> Builder +text_strict = + bytea_lazyBuilder . J.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim + +{-# INLINE text_lazy #-} +text_lazy :: L.Text -> Builder +text_lazy = + bytea_lazyBuilder . K.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim + +{-# INLINE bytea_strict #-} +bytea_strict :: ByteString -> Builder +bytea_strict = + bytes + +{-# INLINE bytea_lazy #-} +bytea_lazy :: N.ByteString -> Builder +bytea_lazy = + lazyBytes + +{-# INLINE bytea_lazyBuilder #-} +bytea_lazyBuilder :: M.Builder -> Builder +bytea_lazyBuilder = + lazyBytes . M.toLazyByteString + +-- * Time + +{-# INLINE date #-} +date :: Day -> Builder +date = + int4_int32 . fromIntegral . O.dayToPostgresJulian + +{-# INLINEABLE time_int #-} +time_int :: TimeOfDay -> Builder +time_int (TimeOfDay h m s) = + let p = unsafeCoerce s :: Integer + u = p `div` (10 ^ 6) + in int8_int64 (fromIntegral u + 10 ^ 6 * 60 * (fromIntegral m + 60 * fromIntegral h)) + +{-# INLINEABLE time_float #-} +time_float :: TimeOfDay -> Builder +time_float (TimeOfDay h m s) = + let p = unsafeCoerce s :: Integer + u = p `div` (10 ^ 6) + in float8 (fromIntegral u / 10 ^ 6 + 60 * (fromIntegral m + 60 * (fromIntegral h))) + +{-# INLINE timetz_int #-} +timetz_int :: (TimeOfDay, TimeZone) -> Builder +timetz_int (timeX, tzX) = + time_int timeX <> tz tzX + +{-# INLINE timetz_float #-} +timetz_float :: (TimeOfDay, TimeZone) -> Builder +timetz_float (timeX, tzX) = + time_float timeX <> tz tzX + +{-# INLINE tz #-} +tz :: TimeZone -> Builder +tz = + int4_int . (* 60) . negate . timeZoneMinutes + +{-# INLINE timestamp_int #-} +timestamp_int :: LocalTime -> Builder +timestamp_int = + int8_int64 . O.localTimeToMicros + +{-# INLINE timestamp_float #-} +timestamp_float :: LocalTime -> Builder +timestamp_float = + float8 . O.localTimeToSecs + +{-# INLINE timestamptz_int #-} +timestamptz_int :: UTCTime -> Builder +timestamptz_int = + int8_int64 . O.utcToMicros + +{-# INLINE timestamptz_float #-} +timestamptz_float :: UTCTime -> Builder +timestamptz_float = + float8 . O.utcToSecs + +{-# INLINEABLE interval_int #-} +interval_int :: DiffTime -> Builder +interval_int x = + int64BE u + <> int32BE d + <> int32BE m + where + P.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) + $ P.fromDiffTime x + +{-# INLINEABLE interval_float #-} +interval_float :: DiffTime -> Builder +interval_float x = + float8 s + <> int32BE d + <> int32BE m + where + P.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) + $ P.fromDiffTime x + s = + fromIntegral u / (10 ^ 6) + +-- * JSON + +{-# INLINE json_bytes #-} +json_bytes :: ByteString -> Builder +json_bytes = + bytes + +{-# INLINE json_bytes_lazy #-} +json_bytes_lazy :: N.ByteString -> Builder +json_bytes_lazy = + lazyBytes + +{-# INLINE json_ast #-} +json_ast :: R.Value -> Builder +json_ast = + lazyBytes . R.encode + +{-# INLINE jsonb_bytes #-} +jsonb_bytes :: ByteString -> Builder +jsonb_bytes = + mappend "\1" . bytes + +{-# INLINE jsonb_bytes_lazy #-} +jsonb_bytes_lazy :: N.ByteString -> Builder +jsonb_bytes_lazy = + mappend "\1" . lazyBytes + +{-# INLINE jsonb_ast #-} +jsonb_ast :: R.Value -> Builder +jsonb_ast = + mappend "\1" . json_ast + +-- * Array + +{-# INLINE array_vector #-} +array_vector :: Word32 -> (element -> Builder) -> Vector element -> Builder +array_vector oid elementBuilder vector = + array oid dimensions False payload + where + dimensions = + [fromIntegral (A.length vector)] + payload = + foldMap (sized . elementBuilder) vector + +{-# INLINE nullableArray_vector #-} +nullableArray_vector :: Word32 -> (element -> Builder) -> Vector (Maybe element) -> Builder +nullableArray_vector oid elementBuilder vector = + array oid dimensions True payload + where + dimensions = + [fromIntegral (A.length vector)] + payload = + foldMap (sizedMaybe elementBuilder) vector + +{-# INLINEABLE array #-} +array :: Word32 -> [Int32] -> Bool -> Builder -> Builder +array oid dimensions nulls payload = + int4_int (B.length dimensions) + <> B.bool false4 true4 nulls + <> int4_word32 oid + <> foldMap arrayDimension dimensions + <> payload + +{-# INLINE arrayDimension #-} +arrayDimension :: Int32 -> Builder +arrayDimension dimension = + int4_int32 dimension <> true4 + +-- * HStore + +-- | +-- A polymorphic in-place @HSTORE@ encoder. +-- +-- Accepts: +-- +-- * An implementation of the @foldl@ function +-- (e.g., @Data.Foldable.'foldl''@), +-- which determines the input value. +-- +-- Here's how you can use it to produce a specific encoder: +-- +-- @ +-- hashMapHStore :: Data.HashMap.Strict.HashMap Text (Maybe Text) -> Builder +-- hashMapHStore = +-- hStoreUsingFoldl foldl' +-- @ +{-# INLINEABLE hStoreUsingFoldl #-} +hStoreUsingFoldl :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> b -> Builder +hStoreUsingFoldl foldl = + exit . foldl progress enter + where + enter = + (0, mempty) + progress (!count, !payload) (key, value) = + (succ count, payload <> hStoreRow key value) + exit (count, payload) = + int4_int count <> payload + +{-# INLINE hStoreUsingFoldMapAndSize #-} +hStoreUsingFoldMapAndSize :: (forall a. (Monoid a) => ((Text, Maybe Text) -> a) -> b -> a) -> Int -> b -> Builder +hStoreUsingFoldMapAndSize foldMap size input = + int4_int size <> foldMap (uncurry hStoreRow) input + +{-# INLINE hStoreFromFoldMapAndSize #-} +hStoreFromFoldMapAndSize :: (forall a. (Monoid a) => (Text -> Maybe Text -> a) -> a) -> Int -> Builder +hStoreFromFoldMapAndSize foldMap size = + int4_int size <> foldMap hStoreRow + +{-# INLINE hStoreRow #-} +hStoreRow :: Text -> Maybe Text -> Builder +hStoreRow key value = + sized (text_strict key) <> sizedMaybe text_strict value + +{-# INLINE hStore_hashMap #-} +hStore_hashMap :: HashMap Text (Maybe Text) -> Builder +hStore_hashMap input = + int4_int (F.size input) + <> F.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input + +{-# INLINE hStore_map #-} +hStore_map :: Map Text (Maybe Text) -> Builder +hStore_map input = + int4_int (Q.size input) + <> Q.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input + +{-# INLINE range #-} +range :: (a -> Builder) -> S.Range a -> Builder +range builder r = + case r of + S.Empty -> word8 0x01 + S.Range S.Inf S.Inf -> word8 0x18 + S.Range (S.Excl l) (S.Excl r) -> word8 0x00 <> sized (builder l) <> sized (builder r) + S.Range (S.Incl l) (S.Excl r) -> word8 0x02 <> sized (builder l) <> sized (builder r) + S.Range (S.Excl l) (S.Incl r) -> word8 0x04 <> sized (builder l) <> sized (builder r) + S.Range (S.Incl l) (S.Incl r) -> word8 0x06 <> sized (builder l) <> sized (builder r) + S.Range (S.Excl l) S.Inf -> word8 0x10 <> sized (builder l) + S.Range (S.Incl l) S.Inf -> word8 0x12 <> sized (builder l) + S.Range S.Inf (S.Excl r) -> word8 0x08 <> sized (builder r) + S.Range S.Inf (S.Incl r) -> word8 0x0C <> sized (builder r) + +{-# INLINE multirange #-} +multirange :: (a -> Builder) -> S.Multirange a -> Builder +multirange builder ranges = + int4_int (fromIntegral (length ranges)) + <> foldMap (sized . range builder) ranges diff --git a/library/PostgreSQL/Binary/Inet.hs b/library/PostgreSQL/Binary/Inet.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Inet.hs @@ -0,0 +1,13 @@ +module PostgreSQL.Binary.Inet where + +import PostgreSQL.Binary.Prelude + +-- | Address family AF_INET +inetAddressFamily :: Word8 +inetAddressFamily = + 2 + +-- | Address family AF_INET6 +inet6AddressFamily :: Word8 +inet6AddressFamily = + 3 diff --git a/library/PostgreSQL/Binary/Integral.hs b/library/PostgreSQL/Binary/Integral.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Integral.hs @@ -0,0 +1,19 @@ +-- | +-- Utils for dealing with integer numbers. +module PostgreSQL.Binary.Integral where + +import qualified Data.ByteString as B +import PostgreSQL.Binary.Prelude + +{-# INLINEABLE pack #-} +pack :: (Bits a, Num a) => B.ByteString -> a +pack = + B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 + +{-# INLINE unpackBySize #-} +unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString +unpackBySize n x = + B.pack $ map f $ reverse [0 .. n - 1] + where + f s = + fromIntegral $ shiftR x (8 * s) diff --git a/library/PostgreSQL/Binary/Interval.hs b/library/PostgreSQL/Binary/Interval.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Interval.hs @@ -0,0 +1,49 @@ +module PostgreSQL.Binary.Interval where + +import PostgreSQL.Binary.Prelude hiding (months) +import qualified PostgreSQL.Binary.Time as Time + +data Interval = Interval + { micros :: Int64, + days :: Int32, + months :: Int32 + } + deriving (Show, Eq) + +-- | +-- Oddly enough despite a claim of support of up to 178000000 years in +-- +-- in practice it starts behaving unpredictably after a smaller limit. +maxDiffTime :: DiffTime +maxDiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros + +minDiffTime :: DiffTime +minDiffTime = negate maxDiffTime + +fromDiffTime :: DiffTime -> Maybe Interval +fromDiffTime x = + if x > maxDiffTime || x < minDiffTime + then Nothing + else Just $ fromPicosUnsafe (unsafeCoerce x) + +fromPicosUnsafe :: Integer -> Interval +fromPicosUnsafe = + evalState $ do + modify $ flip div (10 ^ 6) + u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) + d <- state $ swap . flip divMod (31) + m <- get + return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m) + +toDiffTime :: Interval -> DiffTime +toDiffTime x = + picosecondsToDiffTime + $ (10 ^ 6) + * ( fromIntegral (micros x) + + 10 + ^ 6 + * 60 + * 60 + * 24 + * (fromIntegral (days x + 31 * months x)) + ) diff --git a/library/PostgreSQL/Binary/Numeric.hs b/library/PostgreSQL/Binary/Numeric.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Numeric.hs @@ -0,0 +1,76 @@ +module PostgreSQL.Binary.Numeric where + +import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector +import PostgreSQL.Binary.Prelude + +{-# INLINE posSignCode #-} +posSignCode :: Word16 +posSignCode = 0x0000 + +{-# INLINE negSignCode #-} +negSignCode :: Word16 +negSignCode = 0x4000 + +{-# INLINE nanSignCode #-} +nanSignCode :: Word16 +nanSignCode = 0xC000 + +{-# INLINE extractComponents #-} +extractComponents :: (Integral a) => a -> [Word16] +extractComponents = + (reverse .) . (. abs) . unfoldr $ \case + 0 -> Nothing + x -> case divMod x 10000 of + (d, m) -> Just (fromIntegral m, d) + +{-# INLINE mergeComponents #-} +mergeComponents :: (Integral a) => Vector a -> Integer +mergeComponents = + Vector.foldl' (\l r -> l * 10000 + fromIntegral r) 0 + +{-# INLINE mergeDigits #-} +mergeDigits :: (Integral a) => Vector a -> a +mergeDigits = + Vector.foldl' (\l r -> l * 10 + r) 0 + +-- | +-- Unpack a component into digits. +{-# INLINE componentDigits #-} +componentDigits :: Int16 -> [Int16] +componentDigits = + evalState $ do + a <- state (flip divMod 1000) + b <- state (flip divMod 100) + c <- state (flip divMod 10) + d <- get + return $ [a, b, c, d] + +{-# INLINEABLE componentsReplicateM #-} +componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a +componentsReplicateM amount component = + foldl' folder (pure 0) (replicate amount component) + where + folder acc component = + liftA2 (+) (fmap (* 10000) acc) component + +{-# INLINE signer #-} +signer :: (Integral a) => Word16 -> Either Text (a -> a) +signer = + \case + 0x0000 -> return id + 0x4000 -> return negate + 0xC000 -> Left "NAN sign" + signCode -> Left ("Unexpected sign code: " <> (fromString . show) signCode) + +{-# INLINE scientific #-} +scientific :: Int16 -> Word16 -> Vector Word16 -> Either Text Scientific +scientific pointIndex signCode components = + do + theSigner <- signer signCode + return (Scientific.scientific (c theSigner) e) + where + c signer = + signer (mergeComponents components) + e = + (fromIntegral pointIndex + 1 - Vector.length components) * 4 diff --git a/library/PostgreSQL/Binary/Prelude.hs b/library/PostgreSQL/Binary/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Prelude.hs @@ -0,0 +1,112 @@ +module PostgreSQL.Binary.Prelude + ( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + mapLeft, + joinMap, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports hiding (first, second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import qualified Data.ByteString.Builder +import qualified Data.ByteString.Lazy +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Identity as Exports +import Data.HashMap.Strict as Exports (HashMap) +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports hiding (range) +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) +import Data.Map.Strict as Exports (Map) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Scientific as Exports (Scientific) +import Data.Semigroup as Exports +import Data.String as Exports +import Data.Text as Exports (Text) +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import Data.Time as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.UUID as Exports (UUID) +import Data.Unique as Exports +import Data.Vector as Exports (Vector) +import Data.Version as Exports +import Data.Void as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, sizeOf) +import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic, Generic1) +import GHC.IO.Exception as Exports +import Numeric as Exports +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder + +{-# INLINE mapLeft #-} +mapLeft :: (a -> b) -> Either a x -> Either b x +mapLeft f = + either (Left . f) Right + +joinMap :: (Monad m) => (a -> m b) -> m a -> m b +joinMap f = + join . liftM f diff --git a/library/PostgreSQL/Binary/Range.hs b/library/PostgreSQL/Binary/Range.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Range.hs @@ -0,0 +1,11 @@ +module PostgreSQL.Binary.Range where + +import PostgreSQL.Binary.Prelude + +data Range a = Empty | Range !(Bound a) !(Bound a) + deriving (Eq, Show, Ord, Generic) + +data Bound a = Incl !a | Excl !a | Inf + deriving (Eq, Show, Ord, Generic) + +type Multirange a = [Range a] diff --git a/library/PostgreSQL/Binary/Time.hs b/library/PostgreSQL/Binary/Time.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Time.hs @@ -0,0 +1,138 @@ +module PostgreSQL.Binary.Time where + +import PostgreSQL.Binary.Prelude hiding (second) + +{-# INLINEABLE dayToPostgresJulian #-} +dayToPostgresJulian :: Day -> Integer +dayToPostgresJulian = + (+ (2400001 - 2451545)) . toModifiedJulianDay + +{-# INLINEABLE postgresJulianToDay #-} +postgresJulianToDay :: (Integral a) => a -> Day +postgresJulianToDay = + ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) + +{-# INLINEABLE microsToTimeOfDay #-} +microsToTimeOfDay :: Int64 -> TimeOfDay +microsToTimeOfDay = + evalState $ do + h <- state $ flip divMod $ 10 ^ 6 * 60 * 60 + m <- state $ flip divMod $ 10 ^ 6 * 60 + u <- get + return + $ TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) + +{-# INLINEABLE microsToUTC #-} +microsToUTC :: Int64 -> UTCTime +microsToUTC = + evalState $ do + d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 + u <- get + return + $ UTCTime (postgresJulianToDay d) (microsToDiffTime u) + +{-# INLINEABLE microsToPico #-} +microsToPico :: Int64 -> Pico +microsToPico = + unsafeCoerce . (* (10 ^ 6)) . (fromIntegral :: Int64 -> Integer) + +{-# INLINEABLE microsToDiffTime #-} +microsToDiffTime :: Int64 -> DiffTime +microsToDiffTime = + unsafeCoerce microsToPico + +{-# INLINEABLE microsToLocalTime #-} +microsToLocalTime :: Int64 -> LocalTime +microsToLocalTime = + evalState $ do + d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 + u <- get + return + $ LocalTime (postgresJulianToDay d) (microsToTimeOfDay u) + +{-# INLINEABLE secsToTimeOfDay #-} +secsToTimeOfDay :: Double -> TimeOfDay +secsToTimeOfDay = + evalState $ do + h <- state $ flip divMod' $ 60 * 60 + m <- state $ flip divMod' $ 60 + s <- get + return + $ TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s) + +{-# INLINEABLE secsToUTC #-} +secsToUTC :: Double -> UTCTime +secsToUTC = + evalState $ do + d <- state $ flip divMod' $ 60 * 60 * 24 + s <- get + return + $ UTCTime (postgresJulianToDay d) (secsToDiffTime s) + +{-# INLINEABLE secsToLocalTime #-} +secsToLocalTime :: Double -> LocalTime +secsToLocalTime = + evalState $ do + d <- state $ flip divMod' $ 60 * 60 * 24 + s <- get + return + $ LocalTime (postgresJulianToDay d) (secsToTimeOfDay s) + +{-# INLINEABLE secsToPico #-} +secsToPico :: Double -> Pico +secsToPico s = + unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer) + +{-# INLINEABLE secsToDiffTime #-} +secsToDiffTime :: Double -> DiffTime +secsToDiffTime = + unsafeCoerce secsToPico + +{-# INLINEABLE localTimeToMicros #-} +localTimeToMicros :: LocalTime -> Int64 +localTimeToMicros (LocalTime dayX timeX) = + let d = dayToPostgresJulian dayX + p = unsafeCoerce $ timeOfDayToTime timeX + in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) + +{-# INLINEABLE localTimeToSecs #-} +localTimeToSecs :: LocalTime -> Double +localTimeToSecs (LocalTime dayX timeX) = + let d = dayToPostgresJulian dayX + p = unsafeCoerce $ timeOfDayToTime timeX + in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10 ^ 12)) + +{-# INLINEABLE utcToMicros #-} +utcToMicros :: UTCTime -> Int64 +utcToMicros (UTCTime dayX diffTimeX) = + let d = dayToPostgresJulian dayX + p = unsafeCoerce diffTimeX + in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) + +{-# INLINEABLE utcToSecs #-} +utcToSecs :: UTCTime -> Double +utcToSecs (UTCTime dayX diffTimeX) = + let d = dayToPostgresJulian dayX + p = unsafeCoerce diffTimeX + in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10 ^ 12)) + +-- * Constants in microseconds according to Julian dates standard + +-- According to +-- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html +-- Postgres uses Julian dates internally + +yearMicros :: Int64 +yearMicros = truncate (365.2425 * fromIntegral dayMicros :: Rational) + +dayMicros :: Int64 +dayMicros = 24 * hourMicros + +hourMicros :: Int64 +hourMicros = 60 * minuteMicros + +minuteMicros :: Int64 +minuteMicros = 60 * secondMicros + +secondMicros :: Int64 +secondMicros = 10 ^ 6 diff --git a/library/PostgreSQLBinary/Array.hs b/library/PostgreSQLBinary/Array.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Array.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | --- An intermediate array representation --- and utilities for its (de)composition. -module PostgreSQLBinary.Array where - -import PostgreSQLBinary.Prelude hiding (Data) - - --- | --- A representation of a data serializable to the PostgreSQL array binary format. --- --- Consists of a list of dimensions, a list of encoded elements, --- a flag specifying, whether it contains any nulls, and an oid. -type Data = ([Dimension], [Value], Bool, Word32) - --- | --- A width and a lower bound. --- --- Currently the lower bound is only allowed to have a value of @1@. -type Dimension = (Word32, Word32) - --- | --- An encoded value. 'Nothing' if it represents a @NULL@. -type Value = Maybe ByteString - --- | --- Access a value of data, if the data represents a single value. -asSingleton :: Data -> Maybe Value -asSingleton (dimensions, elements, nulls, oid) = - if null dimensions - then case elements of - [x] -> return x - l -> $bug $ "Unexpected amount of elements: " <> show l - else mzero - --- | --- Construct from a non-empty list, --- taking the shared parameters from the first element. -fromListUnsafe :: [Data] -> Data -fromListUnsafe list = - case list of - (dimensions, values, nulls, oid) : tail -> - ((fromIntegral $ length list, 1) : dimensions, values <> foldMap valuesOf tail, nulls, oid) - where - valuesOf (_, x, _, _) = x - _ -> - error "Empty list" - -fromSingleton :: Value -> Bool -> Word32 -> Data -fromSingleton value nullable oid = - ([], [value], nullable, oid) - --- | --- Get a list of elements. -elements :: Data -> [Data] -elements (dimensions, values, nulls, oid) = - do - subvalues <- slice values - return (subdimensions, subvalues, nulls, oid) - where - ((width, lowerBound), subdimensions) = - case dimensions of - h : t -> (h, t) - _ -> ((0, 1), []) - chunkSize = - if null subdimensions - then 1 - else product $ map dimensionWidth $ subdimensions - where - dimensionWidth (x, _) = fromIntegral x - slice = - foldr (\f g l -> case f l of (a, b) -> a : g b) (const mzero) $ - replicate (fromIntegral width) (splitAt chunkSize) diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Decoder.hs +++ /dev/null @@ -1,175 +0,0 @@ -module PostgreSQLBinary.Decoder where - -import PostgreSQLBinary.Prelude hiding (bool) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified PostgreSQLBinary.Decoder.Zepto as Zepto -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified PostgreSQLBinary.Interval as Interval - - --- | --- A function for decoding a byte string into a value. -type D a = ByteString -> Either Text a - - --- * Numbers -------------------------- - --- | --- Any of PostgreSQL integer types. -{-# INLINABLE int #-} -int :: (Integral a, Bits a) => D a -int = - Right . Integral.pack - -{-# INLINABLE float4 #-} -float4 :: D Float -float4 = - unsafeCoerce (int :: D Word32) - -{-# INLINABLE float8 #-} -float8 :: D Double -float8 = - unsafeCoerce (int :: D Word64) - -{-# INLINABLE numeric #-} -numeric :: D Scientific -numeric = - flip Zepto.run (inline Zepto.numeric) - - --- * Text -------------------------- - --- | --- A UTF-8-encoded char. -{-# INLINABLE char #-} -char :: D Char -char x = - maybe (Left "Empty input") (return . fst) . T.uncons =<< text x - --- | --- Any of the variable-length character types: --- BPCHAR, VARCHAR, NAME and TEXT. -{-# INLINABLE text #-} -text :: D Text -text = - either (Left . fromString . show) Right . TE.decodeUtf8' - -{-# INLINE bytea #-} -bytea :: D ByteString -bytea = - Right - --- * Date and Time -------------------------- - -{-# INLINABLE date #-} -date :: D Day -date = - fmap (Time.postgresJulianToDay . fromIntegral) . (int :: D Int32) - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE time #-} -time :: Bool -> D TimeOfDay -time = - \case - True -> - fmap Time.microsToTimeOfDay . int - False -> - fmap Time.secsToTimeOfDay . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timetz #-} -timetz :: Bool -> D (TimeOfDay, TimeZone) -timetz integer_datetimes = - \x -> - let (timeX, zoneX) = B.splitAt 8 x - in (,) <$> time integer_datetimes timeX <*> tz zoneX - where - tz = - fmap (minutesToTimeZone . negate . (`div` 60) . fromIntegral) . (int :: D Int32) - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timestamptz #-} -timestamp :: Bool -> D LocalTime -timestamp = - \case - True -> - fmap Time.microsToLocalTime . int - False -> - fmap Time.secsToLocalTime . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timestamp #-} -timestamptz :: Bool -> D UTCTime -timestamptz = - \case - True -> - fmap Time.microsToUTC . int - False -> - fmap Time.secsToUTC . float8 - --- | --- The decoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE interval #-} -interval :: Bool -> D DiffTime -interval integerDatetimes = - evalState $ do - t <- state $ B.splitAt 8 - d <- state $ B.splitAt 4 - m <- get - return $ do - ux <- if integerDatetimes - then int t - else float8 t >>= return . round . (* (10^6)) . toRational - dx <- int d - mx <- int m - return $ Interval.toDiffTime $ Interval.Interval ux dx mx - - --- * Misc -------------------------- - -{-# INLINABLE bool #-} -bool :: D Bool -bool b = - case B.uncons b of - Just (0, _) -> return False - Just (1, _) -> return True - _ -> Left ("Invalid value: " <> (fromString . show) b) - -{-# INLINABLE uuid #-} -uuid :: D UUID -uuid = - evalStateT $ - UUID.fromWords <$> word <*> word <*> word <*> word - where - word = - lift . int =<< state (B.splitAt 4) - - --- | --- Arbitrary array. --- --- Returns an intermediate representation, --- which can then be used to decode into a specific data type. -{-# INLINABLE array #-} -array :: D Array.Data -array = - flip Zepto.run Zepto.array diff --git a/library/PostgreSQLBinary/Decoder/Zepto.hs b/library/PostgreSQLBinary/Decoder/Zepto.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Decoder/Zepto.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | --- Composable Attoparsec parsers. -module PostgreSQLBinary.Decoder.Zepto where - -import PostgreSQLBinary.Prelude hiding (take, bool) -import Data.Attoparsec.Zepto -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified Data.Scientific as Scientific - - -{-# INLINE run #-} -run :: ByteString -> Parser a -> Either Text a -run input parser = - either (Left . fromString . show) Right $ parse parser input - -{-# INLINE endOfInput #-} -endOfInput :: Parser () -endOfInput = - atEnd >>= \case True -> return (); False -> fail "Not an end of input" - -{-# INLINE intOfSize #-} -intOfSize :: (Integral a, Bits a) => Int -> Parser a -intOfSize x = - Integral.pack <$> take x - -{-# INLINABLE array #-} -array :: Parser Array.Data -array = - do - dimensionsAmountV <- intOfSize 4 - nullsV <- nulls - oidV <- intOfSize 4 - dimensionsV <- replicateM dimensionsAmountV dimension - valuesV <- many value - return (dimensionsV, valuesV, nullsV, oidV) - where - dimension = - (,) <$> intOfSize 4 <*> intOfSize 4 - value = - nothing <|> just - where - nothing = - string (Integral.unpack (-1 :: Word32)) *> pure Nothing - just = - Just <$> (take =<< intOfSize 4) - nulls = - (intOfSize 4 :: Parser Word32) >>= \case - 0 -> return False - 1 -> return True - w -> fail $ "Invalid value: " <> show w - -{-# INLINE numeric #-} -numeric :: Parser Scientific -numeric = - do - componentsAmount <- intOfSize 2 - pointIndex :: Int16 <- intOfSize 2 - signCode <- intOfSize 2 - take 2 - components <- replicateM componentsAmount (intOfSize 2) - signer <- - if | signCode == Numeric.negSignCode -> return negate - | signCode == Numeric.posSignCode -> return id - | signCode == Numeric.nanSignCode -> fail "NAN sign" - | otherwise -> fail $ "Unexpected sign value: " <> show signCode - let - c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64) - e = (fromIntegral (pointIndex + 1) - length components) * 4 - in return $ Scientific.scientific c e diff --git a/library/PostgreSQLBinary/Encoder.hs b/library/PostgreSQLBinary/Encoder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Encoder.hs +++ /dev/null @@ -1,174 +0,0 @@ -module PostgreSQLBinary.Encoder where - -import PostgreSQLBinary.Prelude -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import qualified PostgreSQLBinary.Encoder.Builder as Builder -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Interval as Interval -import qualified PostgreSQLBinary.Numeric as Numeric - - --- | --- A function for rendering a value into a byte string. -type E a = a -> ByteString - - --- * Numbers -------------------------- - -{-# INLINABLE int2 #-} -int2 :: E (Either Int16 Word16) -int2 = - either unpack unpack - where - unpack = Integral.unpackBySize 2 - -{-# INLINABLE int4 #-} -int4 :: E (Either Int32 Word32) -int4 = - either unpack unpack - where - unpack = Integral.unpackBySize 4 - -{-# INLINABLE int8 #-} -int8 :: E (Either Int64 Word64) -int8 = - either unpack unpack - where - unpack = Integral.unpackBySize 8 - -{-# INLINABLE float4 #-} -float4 :: E Float -float4 = - int4 . Right . (unsafeCoerce :: Float -> Word32) - -{-# INLINABLE float8 #-} -float8 :: E Double -float8 = - int8 . Right . (unsafeCoerce :: Double -> Word64) - -{-# INLINABLE numeric #-} -numeric :: E Scientific -numeric = - Builder.run . Builder.numeric - --- * Text -------------------------- - --- | --- A UTF-8-encoded char. --- --- Note that since it's UTF-8-encoded --- not a \"char\" but a \"text\" OID should be used with it. -{-# INLINABLE char #-} -char :: E Char -char = - text . Left . T.singleton - --- | --- Either a strict or a lazy text. -{-# INLINABLE text #-} -text :: E (Either Text TL.Text) -text = - either strict lazy - where - strict = TE.encodeUtf8 . T.filter (/= '\0') - lazy = BL.toStrict . TLE.encodeUtf8 . TL.filter (/= '\0') - --- | --- Either a strict or a lazy bytestring. -{-# INLINABLE bytea #-} -bytea :: E (Either ByteString BL.ByteString) -bytea = - either id BL.toStrict - --- * Date and Time -------------------------- - -{-# INLINABLE date #-} -date :: E Day -date = - Builder.run . Builder.date - --- | --- Encoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE time #-} -time :: Bool -> E TimeOfDay -time integer_datetimes (TimeOfDay h m s) = - let - p = unsafeCoerce s :: Integer - u = p `div` (10^6) - in if integer_datetimes - then - Integral.unpackBySize 8 $ - fromIntegral u + 10^6 * 60 * (m + 60 * h) - else - inline float8 $ - fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)) - --- | --- Encoding strategy depends on whether the server supports @integer_datetimes@. -{-# INLINABLE timetz #-} -timetz :: Bool -> E (TimeOfDay, TimeZone) -timetz integer_datetimes (timeX, tzX) = - inline time integer_datetimes timeX <> tz tzX - where - tz = - Integral.unpackBySize 4 . (*60) . negate . timeZoneMinutes - -{-# INLINABLE timestamp #-} -timestamp :: Bool -> E LocalTime -timestamp = - \case - True -> int8 . Left . Time.localTimeToMicros - False -> float8 . Time.localTimeToSecs - -{-# INLINABLE timestamptz #-} -timestamptz :: Bool -> E UTCTime -timestamptz = - \case - True -> int8 . Left . Time.utcToMicros - False -> float8 . Time.utcToSecs - -{-# INLINABLE interval #-} -interval :: Bool -> E DiffTime -interval integerDatetimes x = - Builder.run $ - (if integerDatetimes then BB.int64BE u else BB.doubleBE s) <> - BB.int32BE d <> - BB.int32BE m - where - Interval.Interval u d m = - fromMaybe (error "Too large DiffTime value for an interval") $ - Interval.fromDiffTime x - s = fromIntegral u / (10^6) - --- * Misc -------------------------- - -{-# INLINABLE bool #-} -bool :: E Bool -bool = - \case - False -> B.singleton 0 - True -> B.singleton 1 - -{-# INLINABLE uuid #-} -uuid :: E UUID -uuid = - Builder.run . Builder.uuid - -{-# INLINABLE array #-} -array :: E Array.Data -array = - Builder.run . Builder.array diff --git a/library/PostgreSQLBinary/Encoder/Builder.hs b/library/PostgreSQLBinary/Encoder/Builder.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Encoder/Builder.hs +++ /dev/null @@ -1,98 +0,0 @@ -module PostgreSQLBinary.Encoder.Builder where - -import PostgreSQLBinary.Prelude hiding (bool) -import Data.ByteString.Lazy.Builder -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Scientific as Scientific -import qualified Data.UUID as UUID -import qualified PostgreSQLBinary.Array as Array -import qualified PostgreSQLBinary.Time as Time -import qualified PostgreSQLBinary.Numeric as Numeric -import qualified PostgreSQLBinary.Interval as Interval - - -{-# INLINE run #-} -run :: Builder -> B.ByteString -run = - BL.toStrict . toLazyByteString - -{-# INLINE bool #-} -bool :: Bool -> Builder -bool = - \case True -> word8 1; False -> word8 0 - -{-# INLINE array #-} -array :: Array.Data -> Builder -array (dimensionsV, valuesV, nullsV, oidV) = - dimensionsLength <> nulls <> oid <> dimensions <> values - where - dimensionsLength = - word32BE $ fromIntegral $ length dimensionsV - nulls = - word32BE $ if nullsV then 1 else 0 - oid = - word32BE oidV - dimensions = - foldMap dimension dimensionsV - values = - foldMap value valuesV - dimension (w, l) = - word32BE w <> word32BE l - value = - \case - Nothing -> word32BE (-1) - Just b -> word32BE (fromIntegral (B.length b)) <> byteString b - -{-# INLINE date #-} -date :: Day -> Builder -date = - int32BE . fromIntegral . Time.dayToPostgresJulian - -{-# INLINE numeric #-} -numeric :: Scientific -> Builder -numeric x = - int16BE (fromIntegral componentsAmount) <> - int16BE (fromIntegral pointIndex) <> - word16BE signCode <> - int16BE (fromIntegral trimmedExponent) <> - foldMap int16BE components - where - componentsAmount = - length components - coefficient = - Scientific.coefficient x - exponent = - Scientific.base10Exponent x - components = - Numeric.extractComponents tunedCoefficient - pointIndex = - componentsAmount + (tunedExponent `div` 4) - 1 - (tunedCoefficient, tunedExponent) = - case mod exponent 4 of - 0 -> (coefficient, exponent) - x -> (coefficient * 10 ^ x, exponent - x) - trimmedExponent = - if tunedExponent >= 0 - then 0 - else negate tunedExponent - signCode = - if coefficient < 0 - then Numeric.negSignCode - else Numeric.posSignCode - -{-# INLINE uuid #-} -uuid :: UUID -> Builder -uuid = - UUID.toWords >>> \(a, b, c, d) -> - word32BE a <> - word32BE b <> - word32BE c <> - word32BE d - diff --git a/library/PostgreSQLBinary/Integral.hs b/library/PostgreSQLBinary/Integral.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Integral.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- Utils for dealing with numbers. -module PostgreSQLBinary.Integral where - -import PostgreSQLBinary.Prelude -import qualified Data.ByteString as B - - -{-# INLINE byteSize #-} -byteSize :: (Bits a) => a -> Int -byteSize = (`div` 8) . bitSize - -{-# INLINE pack #-} -pack :: (Bits a, Num a) => B.ByteString -> a -pack = B.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 - -{-# INLINE unpack #-} -unpack :: (Bits a, Integral a) => a -> B.ByteString -unpack x = unpackBySize (byteSize x) x - -{-# INLINE unpackBySize #-} -unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString -unpackBySize n x = B.pack $ map f $ reverse [0..n - 1] - where f s = fromIntegral $ shiftR x (8 * s) diff --git a/library/PostgreSQLBinary/Interval.hs b/library/PostgreSQLBinary/Interval.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Interval.hs +++ /dev/null @@ -1,43 +0,0 @@ -module PostgreSQLBinary.Interval where - -import PostgreSQLBinary.Prelude hiding (months) -import qualified PostgreSQLBinary.Time as Time - - -data Interval = - Interval { - micros :: Int64, - days :: Int32, - months :: Int32 - } - deriving (Show, Eq) - - --- | --- Oddly enough despite a claim of support of up to 178000000 years in --- --- in practice it starts behaving unpredictably after a smaller limit. -maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros -minDiffTime :: DiffTime = negate maxDiffTime - -fromDiffTime :: DiffTime -> Maybe Interval -fromDiffTime x = - if x > maxDiffTime || x < minDiffTime - then Nothing - else Just $ fromPicosUnsafe (unsafeCoerce x) - -fromPicosUnsafe :: Integer -> Interval -fromPicosUnsafe = - evalState $ do - modify $ flip div (10^6) - u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) - d <- state $ swap . flip divMod (31) - m <- get - return $ Interval (fromIntegral u) (fromIntegral d) (fromIntegral m) - -toDiffTime :: Interval -> DiffTime -toDiffTime x = - picosecondsToDiffTime $ - (10 ^ 6) * - (fromIntegral (micros x) + - 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) diff --git a/library/PostgreSQLBinary/Numeric.hs b/library/PostgreSQLBinary/Numeric.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Numeric.hs +++ /dev/null @@ -1,38 +0,0 @@ -module PostgreSQLBinary.Numeric where - -import PostgreSQLBinary.Prelude - - -posSignCode :: Word16 = 0x0000 -negSignCode :: Word16 = 0x4000 -nanSignCode :: Word16 = 0xC000 - -{-# INLINE extractComponents #-} -extractComponents :: Integral a => a -> [Int16] -extractComponents = - (reverse .) . (. abs) . unfoldr $ \case - 0 -> Nothing - x -> case divMod x 10000 of - (d, m) -> Just (fromIntegral m, d) - -{-# INLINE mergeComponents #-} -mergeComponents :: Integral a => [a] -> a -mergeComponents = - foldl' (\l r -> l * 10000 + r) 0 - -{-# INLINE mergeDigits #-} -mergeDigits :: Integral a => [a] -> a -mergeDigits = - foldl' (\l r -> l * 10 + r) 0 - --- | --- Unpack a component into digits. -{-# INLINE componentDigits #-} -componentDigits :: Int16 -> [Int16] -componentDigits = - evalState $ do - a <- state (`divMod` 1000) - b <- state (`divMod` 100) - c <- state (`divMod` 10) - d <- get - return $ [a, b, c, d] diff --git a/library/PostgreSQLBinary/Prelude.hs b/library/PostgreSQLBinary/Prelude.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Prelude.hs +++ /dev/null @@ -1,65 +0,0 @@ -module PostgreSQLBinary.Prelude -( - module Exports, - LazyByteString, - LazyText, - bug, - bottom, - partial, -) -where - - --- base-prelude -------------------------- -import BasePrelude as Exports - --- transformers -------------------------- -import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) -import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) -import Control.Monad.Trans.Class as Exports - --- text -------------------------- -import Data.Text as Exports (Text) - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - --- placeholders -------------------------- -import Development.Placeholders as Exports - --- custom -------------------------- -import qualified Debug.Trace.LocationTH -import qualified Data.Text.Lazy -import qualified Data.ByteString.Lazy - - -type LazyByteString = Data.ByteString.Lazy.ByteString -type LazyText = Data.Text.Lazy.Text - -bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] - where - msg = "A \"postgresql-binary\" package bug: " :: String - -bottom = [e| $bug "Bottom evaluated" |] - -partial :: Alternative f => (a -> Bool) -> a -> f a -partial p x = - if p x then pure x else empty diff --git a/library/PostgreSQLBinary/Time.hs b/library/PostgreSQLBinary/Time.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Time.hs +++ /dev/null @@ -1,134 +0,0 @@ -module PostgreSQLBinary.Time where - -import PostgreSQLBinary.Prelude hiding (second) -import Data.Time.Calendar.Julian - - -{-# INLINABLE dayToPostgresJulian #-} -dayToPostgresJulian :: Day -> Integer -dayToPostgresJulian = - (+ (2400001 - 2451545)) . toModifiedJulianDay - -{-# INLINABLE postgresJulianToDay #-} -postgresJulianToDay :: Int64 -> Day -postgresJulianToDay = - ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) - -{-# INLINABLE microsToTimeOfDay #-} -microsToTimeOfDay :: Int64 -> TimeOfDay -microsToTimeOfDay = - evalState $ do - h <- state $ flip divMod $ 10 ^ 6 * 60 * 60 - m <- state $ flip divMod $ 10 ^ 6 * 60 - u <- get - return $ - TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) - -{-# INLINABLE microsToUTC #-} -microsToUTC :: Int64 -> UTCTime -microsToUTC = - evalState $ do - d <- state $ flip divMod $ 10^6 * 60 * 60 * 24 - u <- get - return $ - UTCTime (postgresJulianToDay d) (microsToDiffTime u) - -{-# INLINABLE microsToPico #-} -microsToPico :: Int64 -> Pico -microsToPico = - unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer) - -{-# INLINABLE microsToDiffTime #-} -microsToDiffTime :: Int64 -> DiffTime -microsToDiffTime = - unsafeCoerce microsToPico - -{-# INLINABLE microsToLocalTime #-} -microsToLocalTime :: Int64 -> LocalTime -microsToLocalTime = - evalState $ do - d <- state $ flip divMod $ 10^6 * 60 * 60 * 24 - u <- get - return $ - LocalTime (postgresJulianToDay d) (microsToTimeOfDay u) - -{-# INLINABLE secsToTimeOfDay #-} -secsToTimeOfDay :: Double -> TimeOfDay -secsToTimeOfDay = - evalState $ do - h <- state $ flip divMod' $ 60 * 60 - m <- state $ flip divMod' $ 60 - s <- get - return $ - TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s) - -{-# INLINABLE secsToUTC #-} -secsToUTC :: Double -> UTCTime -secsToUTC = - evalState $ do - d <- state $ flip divMod' $ 60 * 60 * 24 - s <- get - return $ - UTCTime (postgresJulianToDay d) (secsToDiffTime s) - -{-# INLINABLE secsToLocalTime #-} -secsToLocalTime :: Double -> LocalTime -secsToLocalTime = - evalState $ do - d <- state $ flip divMod' $ 60 * 60 * 24 - s <- get - return $ - LocalTime (postgresJulianToDay d) (secsToTimeOfDay s) - -{-# INLINABLE secsToPico #-} -secsToPico :: Double -> Pico -secsToPico s = - unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer) - -{-# INLINABLE secsToDiffTime #-} -secsToDiffTime :: Double -> DiffTime -secsToDiffTime = - unsafeCoerce secsToPico - -{-# INLINABLE localTimeToMicros #-} -localTimeToMicros :: LocalTime -> Int64 -localTimeToMicros (LocalTime dayX timeX) = - let d = dayToPostgresJulian dayX - p = unsafeCoerce $ timeOfDayToTime timeX - in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6)) - -{-# INLINABLE localTimeToSecs #-} -localTimeToSecs :: LocalTime -> Double -localTimeToSecs (LocalTime dayX timeX) = - let d = dayToPostgresJulian dayX - p = unsafeCoerce $ timeOfDayToTime timeX - in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12)) - -{-# INLINABLE utcToMicros #-} -utcToMicros :: UTCTime -> Int64 -utcToMicros (UTCTime dayX diffTimeX) = - let d = dayToPostgresJulian dayX - p = unsafeCoerce diffTimeX - in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6)) - -{-# INLINABLE utcToSecs #-} -utcToSecs :: UTCTime -> Double -utcToSecs (UTCTime dayX diffTimeX) = - let d = dayToPostgresJulian dayX - p = unsafeCoerce diffTimeX - in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12)) - - --- * Constants in microseconds according to Julian dates standard -------------------------- --- According to --- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html --- Postgres uses Julian dates internally -------------------------- - -yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational) -dayMicros :: Int64 = 24 * hourMicros -hourMicros :: Int64 = 60 * minuteMicros -minuteMicros :: Int64 = 60 * secondMicros -secondMicros :: Int64 = 10 ^ 6 - diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,178 +1,164 @@ -name: - postgresql-binary -version: - 0.5.2.1 -synopsis: - Encoders and decoders for the PostgreSQL's binary format +cabal-version: 3.0 +name: postgresql-binary +version: 0.15.0.1 +synopsis: Encoders and decoders for the PostgreSQL's binary format description: An API for dealing with PostgreSQL's binary data format. . - It can be used to implement high level APIs for Postgres. - E.g., + It can be used to implement performant bindings to Postgres. + E.g., is based on this library. . - It supports all Postgres versions starting from 8.3 - and is tested against 8.3, 9.3 and 9.4 + It supports all Postgres versions starting from 8.3 + and is tested against 8.3, 9.3 and 9.5 with the @integer_datetimes@ setting off and on. -category: - Database, Codecs, Parsing -homepage: - https://github.com/nikita-volkov/postgresql-binary -bug-reports: - https://github.com/nikita-volkov/postgresql-binary/issues -author: - Nikita Volkov -maintainer: - Nikita Volkov -copyright: - (c) 2014, Nikita Volkov -license: - MIT -license-file: - LICENSE -build-type: - Simple -cabal-version: - >=1.10 +category: PostgreSQL, Database, Codecs, Parsing +homepage: https://github.com/nikita-volkov/postgresql-binary +bug-reports: https://github.com/nikita-volkov/postgresql-binary/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2014, Nikita Volkov +license: MIT +license-file: LICENSE +extra-source-files: CHANGELOG.md source-repository head - type: - git - location: - git://github.com/nikita-volkov/postgresql-binary.git + type: git + location: https://github.com/nikita-volkov/postgresql-binary +common base + default-language: Haskell2010 + default-extensions: + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UnboxedTuples library - hs-source-dirs: - library - ghc-options: - -funbox-strict-fields - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 - other-modules: - PostgreSQLBinary.Prelude - PostgreSQLBinary.Encoder.Builder - PostgreSQLBinary.Decoder.Zepto - PostgreSQLBinary.Integral - PostgreSQLBinary.Numeric - PostgreSQLBinary.Time - PostgreSQLBinary.Interval + import: base + hs-source-dirs: library + ghc-options: -funbox-strict-fields exposed-modules: - PostgreSQLBinary.Array - PostgreSQLBinary.Encoder - PostgreSQLBinary.Decoder - build-depends: - -- parsers: - attoparsec >= 0.10 && < 0.14, - -- data: - uuid == 1.3.*, - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, - -- errors: - loch-th == 0.2.*, - placeholders == 0.1.*, - -- general: - transformers >= 0.3 && < 0.5, - base-prelude >= 0.1.3 && < 0.2 + PostgreSQL.Binary.Decoding + PostgreSQL.Binary.Encoding + PostgreSQL.Binary.Range + other-modules: + PostgreSQL.Binary.BuilderPrim + PostgreSQL.Binary.Encoding.Builders + PostgreSQL.Binary.Inet + PostgreSQL.Binary.Integral + PostgreSQL.Binary.Interval + PostgreSQL.Binary.Numeric + PostgreSQL.Binary.Prelude + PostgreSQL.Binary.Time -test-suite tests - type: - exitcode-stdio-1.0 - hs-source-dirs: - executables - main-is: - Tests.hs + build-depends: + aeson >=2 && <3, + base >=4.12 && <5, + binary-parser >=0.5.7 && <0.6, + bytestring >=0.10.4 && <0.13, + bytestring-strict-builder >=0.4.5.4 && <0.5, + containers >=0.5 && <0.9, + iproute >=1.7 && <2, + mtl >=2.2 && <2.4, + scientific >=0.3 && <0.4, + text >=1.2 && <3, + time >=1.9 && <2, + transformers >=0.3 && <0.7, + unordered-containers >=0.2 && <0.3, + uuid >=1.3 && <1.4, + vector >=0.12 && <0.14, + +-- This test-suite must be executed in a single-thread. +test-suite tasty + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs other-modules: - PostgreSQLBinary.PTI - ghc-options: - -threaded - "-with-rtsopts=-N" - -funbox-strict-fields - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 + Main.Apx + Main.Composite + Main.DB + Main.Gens + Main.IO + Main.PTI + Main.Prelude + Main.Properties + Main.TextEncoder + Main.TypedComposite + build-depends: - -- testing: + QuickCheck >=2.10 && <3, + aeson >=2 && <3, + iproute >=1.4 && <2, postgresql-binary, - HTF == 0.12.*, - quickcheck-instances == 0.3.*, - QuickCheck >= 2.7 && < 2.9, - -- database: - postgresql-libpq == 0.9.*, - -- data: - uuid == 1.3.*, - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, - -- general: - base-prelude >= 0.1.3 && < 0.2 - + postgresql-libpq >=0.9 && <0.12, + quickcheck-instances >=0.3.22 && <0.4, + rerebase >=1.20.1.1 && <2, + tasty >=1.4 && <2, + tasty-hunit >=0.10 && <0.11, + tasty-quickcheck >=0.10 && <0.12, -benchmark decoding - type: - exitcode-stdio-1.0 - hs-source-dirs: - executables - main-is: - Decoding.hs +benchmark encoding + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: encoding + main-is: Main.hs ghc-options: -O2 -threaded - "-with-rtsopts=-N" + -with-rtsopts=-N -funbox-strict-fields - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 + build-depends: + criterion >=1.5.9 && <2, postgresql-binary, - -- benchmarking: - criterion >= 1.0 && < 1.2, - -- data: - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, - -- general: - deepseq >= 1.3 && < 1.5, - mtl-prelude < 3, - base-prelude >= 0.1.3 && < 0.2 - + rerebase >=1.20.1.1 && <2, -benchmark encoding - type: - exitcode-stdio-1.0 - hs-source-dirs: - executables - main-is: - Encoding.hs +benchmark decoding + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: decoding + main-is: Main.hs ghc-options: -O2 -threaded - "-with-rtsopts=-N" + -with-rtsopts=-N -funbox-strict-fields - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 + build-depends: + criterion >=1.5.9 && <2, postgresql-binary, - -- benchmarking: - criterion >= 1.0 && < 1.2, - -- data: - time >= 1.4 && < 1.6, - scientific >= 0.2 && < 0.4, - text >= 1 && < 1.3, - bytestring >= 0.10 && < 0.11, - -- general: - deepseq >= 1.3 && < 1.5, - mtl-prelude < 3, - base-prelude >= 0.1.3 && < 0.2 + rerebase >=1.20.1.1 && <2, diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,432 @@ +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 Main.TypedComposite as TypedComposite +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), + testProperty "Typed composite roundtrip" TypedComposite.roundtrip, + 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 diff --git a/tasty/Main/Apx.hs b/tasty/Main/Apx.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Apx.hs @@ -0,0 +1,72 @@ +module Main.Apx where + +import Main.Prelude + +-- | +-- A wrapper which provides a type-specific 'Eq' instance +-- with approximate comparison. +newtype Apx a = Apx {unApx :: a} + deriving (Show) + +instance (Eq (Apx a), Eq (Apx b)) => Eq (Apx (a, b)) where + (==) (Apx (a1, a2)) (Apx (b1, b2)) = + Apx a1 + == Apx b1 + && Apx a2 + == Apx b2 + +instance Eq (Apx LocalTime) where + (==) (Apx a) (Apx b) = + Apx (localTimeToSeconds a) + == Apx (localTimeToSeconds b) + +instance Eq (Apx UTCTime) where + (==) (Apx a) (Apx b) = + Apx (utcTimeToSeconds a) + == Apx (utcTimeToSeconds b) + +instance Eq (Apx TimeOfDay) where + (==) (Apx a) (Apx b) = + Apx (timeOfDayToSeconds a) + == Apx (timeOfDayToSeconds b) + +instance Eq (Apx TimeZone) where + (==) (Apx a) (Apx b) = + a == b + +instance Eq (Apx Double) where + (==) (Apx a) (Apx b) = + toRational a == toRational b + +instance Eq (Apx Rational) where + (==) (Apx a) (Apx b) = + a + + error + >= b + && a + - error + <= b + where + error = + 10 ^^ negate 3 + +utcTimeToSeconds :: UTCTime -> Rational +utcTimeToSeconds (UTCTime days diffTime) = + dayToSeconds days + diffTimeToSeconds diffTime + +diffTimeToSeconds :: DiffTime -> Rational +diffTimeToSeconds diffTime = + unsafeCoerce diffTime % (10 ^ 12) + +dayToSeconds :: Day -> Rational +dayToSeconds (ModifiedJulianDay day) = + (unsafeCoerce day * 24 * 60 * 60) % 1 + +localTimeToSeconds :: LocalTime -> Rational +localTimeToSeconds (LocalTime day tod) = + dayToSeconds day + + timeOfDayToSeconds tod + +timeOfDayToSeconds :: TimeOfDay -> Rational +timeOfDayToSeconds (TimeOfDay h m s) = + ((toInteger h * 60 + toInteger m) * 60) % 1 + unsafeCoerce s % (10 ^ 12) diff --git a/tasty/Main/Composite.hs b/tasty/Main/Composite.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Composite.hs @@ -0,0 +1,67 @@ +module Main.Composite where + +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified Main.Gens as Gens +import Main.Prelude hiding (choose, isLeft, isRight) +import qualified PostgreSQL.Binary.Decoding as Decoding +import qualified PostgreSQL.Binary.Encoding as Encoding +import Test.QuickCheck hiding (vector) + +newtype Composite = Composite [CompositeFieldValue] + deriving (Show, Eq, Ord) + +instance Arbitrary Composite where + arbitrary = Composite <$> listOf arbitrary + +data CompositeFieldValue + = Int4CompositeFieldValue !(Maybe Int32) + | TextCompositeFieldValue !(Maybe Text) + | JsonbCompositeFieldValue !(Maybe Aeson.Value) + deriving (Show, Eq, Ord) + +instance Arbitrary CompositeFieldValue where + arbitrary = + oneof + [ Int4CompositeFieldValue <$> arbitrary, + TextCompositeFieldValue <$> Gens.maybeOf Gens.text, + JsonbCompositeFieldValue <$> Gens.maybeOf Gens.aeson + ] + +encodeToByteString :: Composite -> ByteString +encodeToByteString = Encoding.encodingBytes . encodeComposite + +encodeComposite :: Composite -> Encoding.Encoding +encodeComposite (Composite fields) = + Encoding.composite $ foldMap compositeField fields + where + compositeField = \case + Int4CompositeFieldValue z -> fieldEncoder 23 Encoding.int4_int32 z + TextCompositeFieldValue z -> fieldEncoder 25 Encoding.text_strict z + JsonbCompositeFieldValue z -> fieldEncoder 3802 Encoding.jsonb_ast z + where + fieldEncoder oid encoder = \case + Nothing -> Encoding.nullField oid + Just value -> Encoding.field oid $ encoder value + +decodingProperty :: Composite -> ByteString -> Property +decodingProperty composite input = + case Decoding.valueParser (decoder composite) input of + Right p -> p + Left err -> counterexample (Text.unpack err) False + +decoder :: Composite -> Decoding.Value Property +decoder (Composite fields) = + conjoin <$> Decoding.composite (traverse field fields) + where + field = \case + Int4CompositeFieldValue z -> expect z Decoding.int + TextCompositeFieldValue z -> expect z Decoding.text_strict + JsonbCompositeFieldValue z -> expect z Decoding.jsonb_ast + where + expect expectedValue decoder = + case expectedValue of + Just expectedValue -> + Decoding.valueComposite decoder <&> (===) expectedValue + Nothing -> + Decoding.nullableValueComposite decoder <&> (===) Nothing diff --git a/tasty/Main/DB.hs b/tasty/Main/DB.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/DB.hs @@ -0,0 +1,105 @@ +module Main.DB + ( session, + oneRow, + unit, + integerDatetimes, + serverVersion, + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.ByteString as ByteString +import qualified Database.PostgreSQL.LibPQ as LibPQ +import Main.Prelude hiding (unit) + +type Session = + ExceptT ByteString (ReaderT LibPQ.Connection IO) + +session :: Session a -> IO (Either ByteString a) +session m = + do + c <- connect + initConnection c + r <- runReaderT (runExceptT m) c + LibPQ.finish c + return r + +oneRow :: ByteString -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] -> LibPQ.Format -> Session ByteString +oneRow statement params outFormat = + do + Just result <- result statement params outFormat + Just result <- liftIO $ LibPQ.getvalue result 0 0 + return result + +unit :: ByteString -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] -> Session () +unit statement params = + void $ result statement params LibPQ.Binary + +result :: ByteString -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] -> LibPQ.Format -> Session (Maybe LibPQ.Result) +result statement params outFormat = + do + result <- ExceptT $ ReaderT $ \connection -> fmap Right $ LibPQ.execParams connection statement params outFormat + checkResult result + return result + +checkResult :: Maybe LibPQ.Result -> Session () +checkResult result = + ExceptT + $ ReaderT + $ \connection -> do + case result of + Just result -> do + LibPQ.resultErrorField result LibPQ.DiagMessagePrimary >>= maybe (return (Right ())) (return . Left) + Nothing -> do + m <- LibPQ.errorMessage connection + return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m + +integerDatetimes :: Session Bool +integerDatetimes = + lift (ReaderT getIntegerDatetimes) + +serverVersion :: Session Int +serverVersion = + lift (ReaderT LibPQ.serverVersion) + +connect :: IO LibPQ.Connection +connect = + LibPQ.connectdb bs + where + bs = + ByteString.intercalate " " components + where + components = + [ "host=" <> host, + "port=" <> (fromString . show) port, + "user=" <> user, + "password=" <> password, + "dbname=" <> db + ] + where + host = "localhost" + port = 5432 + user = "postgres" + password = "postgres" + db = "postgres" + +initConnection :: LibPQ.Connection -> IO () +initConnection c = + void + $ LibPQ.exec c + $ mconcat + $ map (<> ";") + $ [ "SET client_min_messages TO WARNING", + "SET client_encoding = 'UTF8'", + "SET intervalstyle = 'postgres'" + ] + +getIntegerDatetimes :: LibPQ.Connection -> IO Bool +getIntegerDatetimes c = + fmap parseResult $ LibPQ.parameterStatus c "integer_datetimes" + where + parseResult = + \case + Just "on" -> True + _ -> False diff --git a/tasty/Main/Gens.hs b/tasty/Main/Gens.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Gens.hs @@ -0,0 +1,169 @@ +module Main.Gens where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +import qualified Data.Aeson.KeyMap as AesonKeyMap +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IP as IP +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import qualified Data.UUID as UUID +import qualified Data.Vector as Vector +import Main.Prelude hiding (choose, isLeft, isRight) +import Test.QuickCheck hiding (vector) + +maybeOf :: Gen a -> Gen (Maybe a) +maybeOf gen = + oneof [Just <$> gen, pure Nothing] + +-- * Generators + +auto :: (Arbitrary a) => Gen a +auto = + arbitrary + +vector :: Gen a -> Gen (Vector a) +vector element = + join $ Vector.replicateM <$> arbitrary <*> pure element + +hashMap :: (Hashable a) => Gen a -> Gen b -> Gen (HashMap a b) +hashMap key value = + fmap HashMap.fromList $ join $ replicateM <$> arbitrary <*> pure row + where + row = + (,) <$> key <*> value + +aeson :: Gen Aeson.Value +aeson = + byDepth 0 + where + byDepth depth = + frequency (primitives <> composites) + where + primitives = + map (freq,) [null, bool, number, string] + where + freq = + maxFreq + composites = + map (freq,) [array, object] + where + freq = + maxFreq - depth + maxFreq = + 4 + null = + pure Aeson.Null + bool = + fmap Aeson.Bool arbitrary + number = + fmap Aeson.Number arbitrary + string = + fmap Aeson.String text + array = + fmap Aeson.Array (vector (byDepth (succ depth))) + object = + Aeson.Object . AesonKeyMap.fromList <$> listOf pair + where + pair = + (,) <$> key <*> value + where + key = + AesonKey.fromText <$> text + value = + byDepth (succ depth) + +postgresInt :: (Bounded a, Integral a, Arbitrary a) => Gen a +postgresInt = + arbitrary >>= \x -> if x > halfMaxBound then postgresInt else pure x + where + halfMaxBound = + div maxBound 2 + +text :: Gen Text +text = + arbitrary >>= \x -> if Text.find (== '\NUL') x == Nothing then return x else text + +char :: Gen Char +char = + arbitrary >>= \x -> if x /= '\NUL' then return x else char + +scientific :: Gen Scientific +scientific = + Scientific.scientific <$> arbitrary <*> arbitrary + +microsTimeOfDay :: Gen TimeOfDay +microsTimeOfDay = + fmap timeToTimeOfDay + $ fmap picosecondsToDiffTime + $ fmap (* (10 ^ 6)) + $ choose (0, (10 ^ 6) * 24 * 60 * 60) + +microsLocalTime :: Gen LocalTime +microsLocalTime = + LocalTime <$> arbitrary <*> microsTimeOfDay + +microsUTCTime :: Gen UTCTime +microsUTCTime = + localTimeToUTC <$> timeZone <*> microsLocalTime + +intervalDiffTime :: Gen DiffTime +intervalDiffTime = do + unsafeCoerce ((* (10 ^ 6)) <$> choose (uMin, uMax) :: Gen Integer) + where + uMin = unsafeCoerce minInterval `div` 10 ^ 6 + uMax = unsafeCoerce maxInterval `div` 10 ^ 6 + +timeZone :: Gen TimeZone +timeZone = + minutesToTimeZone <$> choose (-60 * 12 + 1, 60 * 12) + +timetz :: Gen (TimeOfDay, TimeZone) +timetz = + (,) <$> microsTimeOfDay <*> timeZone + +uuid :: Gen UUID.UUID +uuid = + UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +inet :: Gen IP.IPRange +inet = do + ipv6 <- choose (True, False) + if ipv6 + then + IP.IPv6Range + <$> ( IP.makeAddrRange + <$> ( IP.toIPv6w + <$> ( (,,,) + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + ) + ) + <*> choose (0, 128) + ) + else IP.IPv4Range <$> (IP.makeAddrRange <$> (IP.toIPv4w <$> arbitrary) <*> choose (0, 32)) + +macaddr :: Gen (Word8, Word8, Word8, Word8, Word8, Word8) +macaddr = + (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +array3 :: Gen a -> Gen [[[a]]] +array3 gen = + do + width1 <- choose (1, 10) + width2 <- choose (1, 10) + width3 <- choose (1, 10) + replicateM width1 (replicateM width2 (replicateM width3 gen)) + +-- * Constants + +maxInterval :: DiffTime +maxInterval = + unsafeCoerce + $ (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) + +minInterval :: DiffTime +minInterval = + negate maxInterval diff --git a/tasty/Main/IO.hs b/tasty/Main/IO.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/IO.hs @@ -0,0 +1,52 @@ +-- | +-- Specific IO Actions +module Main.IO where + +import qualified Data.ByteString.Builder as ByteStringBuilder +import qualified Data.ByteString.Lazy as ByteStringLazy +import qualified Data.Text.Encoding as Text +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Main.DB as DB +import Main.Prelude hiding (isLeft, isRight) +import qualified Main.TextEncoder as TextEncoder +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Encoding as B + +textRoundtrip :: LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> A.Value a) -> a -> IO (Either Text a) +textRoundtrip oid encoder decoder value = + fmap (either (Left . Text.decodeUtf8) id) + $ DB.session + $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary + return $ A.valueParser (decoder integerDatetimes) bytes + where + params integerDatetimes = + [Just (oid, bytes, LibPQ.Text)] + where + bytes = + (ByteStringLazy.toStrict . ByteStringBuilder.toLazyByteString . encoder) value + +roundtrip :: LibPQ.Oid -> (Bool -> a -> B.Encoding) -> (Bool -> A.Value b) -> a -> IO (Either Text b) +roundtrip oid encoder decoder value = + fmap (either (Left . Text.decodeUtf8) id) + $ DB.session + $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary + return $ A.valueParser (decoder integerDatetimes) bytes + where + params integerDatetimes = + [Just (oid, bytes, LibPQ.Binary)] + where + bytes = + (B.encodingBytes . encoder integerDatetimes) value + +parameterlessStatement :: ByteString -> (Bool -> A.Value a) -> a -> IO (Either Text a) +parameterlessStatement statement decoder value = + fmap (either (Left . Text.decodeUtf8) id) + $ DB.session + $ do + integerDatetimes <- DB.integerDatetimes + bytes <- DB.oneRow statement [] LibPQ.Binary + return $ A.valueParser (decoder integerDatetimes) bytes diff --git a/tasty/Main/PTI.hs b/tasty/Main/PTI.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/PTI.hs @@ -0,0 +1,245 @@ +module Main.PTI where + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import Main.Prelude hiding (bool) + +-- | A Postgresql type info +data PTI = PTI {ptiOID :: !OID, ptiArrayOID :: !(Maybe OID)} + +-- | A Word32 and a LibPQ representation of an OID +data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid} + +mkOID :: Word32 -> OID +mkOID x = + OID x ((LibPQ.Oid . fromIntegral) x) + +mkPTI :: Word32 -> Maybe Word32 -> PTI +mkPTI oid arrayOID = + PTI (mkOID oid) (fmap mkOID arrayOID) + +-- * Constants + +abstime :: PTI +abstime = mkPTI 702 (Just 1023) + +aclitem :: PTI +aclitem = mkPTI 1033 (Just 1034) + +bit :: PTI +bit = mkPTI 1560 (Just 1561) + +bool :: PTI +bool = mkPTI 16 (Just 1000) + +box :: PTI +box = mkPTI 603 (Just 1020) + +bpchar :: PTI +bpchar = mkPTI 1042 (Just 1014) + +bytea :: PTI +bytea = mkPTI 17 (Just 1001) + +char :: PTI +char = mkPTI 18 (Just 1002) + +cid :: PTI +cid = mkPTI 29 (Just 1012) + +cidr :: PTI +cidr = mkPTI 650 (Just 651) + +circle :: PTI +circle = mkPTI 718 (Just 719) + +cstring :: PTI +cstring = mkPTI 2275 (Just 1263) + +date :: PTI +date = mkPTI 1082 (Just 1182) + +daterange :: PTI +daterange = mkPTI 3912 (Just 3913) + +datemultirange :: PTI +datemultirange = mkPTI 4535 (Just 6155) + +float4 :: PTI +float4 = mkPTI 700 (Just 1021) + +float8 :: PTI +float8 = mkPTI 701 (Just 1022) + +gtsvector :: PTI +gtsvector = mkPTI 3642 (Just 3644) + +inet :: PTI +inet = mkPTI 869 (Just 1041) + +int2 :: PTI +int2 = mkPTI 21 (Just 1005) + +int2vector :: PTI +int2vector = mkPTI 22 (Just 1006) + +int4 :: PTI +int4 = mkPTI 23 (Just 1007) + +int4range :: PTI +int4range = mkPTI 3904 (Just 3905) + +int4multirange :: PTI +int4multirange = mkPTI 4451 (Just 6150) + +int8 :: PTI +int8 = mkPTI 20 (Just 1016) + +int8range :: PTI +int8range = mkPTI 3926 (Just 3927) + +int8multirange :: PTI +int8multirange = mkPTI 4536 (Just 6157) + +interval :: PTI +interval = mkPTI 1186 (Just 1187) + +json :: PTI +json = mkPTI 114 (Just 199) + +jsonb :: PTI +jsonb = mkPTI 3802 (Just 3807) + +line :: PTI +line = mkPTI 628 (Just 629) + +lseg :: PTI +lseg = mkPTI 601 (Just 1018) + +macaddr :: PTI +macaddr = mkPTI 829 (Just 1040) + +money :: PTI +money = mkPTI 790 (Just 791) + +name :: PTI +name = mkPTI 19 (Just 1003) + +numeric :: PTI +numeric = mkPTI 1700 (Just 1231) + +numrange :: PTI +numrange = mkPTI 3906 (Just 3907) + +nummultirange :: PTI +nummultirange = mkPTI 4532 (Just 6151) + +oid :: PTI +oid = mkPTI 26 (Just 1028) + +oidvector :: PTI +oidvector = mkPTI 30 (Just 1013) + +path :: PTI +path = mkPTI 602 (Just 1019) + +point :: PTI +point = mkPTI 600 (Just 1017) + +polygon :: PTI +polygon = mkPTI 604 (Just 1027) + +record :: PTI +record = mkPTI 2249 (Just 2287) + +refcursor :: PTI +refcursor = mkPTI 1790 (Just 2201) + +regclass :: PTI +regclass = mkPTI 2205 (Just 2210) + +regconfig :: PTI +regconfig = mkPTI 3734 (Just 3735) + +regdictionary :: PTI +regdictionary = mkPTI 3769 (Just 3770) + +regoper :: PTI +regoper = mkPTI 2203 (Just 2208) + +regoperator :: PTI +regoperator = mkPTI 2204 (Just 2209) + +regproc :: PTI +regproc = mkPTI 24 (Just 1008) + +regprocedure :: PTI +regprocedure = mkPTI 2202 (Just 2207) + +regtype :: PTI +regtype = mkPTI 2206 (Just 2211) + +reltime :: PTI +reltime = mkPTI 703 (Just 1024) + +text :: PTI +text = mkPTI 25 (Just 1009) + +tid :: PTI +tid = mkPTI 27 (Just 1010) + +time :: PTI +time = mkPTI 1083 (Just 1183) + +timestamp :: PTI +timestamp = mkPTI 1114 (Just 1115) + +timestamptz :: PTI +timestamptz = mkPTI 1184 (Just 1185) + +timetz :: PTI +timetz = mkPTI 1266 (Just 1270) + +tinterval :: PTI +tinterval = mkPTI 704 (Just 1025) + +tsquery :: PTI +tsquery = mkPTI 3615 (Just 3645) + +tsrange :: PTI +tsrange = mkPTI 3908 (Just 3909) + +tsmultirange :: PTI +tsmultirange = mkPTI 4533 (Just 6152) + +tstzrange :: PTI +tstzrange = mkPTI 3910 (Just 3911) + +tstzmultirange :: PTI +tstzmultirange = mkPTI 4534 (Just 6153) + +tsvector :: PTI +tsvector = mkPTI 3614 (Just 3643) + +txid_snapshot :: PTI +txid_snapshot = mkPTI 2970 (Just 2949) + +unknown :: PTI +unknown = mkPTI 705 Nothing + +uuid :: PTI +uuid = mkPTI 2950 (Just 2951) + +varbit :: PTI +varbit = mkPTI 1562 (Just 1563) + +varchar :: PTI +varchar = mkPTI 1043 (Just 1015) + +void :: PTI +void = mkPTI 2278 Nothing + +xid :: PTI +xid = mkPTI 28 (Just 1011) + +xml :: PTI +xml = mkPTI 142 (Just 143) diff --git a/tasty/Main/Prelude.hs b/tasty/Main/Prelude.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Prelude.hs @@ -0,0 +1,27 @@ +module Main.Prelude + ( module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + ) +where + +import qualified Data.ByteString.Builder +import qualified Data.ByteString.Lazy +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import Test.QuickCheck.Instances () +import Prelude as Exports hiding (Data, assert, check, fail) + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder diff --git a/tasty/Main/Properties.hs b/tasty/Main/Properties.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Properties.hs @@ -0,0 +1,27 @@ +module Main.Properties where + +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Main.IO as IO +import Main.Prelude hiding (isLeft, isRight) +import qualified Main.TextEncoder as C +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Encoding as B +import Test.QuickCheck + +roundtrip :: + (Show a, Eq a) => + LibPQ.Oid -> + (Bool -> (a -> B.Encoding)) -> + (Bool -> A.Value a) -> + a -> + Property +roundtrip oid encoder decoder value = + Right value === unsafePerformIO (IO.roundtrip oid encoder decoder value) + +stdRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> (a -> B.Encoding) -> A.Value a -> a -> Property +stdRoundtrip oid encoder decoder value = + roundtrip oid (const encoder) (const decoder) value + +textRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> C.Encoder a -> (Bool -> A.Value a) -> a -> Property +textRoundtrip oid encoder decoder value = + Right value === unsafePerformIO (IO.textRoundtrip oid encoder decoder value) diff --git a/tasty/Main/TextEncoder.hs b/tasty/Main/TextEncoder.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/TextEncoder.hs @@ -0,0 +1,60 @@ +-- | +-- Encoders to text format. +module Main.TextEncoder where + +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Scientific +import qualified Data.UUID +import Main.Prelude hiding (bool, maybe) +import qualified Main.Prelude as Prelude + +type Encoder a = + a -> Builder + +bool :: Encoder Bool +bool = + byteString . Prelude.bool "false" "true" + +int2_int16 :: Encoder Int16 +int2_int16 = + int16Dec + +int4_int32 :: Encoder Int32 +int4_int32 = + int32Dec + +int8_int64 :: Encoder Int64 +int8_int64 = + int64Dec + +int2_word16 :: Encoder Word16 +int2_word16 = + word16Dec + +int4_word32 :: Encoder Word32 +int4_word32 = + word32Dec + +int8_word64 :: Encoder Word64 +int8_word64 = + word64Dec + +float4 :: Encoder Float +float4 = + floatDec + +float8 :: Encoder Double +float8 = + doubleDec + +numeric :: Encoder Scientific +numeric = + Data.ByteString.Builder.Scientific.scientificBuilder + +uuid :: Encoder UUID +uuid = + byteString . Data.UUID.toASCIIBytes + +bytea_strict :: Encoder ByteString +bytea_strict = + byteString diff --git a/tasty/Main/TypedComposite.hs b/tasty/Main/TypedComposite.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/TypedComposite.hs @@ -0,0 +1,47 @@ +module Main.TypedComposite where + +import qualified Main.Gens as Gens +import Main.Prelude +import qualified PostgreSQL.Binary.Decoding as Decoding +import qualified PostgreSQL.Binary.Encoding as Encoding +import Test.QuickCheck + +data Person = Person + { personName :: Text, + personAge :: Int32, + personMaybePhone :: Maybe Text + } + deriving (Show, Eq) + +instance Arbitrary Person where + arbitrary = + Person + <$> Gens.text + <*> arbitrary + <*> Gens.maybeOf Gens.text + +nameOid, ageOid, phoneOid :: Word32 +(nameOid, ageOid, phoneOid) = (25, 23, 25) -- text, int4, text + +encodePerson :: Person -> Encoding.Encoding +encodePerson (Person name age maybePhone) = + Encoding.composite + $ Encoding.field nameOid (Encoding.text_strict name) + <> Encoding.field ageOid (Encoding.int4_int32 age) + <> case maybePhone of + Nothing -> Encoding.nullField phoneOid + Just phone -> Encoding.field phoneOid (Encoding.text_strict phone) + +decodePerson :: Decoding.Value Person +decodePerson = + Decoding.composite + $ Person + <$> Decoding.typedValueComposite nameOid (Decoding.text_strict) + <*> Decoding.typedValueComposite ageOid (Decoding.int) + <*> Decoding.typedNullableValueComposite phoneOid (Decoding.text_strict) + +roundtrip :: Person -> Property +roundtrip person = + let encoded = Encoding.encodingBytes (encodePerson person) + decoded = Decoding.valueParser decodePerson encoded + in Right person === decoded