postgresql-binary 0.5.2.1 → 0.15.0.1
raw patch · 41 files changed
Files
- CHANGELOG.md +14/−0
- Setup.hs +0/−2
- decoding/Main.hs +40/−0
- encoding/Main.hs +34/−0
- executables/Decoding.hs +0/−44
- executables/Encoding.hs +0/−43
- executables/PostgreSQLBinary/PTI.hs +0/−77
- executables/Tests.hs +0/−603
- library/PostgreSQL/Binary/BuilderPrim.hs +9/−0
- library/PostgreSQL/Binary/Decoding.hs +778/−0
- library/PostgreSQL/Binary/Encoding.hs +463/−0
- library/PostgreSQL/Binary/Encoding/Builders.hs +487/−0
- library/PostgreSQL/Binary/Inet.hs +13/−0
- library/PostgreSQL/Binary/Integral.hs +19/−0
- library/PostgreSQL/Binary/Interval.hs +49/−0
- library/PostgreSQL/Binary/Numeric.hs +76/−0
- library/PostgreSQL/Binary/Prelude.hs +112/−0
- library/PostgreSQL/Binary/Range.hs +11/−0
- library/PostgreSQL/Binary/Time.hs +138/−0
- library/PostgreSQLBinary/Array.hs +0/−73
- library/PostgreSQLBinary/Decoder.hs +0/−175
- library/PostgreSQLBinary/Decoder/Zepto.hs +0/−71
- library/PostgreSQLBinary/Encoder.hs +0/−174
- library/PostgreSQLBinary/Encoder/Builder.hs +0/−98
- library/PostgreSQLBinary/Integral.hs +0/−24
- library/PostgreSQLBinary/Interval.hs +0/−43
- library/PostgreSQLBinary/Numeric.hs +0/−38
- library/PostgreSQLBinary/Prelude.hs +0/−65
- library/PostgreSQLBinary/Time.hs +0/−134
- postgresql-binary.cabal +132/−146
- tasty/Main.hs +432/−0
- tasty/Main/Apx.hs +72/−0
- tasty/Main/Composite.hs +67/−0
- tasty/Main/DB.hs +105/−0
- tasty/Main/Gens.hs +169/−0
- tasty/Main/IO.hs +52/−0
- tasty/Main/PTI.hs +245/−0
- tasty/Main/Prelude.hs +27/−0
- tasty/Main/Properties.hs +27/−0
- tasty/Main/TextEncoder.hs +60/−0
- tasty/Main/TypedComposite.hs +47/−0
+ CHANGELOG.md view
@@ -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.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ decoding/Main.hs view
@@ -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
+ encoding/Main.hs view
@@ -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
− executables/Decoding.hs
@@ -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
− executables/Encoding.hs
@@ -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
− executables/PostgreSQLBinary/PTI.hs
@@ -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)-
− executables/Tests.hs
@@ -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)-
+ library/PostgreSQL/Binary/BuilderPrim.hs view
@@ -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)
+ library/PostgreSQL/Binary/Decoding.hs view
@@ -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
+ library/PostgreSQL/Binary/Encoding.hs view
@@ -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
+ library/PostgreSQL/Binary/Encoding/Builders.hs view
@@ -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
+ library/PostgreSQL/Binary/Inet.hs view
@@ -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
+ library/PostgreSQL/Binary/Integral.hs view
@@ -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)
+ library/PostgreSQL/Binary/Interval.hs view
@@ -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+-- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs>+-- 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))+ )
+ library/PostgreSQL/Binary/Numeric.hs view
@@ -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
+ library/PostgreSQL/Binary/Prelude.hs view
@@ -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
+ library/PostgreSQL/Binary/Range.hs view
@@ -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]
+ library/PostgreSQL/Binary/Time.hs view
@@ -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
− library/PostgreSQLBinary/Array.hs
@@ -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)
− library/PostgreSQLBinary/Decoder.hs
@@ -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
− library/PostgreSQLBinary/Decoder/Zepto.hs
@@ -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
− library/PostgreSQLBinary/Encoder.hs
@@ -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
− library/PostgreSQLBinary/Encoder/Builder.hs
@@ -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-
− library/PostgreSQLBinary/Integral.hs
@@ -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)
− library/PostgreSQLBinary/Interval.hs
@@ -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--- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs>--- 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)))
− library/PostgreSQLBinary/Numeric.hs
@@ -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]
− library/PostgreSQLBinary/Prelude.hs
@@ -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
− library/PostgreSQLBinary/Time.hs
@@ -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 -
postgresql-binary.cabal view
@@ -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., <http://hackage.haskell.org/package/hasql-postgres "hasql-postgres">+ It can be used to implement performant bindings to Postgres.+ E.g., <http://hackage.haskell.org/package/hasql hasql> 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 <nikita.y.volkov@mail.ru>-maintainer:- Nikita Volkov <nikita.y.volkov@mail.ru>-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 <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+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,
+ tasty/Main.hs view
@@ -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
+ tasty/Main/Apx.hs view
@@ -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)
+ tasty/Main/Composite.hs view
@@ -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
+ tasty/Main/DB.hs view
@@ -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
+ tasty/Main/Gens.hs view
@@ -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
+ tasty/Main/IO.hs view
@@ -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
+ tasty/Main/PTI.hs view
@@ -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)
+ tasty/Main/Prelude.hs view
@@ -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
+ tasty/Main/Properties.hs view
@@ -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)
+ tasty/Main/TextEncoder.hs view
@@ -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
+ tasty/Main/TypedComposite.hs view
@@ -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