postgresql-binary 0.12.5 → 0.15.0.1
raw patch · 27 files changed
Files
- CHANGELOG.md +14/−0
- decoding/Main.hs +29/−49
- encoding/Main.hs +23/−43
- library/PostgreSQL/Binary/BuilderPrim.hs +1/−2
- library/PostgreSQL/Binary/Data.hs +0/−25
- library/PostgreSQL/Binary/Decoding.hs +384/−156
- library/PostgreSQL/Binary/Encoding.hs +212/−108
- library/PostgreSQL/Binary/Encoding/Builders.hs +139/−118
- library/PostgreSQL/Binary/Inet.hs +0/−1
- library/PostgreSQL/Binary/Integral.hs +4/−5
- library/PostgreSQL/Binary/Interval.hs +19/−13
- library/PostgreSQL/Binary/Numeric.hs +11/−12
- library/PostgreSQL/Binary/Prelude.hs +39/−78
- library/PostgreSQL/Binary/Range.hs +11/−0
- library/PostgreSQL/Binary/Time.hs +50/−46
- postgresql-binary.cabal +101/−92
- tasty/Main.hs +372/−220
- tasty/Main/Apx.hs +19/−16
- tasty/Main/Composite.hs +67/−0
- tasty/Main/DB.hs +31/−33
- tasty/Main/Gens.hs +48/−32
- tasty/Main/IO.hs +26/−30
- tasty/Main/PTI.hs +226/−75
- tasty/Main/Prelude.hs +9/−17
- tasty/Main/Properties.hs +12/−14
- tasty/Main/TextEncoder.hs +6/−8
- 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.
decoding/Main.hs view
@@ -1,60 +1,40 @@ module Main where -import Prelude import Criterion import Criterion.Main-import qualified PostgreSQL.Binary.Encoding as E 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]))+ [ 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 = + b name decoder value = bench name $ nf (D.valueParser decoder) value
encoding/Main.hs view
@@ -1,54 +1,34 @@ module Main where -import Prelude 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]+ [ 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 = + value name encoder value = bench name $ nf (E.encodingBytes . encoder) value
library/PostgreSQL/Binary/BuilderPrim.hs view
@@ -1,8 +1,7 @@ module PostgreSQL.Binary.BuilderPrim where -import PostgreSQL.Binary.Prelude import qualified Data.ByteString.Builder.Prim as A-+import PostgreSQL.Binary.Prelude {-# INLINE nullByteIgnoringBoundedPrim #-} nullByteIgnoringBoundedPrim :: A.BoundedPrim Word8
− library/PostgreSQL/Binary/Data.hs
@@ -1,25 +0,0 @@-{-|-Reexports of all the data-types that this API supports.-Useful for the reduction of dependencies in the \"postgresql-binary\" dependent libraries.--}-module PostgreSQL.Binary.Data-(- module Data.HashMap.Strict,- module Data.Map.Strict,- module Data.Scientific,- module Data.Time,- module Data.UUID,- module Data.Vector,- module Data.Aeson,- module Network.IP.Addr,-)-where--import Data.HashMap.Strict (HashMap)-import Data.Map.Strict (Map)-import Data.Scientific (Scientific)-import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)-import Data.UUID (UUID)-import Data.Vector (Vector)-import Data.Aeson (Value)-import Network.IP.Addr (IP, NetAddr)
library/PostgreSQL/Binary/Decoding.hs view
@@ -1,78 +1,108 @@ 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,- 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,- -- ** HStore- hstore,- -- **- enum,- refine,-)+ ( 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 PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure) import BinaryParser-import qualified PostgreSQL.Binary.Integral as Integral-import qualified PostgreSQL.Binary.Interval as Interval-import qualified PostgreSQL.Binary.Numeric as Numeric-import qualified PostgreSQL.Binary.Time as Time-import qualified PostgreSQL.Binary.Inet as Inet-import qualified Data.Vector as Vector+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.Aeson as Aeson-import qualified Network.IP.Addr as IPAddr-+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@@ -82,7 +112,6 @@ BinaryParser.run -- * Helpers-------------------------- -- | -- Any int number of a limited byte-size.@@ -91,32 +120,23 @@ intOfSize x = fmap Integral.pack (bytesOfSize x) -{-# INLINABLE onContent #-}-onContent :: Value a -> Value ( Maybe a )+{-# INLINEABLE onContent #-}+onContent :: Value a -> Value (Maybe a) onContent decoder =- size >>=- \case- (-1) -> pure Nothing- n -> fmap Just (sized (fromIntegral n) decoder)+ size+ >>= \case+ (-1) -> pure Nothing+ n -> fmap Just (sized (fromIntegral n) decoder) where size = intOfSize 4 :: Value Int32 -{-# INLINABLE content #-}-content :: Value (Maybe ByteString)-content =- intOfSize 4 >>= \case- (-1) -> pure Nothing- n -> fmap Just (bytesOfSize n)- {-# INLINE nonNull #-} nonNull :: Maybe a -> Value a nonNull = maybe (failure "Unexpected NULL") return - -- * Primitive-------------------------- -- | -- Lifts a custom decoder implementation.@@ -154,40 +174,45 @@ components <- Vector.replicateM componentsAmount (intOfSize 2) either failure return (Numeric.scientific pointIndex signCode components) -{-# INLINABLE uuid #-}+{-# INLINEABLE uuid #-} uuid :: Value UUID uuid = UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 {-# INLINE ip4 #-}-ip4 :: Value IPAddr.IP4+ip4 :: Value IP.IPv4 ip4 =- IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1+ IP.toIPv4w <$> intOfSize 4 {-# INLINE ip6 #-}-ip6 :: Value IPAddr.IP6+ip6 :: Value IP.IPv6 ip6 =- IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2+ IP.toIPv6w <$> ((,,,) <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4) -{-# INLINABLE inet #-}-inet :: Value (IPAddr.NetAddr IPAddr.IP)+{-# INLINEABLE inet #-}+inet :: Value IP.IPRange inet = do af <- intOfSize 1 netmask <- intOfSize 1- isCidr <- intOfSize 1- ipSize <- intOfSize 1- if | af == Inet.inetAddressFamily ->- do ip <- ip4- return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv4 ip)- | af == Inet.inet6AddressFamily ->- do ip <- ip6- return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv6 ip)- | otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af))- where- inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IPAddr.IP -> IPAddr.NetAddr IPAddr.IP- inetFromBytes _ netmask _ _ ip = IPAddr.netAddr ip netmask+ 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)) -{-# INLINABLE json_ast #-}+{-# 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'@@ -195,7 +220,7 @@ -- | -- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, -- produces a decoder.-{-# INLINABLE json_bytes #-}+{-# INLINEABLE json_bytes #-} json_bytes :: (ByteString -> Either Text a) -> Value a json_bytes cont = getAllBytes >>= parseJSON@@ -205,7 +230,7 @@ parseJSON = either BinaryParser.failure return . cont -{-# INLINABLE jsonb_ast #-}+{-# INLINEABLE jsonb_ast #-} jsonb_ast :: Value Aeson.Value jsonb_ast = jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict'@@ -213,11 +238,11 @@ -- | -- 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.-{-# INLINABLE jsonb_bytes #-}+{-# INLINEABLE jsonb_bytes #-} jsonb_bytes :: (ByteString -> Either Text a) -> Value a jsonb_bytes cont = getAllBytes >>= trimBytes >>= parseJSON@@ -225,18 +250,17 @@ getAllBytes = BinaryParser.remainders trimBytes =- maybe (BinaryParser.failure "Empty input") return .- fmap snd . ByteString.uncons+ maybe (BinaryParser.failure "Empty input") return+ . fmap snd+ . ByteString.uncons parseJSON = either BinaryParser.failure return . cont - -- ** Textual-------------------------- -- | -- A UTF-8-decoded char.-{-# INLINABLE char #-}+{-# INLINEABLE char #-} char :: Value Char char = fmap Text.uncons text_strict >>= \case@@ -247,7 +271,7 @@ -- | -- Any of the variable-length character types: -- BPCHAR, VARCHAR, NAME and TEXT.-{-# INLINABLE text_strict #-}+{-# INLINEABLE text_strict #-} text_strict :: Value Text text_strict = do@@ -262,12 +286,12 @@ -- | -- Any of the variable-length character types: -- BPCHAR, VARCHAR, NAME and TEXT.-{-# INLINABLE text_lazy #-}+{-# INLINEABLE text_lazy #-} text_lazy :: Value LazyText text_lazy = do input <- bytea_lazy- either (failure . exception input ) return (LazyText.decodeUtf8' input)+ either (failure . exception input) return (LazyText.decodeUtf8' input) where exception input = \case@@ -288,9 +312,7 @@ bytea_lazy = fmap LazyByteString.fromStrict remainders - -- * Date and Time-------------------------- -- | -- @DATE@ values decoding.@@ -366,38 +388,35 @@ interval_float :: Value DiffTime interval_float = do- u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8)+ 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 -- @--- -{-# INLINABLE hstore #-}-hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Value k -> Value v -> Value r+{-# 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@@ -411,30 +430,59 @@ value = onContent valueContent - -- * Composite-------------------------- -newtype Composite a =- Composite ( Value a )- deriving ( Functor , Applicative , Monad , MonadFail )+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 decoder) =- numOfComponents *> decoder- where- numOfComponents =- unitOfSize 4+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 -- |--- Lift a value 'Value' into 'Composite'.+-- 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 :: Value a -> Composite (Maybe a) nullableValueComposite valueValue =- Composite (skipOid *> onContent valueValue)+ baseFieldValueComposite (skipOid *> onContent valueValue) where skipOid = unitOfSize 4@@ -444,30 +492,62 @@ {-# INLINE valueComposite #-} valueComposite :: Value a -> Composite a valueComposite valueValue =- Composite (skipOid *> onContent valueValue >>= maybe (failure "Unexpected NULL") return)+ 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 )+newtype Array a+ = Array ([Word32] -> Value a)+ deriving (Functor) -- | -- Unlift an 'Array' to a value 'Value'.@@ -489,17 +569,16 @@ -- | -- 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 :: (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)@@ -508,7 +587,7 @@ -- | -- Lift a value 'Value' into 'Array' for parsing of nullable leaf values. {-# INLINE nullableValueArray #-}-nullableValueArray :: Value a -> Array ( Maybe a )+nullableValueArray :: Value a -> Array (Maybe a) nullableValueArray = Array . const . onContent @@ -519,9 +598,7 @@ valueArray = Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent - -- * Enum-------------------------- -- | -- Given a partial mapping from text to value,@@ -540,7 +617,6 @@ pure -- * Refining values-------------------------- -- | Given additional constraints when -- using an existing value decoder, produces@@ -548,3 +624,155 @@ {-# 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
@@ -1,76 +1,101 @@ module PostgreSQL.Binary.Encoding-(- -- * Encoding- Encoding,- encodingBytes,+ ( -- * Encoding+ Encoding,+ encodingBytes,+ composite,+ array,+ array_foldable,+ array_vector,+ nullableArray_vector,+ hStore_foldable,+ hStore_hashMap,+ hStore_map, - -- * - 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, - -- * Primitives- bool,- int2_int16,- int2_word16,- int4_int32,- int4_word32,- int8_int64,- int8_word64,- float4,- float8,- numeric,- uuid,- inet,- 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,+ -- ** Time - -- * Array- Array,- encodingArray,- nullArray,- dimensionArray,-)+ -- | 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 PostgreSQL.Binary.Prelude hiding (bool, length) import qualified ByteString.StrictBuilder as C-import qualified Data.Vector as A-import qualified PostgreSQL.Binary.Encoding.Builders as B-import qualified Data.ByteString.Builder as M+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 Data.Aeson as R-import qualified Network.IP.Addr as G-+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@@ -80,73 +105,67 @@ encodingBytes = C.builderBytes - -- * Values-------------------------- -{-|-Turn an array builder into final value.-The first parameter is OID of the element type.--}+{-# 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.--}+-- |+-- 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 :: (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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- A polymorphic @HSTORE@ encoder. {-# INLINE hStore_foldable #-}-hStore_foldable :: Foldable foldable => foldable (Text, Maybe Text) -> Encoding+hStore_foldable :: (Foldable foldable) => foldable (Text, Maybe Text) -> Encoding hStore_foldable = B.hStoreUsingFoldl foldl -{-|-@HSTORE@ encoder from HashMap.--}+-- |+-- @HSTORE@ encoder from HashMap. {-# INLINE hStore_hashMap #-} hStore_hashMap :: HashMap Text (Maybe Text) -> Encoding hStore_hashMap = B.hStore_hashMap -{-|-@HSTORE@ encoder from Map.--}+-- |+-- @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@@ -204,10 +223,15 @@ B.uuid {-# INLINE inet #-}-inet :: G.NetAddr G.IP -> Encoding+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 =@@ -233,11 +257,6 @@ bytea_lazy = B.bytea_lazy -{-# INLINE bytea_lazyBuilder #-}-bytea_lazyBuilder :: M.Builder -> Encoding-bytea_lazyBuilder =- B.bytea_lazyBuilder- {-# INLINE date #-} date :: Day -> Encoding date =@@ -323,15 +342,12 @@ jsonb_ast = B.jsonb_ast - -- * Array-------------------------- -{-|-Abstraction for encoding into multidimensional array.--}-data Array =- Array !Encoding ![Int32] !Bool+-- |+-- Abstraction for encoding into multidimensional array.+data Array+ = Array !Encoding ![Int32] !Bool encodingArray :: Encoding -> Array encodingArray value =@@ -357,3 +373,91 @@ 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
@@ -1,30 +1,28 @@-module PostgreSQL.Binary.Encoding.Builders-where+module PostgreSQL.Binary.Encoding.Builders where -import PostgreSQL.Binary.Prelude hiding (bool) import ByteString.StrictBuilder-import qualified Data.Vector as A-import qualified Data.Scientific as D-import qualified Data.UUID as E+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.HashMap.Strict as F-import qualified Data.Map.Strict as Q-import qualified Data.Aeson as R-import qualified Network.IP.Addr as G-import qualified PostgreSQL.Binary.Prelude as B-import qualified PostgreSQL.Binary.Numeric as C-import qualified PostgreSQL.Binary.Inet as H+import qualified Data.UUID as E+import qualified Data.Vector as A import qualified PostgreSQL.Binary.BuilderPrim as I-import qualified PostgreSQL.Binary.Time as O+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@@ -34,8 +32,8 @@ {-# INLINE sized #-} sized :: Builder -> Builder sized payload =- int4_int (builderLength payload) <>- payload+ int4_int (builderLength payload)+ <> payload {-# INLINE sizedMaybe #-} sizedMaybe :: (element -> Builder) -> Maybe element -> Builder@@ -62,9 +60,7 @@ false4 = int4_word32 0 - -- * Primitives-------------------------- {-# INLINE bool #-} bool :: Bool -> Builder@@ -116,22 +112,22 @@ float8 = int8_int64 . unsafeCoerce -{-# INLINABLE numeric #-}+{-# INLINEABLE numeric #-} numeric :: Scientific -> Builder numeric x =- word16BE (fromIntegral componentsAmount) <>- word16BE (fromIntegral pointIndex) <>- signCode <>- word16BE (fromIntegral trimmedExponent) <>- foldMap word16BE components+ word16BE (fromIntegral componentsAmount)+ <> word16BE (fromIntegral pointIndex)+ <> signCode+ <> word16BE (fromIntegral trimmedExponent)+ <> foldMap word16BE components where- componentsAmount = + componentsAmount = length components coefficient = D.coefficient x- exponent = + exponent = D.base10Exponent x- components = + components = C.extractComponents tunedCoefficient pointIndex = componentsAmount + (tunedExponent `div` 4) - 1@@ -164,32 +160,44 @@ case E.toWords uuid of (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 -{-# INLINABLE ip4 #-}-ip4 :: G.IP4 -> Builder-ip4 x =- case G.ip4ToOctets x of- (w1, w2, w3, w4) -> word8 w1 <> word8 w2 <> word8 w3 <> word8 w4+{-# INLINEABLE ip4 #-}+ip4 :: G.IPv4 -> Builder+ip4 =+ int4_word32 . G.fromIPv4w -{-# INLINABLE ip6 #-}-ip6 :: G.IP6 -> Builder+{-# INLINEABLE ip6 #-}+ip6 :: G.IPv6 -> Builder ip6 x =- case G.ip6ToWords x of- (w1, w2, w3, w4, w5, w6, w7, w8) ->- int2_word16 w1 <> int2_word16 w2 <> int2_word16 w3 <> int2_word16 w4 <>- int2_word16 w5 <> int2_word16 w6 <> int2_word16 w7 <> int2_word16 w8+ case G.fromIPv6w x of+ (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 -{-# INLINABLE inet #-}-inet :: G.NetAddr G.IP -> Builder-inet i =- case G.netHost i of- G.IPv4 x -> inetAddressFamily <> netLength <> isCidr <> ip4Size <> ip4 x- G.IPv6 x -> inet6AddressFamily <> netLength <> isCidr <> ip6Size <> ip6 x- where- netLength =- word8 (G.netLength i)- isCidr =- false1+{-# 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 =@@ -210,18 +218,21 @@ 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 = +char_utf8 = utf8Char {-# INLINE text_strict #-}@@ -249,30 +260,26 @@ bytea_lazyBuilder = lazyBytes . M.toLazyByteString - -- * Time-------------------------- {-# INLINE date #-} date :: Day -> Builder date = int4_int32 . fromIntegral . O.dayToPostgresJulian -{-# INLINABLE time_int #-}+{-# 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))+ let p = unsafeCoerce s :: Integer+ u = p `div` (10 ^ 6)+ in int8_int64 (fromIntegral u + 10 ^ 6 * 60 * (fromIntegral m + 60 * fromIntegral h)) -{-# INLINABLE time_float #-}+{-# 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)))+ 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@@ -287,7 +294,7 @@ {-# INLINE tz #-} tz :: TimeZone -> Builder tz =- int4_int . (*60) . negate . timeZoneMinutes+ int4_int . (* 60) . negate . timeZoneMinutes {-# INLINE timestamp_int #-} timestamp_int :: LocalTime -> Builder@@ -309,33 +316,31 @@ timestamptz_float = float8 . O.utcToSecs -{-# INLINABLE interval_int #-}+{-# INLINEABLE interval_int #-} interval_int :: DiffTime -> Builder interval_int x =- int64BE u <>- int32BE d <>- int32BE m+ 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+ P.Interval u d m =+ fromMaybe (error ("Too large DiffTime value for an interval " <> show x))+ $ P.fromDiffTime x -{-# INLINABLE interval_float #-}+{-# INLINEABLE interval_float #-} interval_float :: DiffTime -> Builder interval_float x =- float8 s <>- int32BE d <>- int32BE m+ 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+ P.Interval u d m =+ fromMaybe (error ("Too large DiffTime value for an interval " <> show x))+ $ P.fromDiffTime x s =- fromIntegral u / (10^6)-+ fromIntegral u / (10 ^ 6) -- * JSON-------------------------- {-# INLINE json_bytes #-} json_bytes :: ByteString -> Builder@@ -367,9 +372,7 @@ jsonb_ast = mappend "\1" . json_ast - -- * Array-------------------------- {-# INLINE array_vector #-} array_vector :: Word32 -> (element -> Builder) -> Vector element -> Builder@@ -391,42 +394,39 @@ payload = foldMap (sizedMaybe elementBuilder) vector -{-# INLINABLE array #-}+{-# 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+ 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'-@--}-{-# INLINABLE hStoreUsingFoldl #-}+-- |+-- 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@@ -439,12 +439,12 @@ int4_int count <> payload {-# INLINE hStoreUsingFoldMapAndSize #-}-hStoreUsingFoldMapAndSize :: (forall a. Monoid a => ((Text, Maybe Text) -> a) -> b -> a) -> Int -> b -> Builder+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 :: (forall a. (Monoid a) => (Text -> Maybe Text -> a) -> a) -> Int -> Builder hStoreFromFoldMapAndSize foldMap size = int4_int size <> foldMap hStoreRow @@ -456,11 +456,32 @@ {-# 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+ 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+ 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
@@ -2,7 +2,6 @@ import PostgreSQL.Binary.Prelude - -- | Address family AF_INET inetAddressFamily :: Word8 inetAddressFamily =
library/PostgreSQL/Binary/Integral.hs view
@@ -2,11 +2,10 @@ -- Utils for dealing with integer numbers. module PostgreSQL.Binary.Integral where -import PostgreSQL.Binary.Prelude import qualified Data.ByteString as B-+import PostgreSQL.Binary.Prelude -{-# INLINABLE pack #-}+{-# INLINEABLE pack #-} pack :: (Bits a, Num a) => B.ByteString -> a pack = B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0@@ -14,7 +13,7 @@ {-# INLINE unpackBySize #-} unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString unpackBySize n x =- B.pack $ map f $ reverse [0..n - 1]- where + B.pack $ map f $ reverse [0 .. n - 1]+ where f s = fromIntegral $ shiftR x (8 * s)
library/PostgreSQL/Binary/Interval.hs view
@@ -3,23 +3,23 @@ import PostgreSQL.Binary.Prelude hiding (months) import qualified PostgreSQL.Binary.Time as Time --data Interval = - Interval {- micros :: Int64,+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+maxDiffTime :: DiffTime+maxDiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros +minDiffTime :: DiffTime+minDiffTime = negate maxDiffTime+ fromDiffTime :: DiffTime -> Maybe Interval fromDiffTime x = if x > maxDiffTime || x < minDiffTime@@ -29,7 +29,7 @@ fromPicosUnsafe :: Integer -> Interval fromPicosUnsafe = evalState $ do- modify $ flip div (10^6)+ modify $ flip div (10 ^ 6) u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) d <- state $ swap . flip divMod (31) m <- get@@ -37,7 +37,13 @@ toDiffTime :: Interval -> DiffTime toDiffTime x =- picosecondsToDiffTime $ - (10 ^ 6) *- (fromIntegral (micros x) + - 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x)))+ picosecondsToDiffTime+ $ (10 ^ 6)+ * ( fromIntegral (micros x)+ + 10+ ^ 6+ * 60+ * 60+ * 24+ * (fromIntegral (days x + 31 * months x))+ )
library/PostgreSQL/Binary/Numeric.hs view
@@ -1,9 +1,8 @@ module PostgreSQL.Binary.Numeric where -import PostgreSQL.Binary.Prelude-import qualified Data.Vector as Vector import qualified Data.Scientific as Scientific-+import qualified Data.Vector as Vector+import PostgreSQL.Binary.Prelude {-# INLINE posSignCode #-} posSignCode :: Word16@@ -18,7 +17,7 @@ nanSignCode = 0xC000 {-# INLINE extractComponents #-}-extractComponents :: Integral a => a -> [Word16]+extractComponents :: (Integral a) => a -> [Word16] extractComponents = (reverse .) . (. abs) . unfoldr $ \case 0 -> Nothing@@ -26,13 +25,13 @@ (d, m) -> Just (fromIntegral m, d) {-# INLINE mergeComponents #-}-mergeComponents :: Integral a => Vector a -> Integer-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 = +mergeDigits :: (Integral a) => Vector a -> a+mergeDigits = Vector.foldl' (\l r -> l * 10 + r) 0 -- |@@ -47,16 +46,16 @@ d <- get return $ [a, b, c, d] -{-# INLINABLE componentsReplicateM #-}+{-# INLINEABLE componentsReplicateM #-} componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a-componentsReplicateM amount component = +componentsReplicateM amount component = foldl' folder (pure 0) (replicate amount component) where folder acc component =- liftA2 (+) (fmap (*10000) acc) component+ liftA2 (+) (fmap (* 10000) acc) component {-# INLINE signer #-}-signer :: Integral a => Word16 -> Either Text (a -> a)+signer :: (Integral a) => Word16 -> Either Text (a -> a) signer = \case 0x0000 -> return id
library/PostgreSQL/Binary/Prelude.hs view
@@ -1,31 +1,33 @@ module PostgreSQL.Binary.Prelude-( - module Exports,- LazyByteString,- ByteStringBuilder,- LazyText,- TextBuilder,- mapLeft,- joinMap,-)+ ( module Exports,+ LazyByteString,+ ByteStringBuilder,+ LazyText,+ TextBuilder,+ mapLeft,+ joinMap,+ ) where ---- base-------------------------- 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, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class 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@@ -35,24 +37,33 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports+import Data.Functor as Exports hiding (unzip) import Data.Functor.Identity as Exports-import Data.Int as Exports+import Data.HashMap.Strict as Exports (HashMap) import Data.IORef as Exports-import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+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 (Last(..), First(..), (<>))+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.Semigroup 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@@ -60,13 +71,12 @@ import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports-import Foreign.Storable as Exports hiding (sizeOf, alignment)-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(fromList, Item))+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 Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -75,58 +85,10 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports-import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce 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-import Data.Functor.Identity as Exports---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- text---------------------------import Data.Text as Exports (Text)---- vector---------------------------import Data.Vector as Exports (Vector)---- scientific---------------------------import Data.Scientific as Exports (Scientific)---- uuid---------------------------import Data.UUID as Exports (UUID)---- time---------------------------import Data.Time as Exports---- unordered-containers---------------------------import Data.HashMap.Strict as Exports (HashMap)---- containers---------------------------import Data.Map.Strict as Exports (Map)---- custom---------------------------import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Builder-import qualified Data.Text.Lazy-import qualified Data.Text.Lazy.Builder-+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@@ -140,12 +102,11 @@ 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 :: (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
@@ -1,134 +1,138 @@ module PostgreSQL.Binary.Time where import PostgreSQL.Binary.Prelude hiding (second)-import Data.Time.Calendar.Julian --{-# INLINABLE dayToPostgresJulian #-}+{-# INLINEABLE dayToPostgresJulian #-} dayToPostgresJulian :: Day -> Integer dayToPostgresJulian = (+ (2400001 - 2451545)) . toModifiedJulianDay -{-# INLINABLE postgresJulianToDay #-}-postgresJulianToDay :: Integral a => a -> Day+{-# INLINEABLE postgresJulianToDay #-}+postgresJulianToDay :: (Integral a) => a -> Day postgresJulianToDay = ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) -{-# INLINABLE microsToTimeOfDay #-}+{-# 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)+ return+ $ TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) -{-# INLINABLE microsToUTC #-}+{-# INLINEABLE microsToUTC #-} microsToUTC :: Int64 -> UTCTime microsToUTC = evalState $ do- d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 u <- get- return $- UTCTime (postgresJulianToDay d) (microsToDiffTime u)+ return+ $ UTCTime (postgresJulianToDay d) (microsToDiffTime u) -{-# INLINABLE microsToPico #-}+{-# INLINEABLE microsToPico #-} microsToPico :: Int64 -> Pico microsToPico =- unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer)+ unsafeCoerce . (* (10 ^ 6)) . (fromIntegral :: Int64 -> Integer) -{-# INLINABLE microsToDiffTime #-}+{-# INLINEABLE microsToDiffTime #-} microsToDiffTime :: Int64 -> DiffTime microsToDiffTime = unsafeCoerce microsToPico -{-# INLINABLE microsToLocalTime #-}+{-# INLINEABLE microsToLocalTime #-} microsToLocalTime :: Int64 -> LocalTime microsToLocalTime = evalState $ do- d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 u <- get- return $- LocalTime (postgresJulianToDay d) (microsToTimeOfDay u)+ return+ $ LocalTime (postgresJulianToDay d) (microsToTimeOfDay u) -{-# INLINABLE secsToTimeOfDay #-}+{-# 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)+ return+ $ TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s) -{-# INLINABLE secsToUTC #-}+{-# INLINEABLE secsToUTC #-} secsToUTC :: Double -> UTCTime secsToUTC = evalState $ do d <- state $ flip divMod' $ 60 * 60 * 24 s <- get- return $- UTCTime (postgresJulianToDay d) (secsToDiffTime s)+ return+ $ UTCTime (postgresJulianToDay d) (secsToDiffTime s) -{-# INLINABLE secsToLocalTime #-}+{-# INLINEABLE secsToLocalTime #-} secsToLocalTime :: Double -> LocalTime secsToLocalTime = evalState $ do d <- state $ flip divMod' $ 60 * 60 * 24 s <- get- return $- LocalTime (postgresJulianToDay d) (secsToTimeOfDay s)+ return+ $ LocalTime (postgresJulianToDay d) (secsToTimeOfDay s) -{-# INLINABLE secsToPico #-}+{-# INLINEABLE secsToPico #-} secsToPico :: Double -> Pico secsToPico s = unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer) -{-# INLINABLE secsToDiffTime #-}+{-# INLINEABLE secsToDiffTime #-} secsToDiffTime :: Double -> DiffTime secsToDiffTime = unsafeCoerce secsToPico -{-# INLINABLE localTimeToMicros #-}+{-# 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))+ in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) -{-# INLINABLE localTimeToSecs #-}+{-# 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))+ in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10 ^ 12)) -{-# INLINABLE utcToMicros #-}+{-# 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))+ in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) -{-# INLINABLE utcToSecs #-}+{-# 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))-+ 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 +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
postgresql-binary.cabal view
@@ -1,9 +1,7 @@-name:- postgresql-binary-version:- 0.12.5-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. .@@ -11,145 +9,156 @@ E.g., <http://hackage.haskell.org/package/hasql hasql> is based on this library. .- It supports all Postgres versions starting from 8.3 + 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:- 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-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 -library- hs-source-dirs:- library- ghc-options:- -funbox-strict-fields+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, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ 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+ import: base+ hs-source-dirs: library+ ghc-options: -funbox-strict-fields exposed-modules: PostgreSQL.Binary.Decoding PostgreSQL.Binary.Encoding- PostgreSQL.Binary.Data+ PostgreSQL.Binary.Range+ other-modules:+ PostgreSQL.Binary.BuilderPrim PostgreSQL.Binary.Encoding.Builders- PostgreSQL.Binary.Prelude+ PostgreSQL.Binary.Inet PostgreSQL.Binary.Integral PostgreSQL.Binary.Interval PostgreSQL.Binary.Numeric+ PostgreSQL.Binary.Prelude PostgreSQL.Binary.Time- PostgreSQL.Binary.Inet- PostgreSQL.Binary.BuilderPrim+ build-depends: aeson >=2 && <3, base >=4.12 && <5, binary-parser >=0.5.7 && <0.6,- bytestring >=0.10.4 && <0.12,+ bytestring >=0.10.4 && <0.13, bytestring-strict-builder >=0.4.5.4 && <0.5,- containers >=0.5 && <0.7,- network-ip >=0.3 && <0.4,+ 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.*,- uuid ==1.3.*,- vector >=0.12 && <0.14+ 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- type:- exitcode-stdio-1.0- hs-source-dirs:- tasty- main-is:- Main.hs+ import: base+ type: exitcode-stdio-1.0+ hs-source-dirs: tasty+ main-is: Main.hs other-modules:- Main.TextEncoder - Main.DB Main.Apx- Main.IO+ Main.Composite+ Main.DB Main.Gens+ Main.IO Main.PTI- Main.Properties Main.Prelude- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ Main.Properties+ Main.TextEncoder+ Main.TypedComposite+ build-depends:+ QuickCheck >=2.10 && <3, aeson >=2 && <3,- network-ip >=0.2 && <1,+ iproute >=1.4 && <2, postgresql-binary,- postgresql-libpq ==0.9.*,- QuickCheck >=2.10 && <3,+ postgresql-libpq >=0.9 && <0.12, quickcheck-instances >=0.3.22 && <0.4,- rerebase >=1.10.0.1 && <2,+ rerebase >=1.20.1.1 && <2, tasty >=1.4 && <2, tasty-hunit >=0.10 && <0.11,- tasty-quickcheck >=0.10 && <0.11+ tasty-quickcheck >=0.10 && <0.12, benchmark encoding- type: - exitcode-stdio-1.0- hs-source-dirs:- encoding- main-is:- Main.hs+ 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, 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,- rerebase >=1.10.0.1 && <2+ rerebase >=1.20.1.1 && <2, benchmark decoding- type: - exitcode-stdio-1.0- hs-source-dirs:- decoding- main-is:- Main.hs+ 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, 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,- rerebase >=1.10.0.1 && <2+ rerebase >=1.20.1.1 && <2,
tasty/Main.hs view
@@ -1,29 +1,29 @@ module Main where -import Main.Prelude hiding (assert, isRight, isLeft, select)-import Control.Monad.IO.Class-import Test.QuickCheck.Instances-import Test.Tasty-import qualified Test.Tasty.HUnit as HUnit-import qualified Test.Tasty.QuickCheck as QuickCheck-import qualified Test.QuickCheck as QuickCheck-import qualified PostgreSQL.Binary.Encoding as A-import qualified PostgreSQL.Binary.Decoding as B-import qualified Data.ByteString as ByteString+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.Properties as Properties 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 Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.Text.Lazy as TextLazy-import Main.Apx (Apx(..))-+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@@ -35,61 +35,57 @@ then [primitiveRoundtrip "jsonb" Gens.aeson PTI.jsonb A.jsonb_ast B.jsonb_ast] else [] other =- [- 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)- ,+ [ 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@@ -99,9 +95,11 @@ 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)+ 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'" []@@ -109,172 +107,326 @@ 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- ,- 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+ 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)- ]+ 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+ 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))+ 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+ 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+ 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+ 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+ 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 + either (error . show) id+ $ unsafePerformIO+ $ DB.session+ $ DB.serverVersion
tasty/Main/Apx.hs view
@@ -2,33 +2,33 @@ import Main.Prelude - -- | -- A wrapper which provides a type-specific 'Eq' instance -- with approximate comparison.-newtype Apx a =- Apx { unApx :: a }+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+ Apx a1+ == Apx b1+ && Apx a2+ == Apx b2 instance Eq (Apx LocalTime) where (==) (Apx a) (Apx b) =- Apx (localTimeToSeconds a) ==- Apx (localTimeToSeconds b)+ Apx (localTimeToSeconds a)+ == Apx (localTimeToSeconds b) instance Eq (Apx UTCTime) where (==) (Apx a) (Apx b) =- Apx (utcTimeToSeconds a) ==- Apx (utcTimeToSeconds b)+ Apx (utcTimeToSeconds a)+ == Apx (utcTimeToSeconds b) instance Eq (Apx TimeOfDay) where (==) (Apx a) (Apx b) =- Apx (timeOfDayToSeconds a) ==- Apx (timeOfDayToSeconds b)+ Apx (timeOfDayToSeconds a)+ == Apx (timeOfDayToSeconds b) instance Eq (Apx TimeZone) where (==) (Apx a) (Apx b) =@@ -40,13 +40,16 @@ instance Eq (Apx Rational) where (==) (Apx a) (Apx b) =- a + error >= b &&- a - error <= b+ a+ + error+ >= b+ && a+ - error+ <= b where error = 10 ^^ negate 3 - utcTimeToSeconds :: UTCTime -> Rational utcTimeToSeconds (UTCTime days diffTime) = dayToSeconds days + diffTimeToSeconds diffTime@@ -61,8 +64,8 @@ localTimeToSeconds :: LocalTime -> Rational localTimeToSeconds (LocalTime day tod) =- dayToSeconds day +- timeOfDayToSeconds tod+ dayToSeconds day+ + timeOfDayToSeconds tod timeOfDayToSeconds :: TimeOfDay -> Rational timeOfDayToSeconds (TimeOfDay h m s) =
+ 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
@@ -1,19 +1,17 @@ module Main.DB-(- session,- oneRow,- unit,- integerDatetimes,- serverVersion,-)+ ( session,+ oneRow,+ unit,+ integerDatetimes,+ serverVersion,+ ) where -import Main.Prelude hiding (unit)-import Control.Monad.Trans.Reader import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.ByteString as ByteString import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.ByteString as ByteString; import Data.ByteString (ByteString)-+import Main.Prelude hiding (unit) type Session = ExceptT ByteString (ReaderT LibPQ.Connection IO)@@ -47,13 +45,15 @@ 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+ 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 =@@ -63,19 +63,15 @@ serverVersion = lift (ReaderT LibPQ.serverVersion) --- *--------------------------- connect :: IO LibPQ.Connection connect = LibPQ.connectdb bs where- bs = + bs = ByteString.intercalate " " components where- components = - [- "host=" <> host,+ components =+ [ "host=" <> host, "port=" <> (fromString . show) port, "user=" <> user, "password=" <> password,@@ -85,23 +81,25 @@ host = "localhost" port = 5432 user = "postgres"- password = ""+ 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'"- ]+ 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 = + parseResult = \case Just "on" -> True _ -> False
tasty/Main/Gens.hs view
@@ -1,25 +1,24 @@ module Main.Gens where -import Main.Prelude hiding (assert, isRight, isLeft, choose)-import Test.QuickCheck hiding (vector)-import Test.QuickCheck.Instances-import qualified Main.PTI as PTI+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 qualified Data.HashMap.Strict as HashMap-import qualified PostgreSQL.Binary.Encoding as Encoder-import qualified Data.Text as Text-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.KeyMap as AesonKeyMap-import qualified Data.Aeson.Key as AesonKey-import qualified Network.IP.Addr as IPAddr+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 a) => Gen a auto = arbitrary @@ -27,7 +26,7 @@ vector element = join $ Vector.replicateM <$> arbitrary <*> pure element -hashMap :: (Eq a, Hashable a) => Gen a -> Gen b -> Gen (HashMap a b)+hashMap :: (Hashable a) => Gen a -> Gen b -> Gen (HashMap a b) hashMap key value = fmap HashMap.fromList $ join $ replicateM <$> arbitrary <*> pure row where@@ -74,7 +73,7 @@ value = byDepth (succ depth) -postgresInt :: (Bounded a, Ord a, Integral a, Arbitrary a) => Gen a+postgresInt :: (Bounded a, Integral a, Arbitrary a) => Gen a postgresInt = arbitrary >>= \x -> if x > halfMaxBound then postgresInt else pure x where@@ -95,11 +94,13 @@ microsTimeOfDay :: Gen TimeOfDay microsTimeOfDay =- fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ - choose (0, (10^6)*24*60*60)+ fmap timeToTimeOfDay+ $ fmap picosecondsToDiffTime+ $ fmap (* (10 ^ 6))+ $ choose (0, (10 ^ 6) * 24 * 60 * 60) microsLocalTime :: Gen LocalTime-microsLocalTime = +microsLocalTime = LocalTime <$> arbitrary <*> microsTimeOfDay microsUTCTime :: Gen UTCTime@@ -108,14 +109,14 @@ intervalDiffTime :: Gen DiffTime intervalDiffTime = do- unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer)+ unsafeCoerce ((* (10 ^ 6)) <$> choose (uMin, uMax) :: Gen Integer) where- uMin = unsafeCoerce minInterval `div` 10^6- uMax = unsafeCoerce maxInterval `div` 10^6+ uMin = unsafeCoerce minInterval `div` 10 ^ 6+ uMax = unsafeCoerce maxInterval `div` 10 ^ 6 timeZone :: Gen TimeZone timeZone =- minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12)+ minutesToTimeZone <$> choose (-60 * 12 + 1, 60 * 12) timetz :: Gen (TimeOfDay, TimeZone) timetz =@@ -125,14 +126,29 @@ uuid = UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -inet :: Gen (IPAddr.NetAddr IPAddr.IP)+inet :: Gen IP.IPRange inet = do ipv6 <- choose (True, False) if ipv6- then IPAddr.netAddr <$> (IPAddr.IPv6 <$> (IPAddr.ip6FromWords <$>- arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)) <*> choose (0, 128)- else IPAddr.netAddr <$> (IPAddr.IPv4 <$> (IPAddr.ip4FromOctets <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)) <*> choose (0, 32)+ 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@@ -141,13 +157,13 @@ width3 <- choose (1, 10) replicateM width1 (replicateM width2 (replicateM width3 gen)) - -- * Constants-------------------------- -maxInterval :: DiffTime = - unsafeCoerce $ - (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer)+maxInterval :: DiffTime+maxInterval =+ unsafeCoerce+ $ (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) -minInterval :: DiffTime = +minInterval :: DiffTime+minInterval = negate maxInterval
tasty/Main/IO.hs view
@@ -2,55 +2,51 @@ -- Specific IO Actions module Main.IO where -import Main.Prelude hiding (assert, isRight, isLeft)-import Test.QuickCheck-import Test.QuickCheck.Instances-import qualified Main.PTI as PTI-import qualified Main.DB as DB-import qualified Main.TextEncoder as TextEncoder -import qualified Data.Scientific as Scientific-import qualified Data.UUID as UUID-import qualified Data.Vector as Vector+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-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.ByteString.Builder as ByteStringBuilder-import qualified Data.ByteString.Lazy as ByteStringLazy - 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+ 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 ) ]+ [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+ 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 ) ]+ [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+ 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
@@ -1,14 +1,13 @@ module Main.PTI where -import Main.Prelude hiding (bool) import qualified Database.PostgreSQL.LibPQ as LibPQ-+import Main.Prelude hiding (bool) -- | A Postgresql type info-data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }+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 }+data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid} mkOID :: Word32 -> OID mkOID x =@@ -18,77 +17,229 @@ mkPTI oid arrayOID = PTI (mkOID oid) (fmap mkOID arrayOID) - -- * Constants-------------------------- -abstime = mkPTI 702 (Just 1023)-aclitem = mkPTI 1033 (Just 1034)-bit = mkPTI 1560 (Just 1561)-bool = mkPTI 16 (Just 1000)-box = mkPTI 603 (Just 1020)-bpchar = mkPTI 1042 (Just 1014)-bytea = mkPTI 17 (Just 1001)-char = mkPTI 18 (Just 1002)-cid = mkPTI 29 (Just 1012)-cidr = mkPTI 650 (Just 651)-circle = mkPTI 718 (Just 719)-cstring = mkPTI 2275 (Just 1263)-date = mkPTI 1082 (Just 1182)-daterange = mkPTI 3912 (Just 3913)-float4 = mkPTI 700 (Just 1021)-float8 = mkPTI 701 (Just 1022)-gtsvector = mkPTI 3642 (Just 3644)-inet = mkPTI 869 (Just 1041)-int2 = mkPTI 21 (Just 1005)-int2vector = mkPTI 22 (Just 1006)-int4 = mkPTI 23 (Just 1007)-int4range = mkPTI 3904 (Just 3905)-int8 = mkPTI 20 (Just 1016)-int8range = mkPTI 3926 (Just 3927)-interval = mkPTI 1186 (Just 1187)-json = mkPTI 114 (Just 199)-jsonb = mkPTI 3802 (Just 3807)-line = mkPTI 628 (Just 629)-lseg = mkPTI 601 (Just 1018)-macaddr = mkPTI 829 (Just 1040)-money = mkPTI 790 (Just 791)-name = mkPTI 19 (Just 1003)-numeric = mkPTI 1700 (Just 1231)-numrange = mkPTI 3906 (Just 3907)-oid = mkPTI 26 (Just 1028)-oidvector = mkPTI 30 (Just 1013)-path = mkPTI 602 (Just 1019)-point = mkPTI 600 (Just 1017)-polygon = mkPTI 604 (Just 1027)-record = mkPTI 2249 (Just 2287)-refcursor = mkPTI 1790 (Just 2201)-regclass = mkPTI 2205 (Just 2210)-regconfig = mkPTI 3734 (Just 3735)-regdictionary = mkPTI 3769 (Just 3770)-regoper = mkPTI 2203 (Just 2208)-regoperator = mkPTI 2204 (Just 2209)-regproc = mkPTI 24 (Just 1008)-regprocedure = mkPTI 2202 (Just 2207)-regtype = mkPTI 2206 (Just 2211)-reltime = mkPTI 703 (Just 1024)-text = mkPTI 25 (Just 1009)-tid = mkPTI 27 (Just 1010)-time = mkPTI 1083 (Just 1183)-timestamp = mkPTI 1114 (Just 1115)-timestamptz = mkPTI 1184 (Just 1185)-timetz = mkPTI 1266 (Just 1270)-tinterval = mkPTI 704 (Just 1025)-tsquery = mkPTI 3615 (Just 3645)-tsrange = mkPTI 3908 (Just 3909)-tstzrange = mkPTI 3910 (Just 3911)-tsvector = mkPTI 3614 (Just 3643)-txid_snapshot = mkPTI 2970 (Just 2949)-unknown = mkPTI 705 Nothing-uuid = mkPTI 2950 (Just 2951)-varbit = mkPTI 1562 (Just 1563)-varchar = mkPTI 1043 (Just 1015)-void = mkPTI 2278 Nothing-xid = mkPTI 28 (Just 1011)-xml = mkPTI 142 (Just 143)+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
@@ -1,25 +1,18 @@ module Main.Prelude-( - module Exports,- LazyByteString,- ByteStringBuilder,- LazyText,- TextBuilder,-)+ ( module Exports,+ LazyByteString,+ ByteStringBuilder,+ LazyText,+ TextBuilder,+ ) where ---- rerebase---------------------------import Prelude as Exports hiding (assert, Data, fail, check)---- custom---------------------------import qualified Data.ByteString.Lazy 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@@ -32,4 +25,3 @@ type TextBuilder = Data.Text.Lazy.Builder.Builder-
tasty/Main/Properties.hs view
@@ -1,22 +1,20 @@ module Main.Properties where -import Main.Prelude hiding (assert, isRight, isLeft)-import Test.QuickCheck-import Test.QuickCheck.Instances-import qualified Data.Scientific as Scientific-import qualified Data.UUID as UUID-import qualified Data.Vector as Vector+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 qualified Main.TextEncoder as C -import qualified Main.PTI as PTI-import qualified Main.DB as DB-import qualified Main.IO as IO-import qualified Database.PostgreSQL.LibPQ as LibPQ-+import Test.QuickCheck -roundtrip :: (Show a, Eq a) => - LibPQ.Oid -> (Bool -> (a -> B.Encoding)) -> (Bool -> A.Value a) -> a -> Property+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)
tasty/Main/TextEncoder.hs view
@@ -1,12 +1,11 @@ -- | -- Encoders to text format.-module Main.TextEncoder where+module Main.TextEncoder where -import Main.Prelude hiding (maybe, bool) import Data.ByteString.Builder import qualified Data.ByteString.Builder.Scientific-import qualified Data.Text.Encoding import qualified Data.UUID+import Main.Prelude hiding (bool, maybe) import qualified Main.Prelude as Prelude type Encoder a =@@ -19,11 +18,11 @@ int2_int16 :: Encoder Int16 int2_int16 = int16Dec- + int4_int32 :: Encoder Int32 int4_int32 = int32Dec- + int8_int64 :: Encoder Int64 int8_int64 = int64Dec@@ -31,11 +30,11 @@ int2_word16 :: Encoder Word16 int2_word16 = word16Dec- + int4_word32 :: Encoder Word32 int4_word32 = word32Dec- + int8_word64 :: Encoder Word64 int8_word64 = word64Dec@@ -59,4 +58,3 @@ 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