diff --git a/decoding/Main.hs b/decoding/Main.hs --- a/decoding/Main.hs +++ b/decoding/Main.hs @@ -3,61 +3,58 @@ import Prelude import Criterion import Criterion.Main -import qualified PostgreSQL.Binary.Encoder as E -import qualified PostgreSQL.Binary.Decoder as D +import qualified PostgreSQL.Binary.Encoding as E +import qualified PostgreSQL.Binary.Decoding as D main = defaultMain [ - b "bool" D.bool (E.run E.bool True) + b "bool" D.bool ((E.encodingBytes . E.bool) True) , - b "int2" (D.int :: D.Decoder Int16) (E.run E.int2_int16 1000) + b "int2" (D.int :: D.Value Int16) ((E.encodingBytes . E.int2_int16) 1000) , - b "int4" (D.int :: D.Decoder Int32) (E.run E.int4_int32 1000) + b "int4" (D.int :: D.Value Int32) ((E.encodingBytes . E.int4_int32) 1000) , - b "int8" (D.int :: D.Decoder Int64) (E.run E.int8_int64 1000) + b "int8" (D.int :: D.Value Int64) ((E.encodingBytes . E.int8_int64) 1000) , - b "float4" D.float4 (E.run E.float4 12.65468468) + b "float4" D.float4 ((E.encodingBytes . E.float4) 12.65468468) , - b "float8" D.float8 (E.run E.float8 12.65468468) + b "float8" D.float8 ((E.encodingBytes . E.float8) 12.65468468) , - b "numeric" D.numeric (E.run E.numeric (read "20.213290183")) + b "numeric" D.numeric ((E.encodingBytes . E.numeric) (read "20.213290183")) , - b "char" D.char (E.run E.char 'Я') + b "char" D.char ((E.encodingBytes . E.char_utf8) 'Я') , - b "text" D.text_strict (E.run E.text_strict "alsdjflskjдывлоаы оады") + b "text" D.text_strict ((E.encodingBytes . E.text_strict) "alsdjflskjдывлоаы оады") , - b "bytea" D.bytea_strict (E.run E.bytea_strict "alskdfj;dasjfl;dasjflksdj") + b "bytea" D.bytea_strict ((E.encodingBytes . E.bytea_strict) "alskdfj;dasjfl;dasjflksdj") , - b "date" D.date (E.run E.date (read "2000-01-19")) + b "date" D.date ((E.encodingBytes . E.date) (read "2000-01-19")) , - b "time" D.time_int (E.run E.time_int (read "10:41:06")) + b "time" D.time_int ((E.encodingBytes . E.time_int) (read "10:41:06")) , - b "timetz" D.timetz_int (E.run E.timetz_int (read "(10:41:06, +0300)")) + b "timetz" D.timetz_int ((E.encodingBytes . E.timetz_int) (read "(10:41:06, +0300)")) , - b "timestamp" D.timestamp_int (E.run E.timestamp_int (read "2000-01-19 10:41:06")) + b "timestamp" D.timestamp_int ((E.encodingBytes . E.timestamp_int) (read "2000-01-19 10:41:06")) , - b "timestamptz" D.timestamptz_int (E.run E.timestamptz_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.run E.interval_int (secondsToDiffTime 23472391128374)) + b "interval" D.interval_int ((E.encodingBytes . E.interval_int) (secondsToDiffTime 23472391128374)) , - b "uuid" D.uuid (E.run E.uuid (read "550e8400-e29b-41d4-a716-446655440000")) + b "uuid" D.uuid ((E.encodingBytes . E.uuid) (read "550e8400-e29b-41d4-a716-446655440000")) , let encoder = - E.array 23 $ - E.arrayDimension foldl' $ - E.arrayValue $ - E.int4_int32 + E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32) decoder = D.array $ - D.arrayDimension replicateM $ - D.arrayNonNullValue $ - (D.int :: D.Decoder Int32) + D.dimensionArray replicateM $ + D.valueArray $ + (D.int :: D.Value Int32) in - b "array" decoder (E.run encoder [1,2,3,4]) + b "array" decoder (E.encodingBytes (encoder [1,2,3,4])) ] where b name decoder value = - bench name $ nf (D.run decoder) value + bench name $ nf (D.valueParser decoder) value diff --git a/encoding/Main.hs b/encoding/Main.hs --- a/encoding/Main.hs +++ b/encoding/Main.hs @@ -3,55 +3,52 @@ import Prelude import Criterion import Criterion.Main -import qualified PostgreSQL.Binary.Encoder as E +import qualified PostgreSQL.Binary.Encoding as E main = defaultMain [ - b "bool" E.bool True + value "bool" E.bool True , - b "int2" E.int2_int16 1000 + value "int2" E.int2_int16 1000 , - b "int4" E.int4_int32 1000 + value "int4" E.int4_int32 1000 , - b "int8" E.int8_int64 1000 + value "int8" E.int8_int64 1000 , - b "float4" E.float4 12.65468468 + value "float4" E.float4 12.65468468 , - b "float8" E.float8 12.65468468 + value "float8" E.float8 12.65468468 , - b "numeric" E.numeric (read "20.213290183") + value "numeric" E.numeric (read "20.213290183") , - b "char" E.char 'Я' + value "char_utf8" E.char_utf8 'Я' , - b "text" E.text_strict "alsdjflskjдывлоаы оады" + value "text" E.text_strict "alsdjflskjдывлоаы оады" , - b "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj" + value "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj" , - b "date" E.date (read "2000-01-19") + value "date" E.date (read "2000-01-19") , - b "time" E.time_int (read "10:41:06") + value "time" E.time_int (read "10:41:06") , - b "timetz" E.timetz_int (read "(10:41:06, +0300)") + value "timetz" E.timetz_int (read "(10:41:06, +0300)") , - b "timestamp" E.timestamp_int (read "2000-01-19 10:41:06") + value "timestamp" E.timestamp_int (read "2000-01-19 10:41:06") , - b "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06") + value "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06") , - b "interval" E.interval_int (secondsToDiffTime 23472391128374) + value "interval" E.interval_int (secondsToDiffTime 23472391128374) , - b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000") + value "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000") , let encoder = - E.array 23 $ - E.arrayDimension foldl' $ - E.arrayValue $ - E.int4_int32 + E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32) in - b "array" encoder [1,2,3,4] + value "array" encoder [1,2,3,4] ] where - b name encoder value = - bench name $ nf (E.run encoder) value + value name encoder value = + bench name $ nf (E.encodingBytes . encoder) value diff --git a/library/PostgreSQL/Binary/Data.hs b/library/PostgreSQL/Binary/Data.hs --- a/library/PostgreSQL/Binary/Data.hs +++ b/library/PostgreSQL/Binary/Data.hs @@ -1,58 +1,25 @@ --- | --- Models of supported data structures according to the serialisation format. -module PostgreSQL.Binary.Data where - -import PostgreSQL.Binary.Prelude -import qualified Network.IP.Addr as IPAddr - --- | --- A representation of a data serializable to the PostgreSQL array binary format. --- --- Consists of a vector of dimensions, a vector of encoded elements, --- a flag specifying, whether it contains any nulls, and an oid. -type Array = - (Vector ArrayDimension, Vector Content, Bool, OID) - --- | --- A width and a lower bound. --- --- Currently the lower bound is only allowed to have a value of @1@. -type ArrayDimension = - (Word32, Word32) - --- | --- An encoded value. 'Nothing' if it represents a @NULL@. -type Content = - Maybe ByteString - --- | --- A Postgres OID of a type. -type OID = - Word32 - --- | --- A representation of a composite Postgres data (Record or Row). -type Composite = - Vector (OID, Content) - --- | --- HStore. -type HStore = - Vector (ByteString, Content) - --- | --- The four components of UUID. -type UUID = - (Word32, Word32, Word32, Word32) +{-| +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 --- | --- Representation of the PostgreSQL Numeric encoding. --- --- Consists of the following components: --- --- * Point index --- * Sign code --- * Components --- -type Numeric = - (Int16, Word16, Vector Int16) +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) diff --git a/library/PostgreSQL/Binary/Decoder.hs b/library/PostgreSQL/Binary/Decoder.hs deleted file mode 100644 --- a/library/PostgreSQL/Binary/Decoder.hs +++ /dev/null @@ -1,580 +0,0 @@ -module PostgreSQL.Binary.Decoder -( - Decoder, - run, - -- * 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 - ArrayDecoder, - array, - arrayDimension, - arrayValue, - arrayNonNullValue, - -- ** Composite - CompositeDecoder, - composite, - compositeValue, - compositeNonNullValue, - -- ** HStore - hstore, - -- ** - enum, -) -where - -import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure) -import BinaryParser -import qualified PostgreSQL.Binary.Data as Data -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 qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as LazyByteString -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 - - -type Decoder = - BinaryParser - - --- * Helpers -------------------------- - --- | --- Any int number of a limited byte-size. -{-# INLINE intOfSize #-} -intOfSize :: (Integral a, Bits a) => Int -> Decoder a -intOfSize x = - fmap Integral.pack (bytesOfSize x) - -{-# INLINABLE onContent #-} -onContent :: Decoder a -> Decoder ( Maybe a ) -onContent decoder = - size >>= - \case - (-1) -> pure Nothing - n -> fmap Just (sized (fromIntegral n) decoder) - where - size = - intOfSize 4 :: Decoder Int32 - -{-# INLINABLE content #-} -content :: Decoder (Maybe ByteString) -content = - intOfSize 4 >>= \case - (-1) -> pure Nothing - n -> fmap Just (bytesOfSize n) - -{-# INLINE nonNull #-} -nonNull :: Maybe a -> Decoder a -nonNull = - maybe (failure "Unexpected NULL") return - - --- * Primitive -------------------------- - --- | --- Lifts a custom decoder implementation. -{-# INLINE fn #-} -fn :: (ByteString -> Either Text a) -> Decoder a -fn fn = - BinaryParser.remainders >>= either BinaryParser.failure return . fn - -{-# INLINE int #-} -int :: (Integral a, Bits a) => Decoder a -int = - fmap Integral.pack remainders - -float4 :: Decoder Float -float4 = - unsafeCoerce (int :: Decoder Int32) - -float8 :: Decoder Double -float8 = - unsafeCoerce (int :: Decoder Int64) - -{-# INLINE bool #-} -bool :: Decoder Bool -bool = - fmap (== 1) byte - -{-# NOINLINE numeric #-} -numeric :: Decoder Scientific -numeric = - do - componentsAmount <- intOfSize 2 - pointIndex <- intOfSize 2 - signCode <- intOfSize 2 - unitOfSize 2 - components <- Vector.replicateM componentsAmount (intOfSize 2) - either failure return (Numeric.scientific pointIndex signCode components) - -{-# INLINABLE uuid #-} -uuid :: Decoder UUID -uuid = - UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 - -{-# INLINE ip4 #-} -ip4 :: Decoder IPAddr.IP4 -ip4 = - IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 - -{-# INLINE ip6 #-} -ip6 :: Decoder IPAddr.IP6 -ip6 = - IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 - -{-# INLINABLE inet #-} -inet :: Decoder (IPAddr.NetAddr IPAddr.IP) -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 - -{-# INLINABLE json_ast #-} -json_ast :: Decoder Aeson.Value -json_ast = - bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict' - --- | --- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, --- produces a decoder. -{-# INLINABLE json_bytes #-} -json_bytes :: (ByteString -> Either Text a) -> Decoder a -json_bytes cont = - getAllBytes >>= parseJSON - where - getAllBytes = - BinaryParser.remainders - parseJSON = - either BinaryParser.failure return . cont - -{-# INLINABLE jsonb_ast #-} -jsonb_ast :: Decoder Aeson.Value -jsonb_ast = - jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict' - --- | --- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, --- produces a decoder. --- --- For those wondering, yes, --- JSONB is encoded as plain JSON string in the binary format of Postgres. --- Sad, but true. -{-# INLINABLE jsonb_bytes #-} -jsonb_bytes :: (ByteString -> Either Text a) -> Decoder a -jsonb_bytes cont = - getAllBytes >>= trimBytes >>= parseJSON - where - getAllBytes = - BinaryParser.remainders - trimBytes = - maybe (BinaryParser.failure "Empty input") return . - fmap snd . ByteString.uncons - parseJSON = - either BinaryParser.failure return . cont - - --- ** Textual -------------------------- - --- | --- A UTF-8-decoded char. -{-# INLINABLE char #-} -char :: Decoder Char -char = - fmap Text.uncons text_strict >>= \case - Just (c, "") -> return c - Nothing -> failure "Empty input" - _ -> failure "Consumed too much" - --- | --- Any of the variable-length character types: --- BPCHAR, VARCHAR, NAME and TEXT. -{-# INLINABLE text_strict #-} -text_strict :: Decoder Text -text_strict = - remainders >>= either (failure . exception) return . Text.decodeUtf8' - where - exception = - \case - Text.DecodeError message byte -> fromString message - _ -> $bug "Unexpected unicode exception" - --- | --- Any of the variable-length character types: --- BPCHAR, VARCHAR, NAME and TEXT. -{-# INLINABLE text_lazy #-} -text_lazy :: Decoder LazyText -text_lazy = - bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8' - where - exception = - \case - Text.DecodeError message byte -> fromString message - _ -> $bug "Unexpected unicode exception" - --- | --- BYTEA or any other type in its undecoded form. -{-# INLINE bytea_strict #-} -bytea_strict :: Decoder ByteString -bytea_strict = - remainders - --- | --- BYTEA or any other type in its undecoded form. -{-# INLINE bytea_lazy #-} -bytea_lazy :: Decoder LazyByteString -bytea_lazy = - fmap LazyByteString.fromStrict remainders - - --- * Date and Time -------------------------- - --- | --- @DATE@ values decoding. -date :: Decoder Day -date = - fmap (Time.postgresJulianToDay . fromIntegral) (int :: Decoder Int32) - --- | --- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled. -time_int :: Decoder TimeOfDay -time_int = - fmap Time.microsToTimeOfDay int - --- | --- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled. -time_float :: Decoder TimeOfDay -time_float = - fmap Time.secsToTimeOfDay float8 - --- | --- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled. -timetz_int :: Decoder (TimeOfDay, TimeZone) -timetz_int = - (,) <$> sized 8 time_int <*> tz - --- | --- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled. -timetz_float :: Decoder (TimeOfDay, TimeZone) -timetz_float = - (,) <$> sized 8 time_float <*> tz - -{-# INLINE tz #-} -tz :: Decoder TimeZone -tz = - fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Decoder Int32) - --- | --- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. -timestamp_int :: Decoder LocalTime -timestamp_int = - fmap Time.microsToLocalTime int - --- | --- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. -timestamp_float :: Decoder LocalTime -timestamp_float = - fmap Time.secsToLocalTime float8 - --- | --- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. -timestamptz_int :: Decoder UTCTime -timestamptz_int = - fmap Time.microsToUTC int - --- | --- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. -timestamptz_float :: Decoder UTCTime -timestamptz_float = - fmap Time.secsToUTC float8 - --- | --- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled. -interval_int :: Decoder DiffTime -interval_int = - do - u <- sized 8 int - d <- sized 4 int - m <- int - return $ Interval.toDiffTime $ Interval.Interval u d m - --- | --- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled. -interval_float :: Decoder DiffTime -interval_float = - do - u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8) - d <- sized 4 int - m <- int - return $ Interval.toDiffTime $ Interval.Interval u d m - - --- * Exotic -------------------------- - --- | --- A lower-level array data parser, --- which aggregates the intermediate data representation as per the Postgres format. --- --- Only use this if 'array' doesn't fit your case. -{-# INLINABLE arrayRep #-} -arrayRep :: Decoder Data.Array -arrayRep = - do - dimensionsAmount <- intOfSize 4 - nullsValue <- nulls - oid <- intOfSize 4 - dimensions <- Vector.replicateM dimensionsAmount dimension - let valuesAmount = (Vector.product . Vector.map fst) dimensions - values <- Vector.replicateM (fromIntegral valuesAmount) content - return (dimensions, values, nullsValue, oid) - where - dimension = - (,) <$> intOfSize 4 <*> intOfSize 4 - nulls = - intOfSize 4 >>= \(x :: Word32) -> case x of - 0 -> return False - 1 -> return True - w -> failure $ "Invalid value: " <> (fromString . show) w - -{-# INLINABLE compositeRep #-} -compositeRep :: Decoder Data.Composite -compositeRep = - do - componentsAmount <- intOfSize 4 - Vector.replicateM componentsAmount component - where - component = - (,) <$> intOfSize 4 <*> content - --- | --- 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 :: Decoder [ ( Text , Maybe Text ) ] --- hstoreAsList = --- hstore replicateM text text --- @ --- -{-# INLINABLE hstore #-} -hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Decoder k -> Decoder v -> Decoder r -hstore replicateM keyContent valueContent = - do - componentsAmount <- intOfSize 4 - replicateM componentsAmount component - where - component = - (,) <$> key <*> value - where - key = - onContent keyContent >>= nonNull - value = - onContent valueContent - -{-# INLINABLE hstoreRep #-} -hstoreRep :: Decoder Data.HStore -hstoreRep = - do - componentsAmount <- intOfSize 4 - Vector.replicateM componentsAmount component - where - component = - (,) <$> key <*> content - where - key = - intOfSize 4 >>= bytesOfSize - - --- * Composite -------------------------- - -newtype CompositeDecoder a = - CompositeDecoder ( Decoder a ) - deriving ( Functor , Applicative , Monad ) - --- | --- Unlift a 'CompositeDecoder' to a value 'Decoder'. -{-# INLINE composite #-} -composite :: CompositeDecoder a -> Decoder a -composite (CompositeDecoder decoder) = - numOfComponents *> decoder - where - numOfComponents = - unitOfSize 4 - --- | --- Lift a value 'Decoder' into 'CompositeDecoder'. -{-# INLINE compositeValue #-} -compositeValue :: Decoder a -> CompositeDecoder ( Maybe a ) -compositeValue valueDecoder = - CompositeDecoder (skipOid *> onContent valueDecoder) - where - skipOid = - unitOfSize 4 - --- | --- Lift a non-nullable value 'Decoder' into 'CompositeDecoder'. -{-# INLINE compositeNonNullValue #-} -compositeNonNullValue :: Decoder a -> CompositeDecoder a -compositeNonNullValue valueDecoder = - CompositeDecoder (skipOid *> onContent valueDecoder >>= maybe (failure "Unexpected NULL") return) - where - skipOid = - unitOfSize 4 - - --- * 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 :: Decoder [ [ Text ] ] --- x = --- array (arrayDimension replicateM (fmap catMaybes (arrayDimension replicateM (arrayValue text)))) --- @ --- -newtype ArrayDecoder a = - ArrayDecoder ( [ Word32 ] -> Decoder a ) - deriving ( Functor ) - --- | --- Unlift an 'ArrayDecoder' to a value 'Decoder'. -{-# INLINE array #-} -array :: ArrayDecoder a -> Decoder a -array (ArrayDecoder decoder) = - do - dimensionsAmount <- intOfSize 4 - if dimensionsAmount /= 0 - then do - unitOfSize (4 + 4) - dimensionSizes <- replicateM dimensionsAmount dimensionSize - decoder dimensionSizes - else decoder [0] - where - dimensionSize = - intOfSize 4 <* unitOfSize 4 - --- | --- A function for parsing a dimension of an array. --- Provides support for multi-dimensional arrays. --- --- Accepts: --- --- * An implementation of the @replicateM@ function --- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), --- which determines the output value. --- --- * A decoder of its components, which can be either another 'arrayDimension' or 'arrayValue'. --- -{-# INLINE arrayDimension #-} -arrayDimension :: ( forall m. Monad m => Int -> m a -> m b ) -> ArrayDecoder a -> ArrayDecoder b -arrayDimension replicateM (ArrayDecoder component) = - ArrayDecoder $ \case - head : tail -> replicateM (fromIntegral head) (component tail) - _ -> failure "A missing dimension length" - --- | --- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of nullable leaf values. -{-# INLINE arrayValue #-} -arrayValue :: Decoder a -> ArrayDecoder ( Maybe a ) -arrayValue = - ArrayDecoder . const . onContent - --- | --- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of non-nullable leaf values. -{-# INLINE arrayNonNullValue #-} -arrayNonNullValue :: Decoder a -> ArrayDecoder a -arrayNonNullValue = - ArrayDecoder . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent - - --- * Enum -------------------------- - --- | --- Given a partial mapping from text to value, --- produces a decoder of that value. -{-# INLINE enum #-} -enum :: (Text -> Maybe a) -> Decoder a -enum mapping = - text_strict >>= onText - where - onText text = - maybe onNothing onJust (mapping text) - where - onNothing = - failure ("No mapping for text \"" <> text <> "\"") - onJust = - pure diff --git a/library/PostgreSQL/Binary/Decoding.hs b/library/PostgreSQL/Binary/Decoding.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Decoding.hs @@ -0,0 +1,535 @@ +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, +) +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 qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +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 + + +type Value = + BinaryParser + +valueParser :: Value a -> ByteString -> Either Text a +valueParser = + BinaryParser.run + +-- * Helpers +------------------------- + +-- | +-- Any int number of a limited byte-size. +{-# INLINE intOfSize #-} +intOfSize :: (Integral a, Bits a) => Int -> Value a +intOfSize x = + fmap Integral.pack (bytesOfSize x) + +{-# INLINABLE onContent #-} +onContent :: Value a -> Value ( Maybe a ) +onContent decoder = + size >>= + \case + (-1) -> pure Nothing + n -> fmap Just (sized (fromIntegral n) decoder) + where + size = + intOfSize 4 :: Value Int32 + +{-# 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. +{-# INLINE fn #-} +fn :: (ByteString -> Either Text a) -> Value a +fn fn = + BinaryParser.remainders >>= either BinaryParser.failure return . fn + +{-# INLINE int #-} +int :: (Integral a, Bits a) => Value a +int = + fmap Integral.pack remainders + +float4 :: Value Float +float4 = + unsafeCoerce (int :: Value Int32) + +float8 :: Value Double +float8 = + unsafeCoerce (int :: Value Int64) + +{-# INLINE bool #-} +bool :: Value Bool +bool = + fmap (== 1) byte + +{-# NOINLINE numeric #-} +numeric :: Value Scientific +numeric = + do + componentsAmount <- intOfSize 2 + pointIndex <- intOfSize 2 + signCode <- intOfSize 2 + unitOfSize 2 + components <- Vector.replicateM componentsAmount (intOfSize 2) + either failure return (Numeric.scientific pointIndex signCode components) + +{-# INLINABLE uuid #-} +uuid :: Value UUID +uuid = + UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 + +{-# INLINE ip4 #-} +ip4 :: Value IPAddr.IP4 +ip4 = + IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 + +{-# INLINE ip6 #-} +ip6 :: Value IPAddr.IP6 +ip6 = + IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 + +{-# INLINABLE inet #-} +inet :: Value (IPAddr.NetAddr IPAddr.IP) +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 + +{-# INLINABLE json_ast #-} +json_ast :: Value Aeson.Value +json_ast = + bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict' + +-- | +-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, +-- produces a decoder. +{-# INLINABLE json_bytes #-} +json_bytes :: (ByteString -> Either Text a) -> Value a +json_bytes cont = + getAllBytes >>= parseJSON + where + getAllBytes = + BinaryParser.remainders + parseJSON = + either BinaryParser.failure return . cont + +{-# INLINABLE jsonb_ast #-} +jsonb_ast :: Value Aeson.Value +jsonb_ast = + jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict' + +-- | +-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, +-- produces a decoder. +-- +-- For those wondering, yes, +-- JSONB is encoded as plain JSON string in the binary format of Postgres. +-- Sad, but true. +{-# INLINABLE jsonb_bytes #-} +jsonb_bytes :: (ByteString -> Either Text a) -> Value a +jsonb_bytes cont = + getAllBytes >>= trimBytes >>= parseJSON + where + getAllBytes = + BinaryParser.remainders + trimBytes = + maybe (BinaryParser.failure "Empty input") return . + fmap snd . ByteString.uncons + parseJSON = + either BinaryParser.failure return . cont + + +-- ** Textual +------------------------- + +-- | +-- A UTF-8-decoded char. +{-# INLINABLE char #-} +char :: Value Char +char = + fmap Text.uncons text_strict >>= \case + Just (c, "") -> return c + Nothing -> failure "Empty input" + _ -> failure "Consumed too much" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINABLE text_strict #-} +text_strict :: Value Text +text_strict = + remainders >>= either (failure . exception) return . Text.decodeUtf8' + where + exception = + \case + Text.DecodeError message byte -> fromString message + _ -> $bug "Unexpected unicode exception" + +-- | +-- Any of the variable-length character types: +-- BPCHAR, VARCHAR, NAME and TEXT. +{-# INLINABLE text_lazy #-} +text_lazy :: Value LazyText +text_lazy = + bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8' + where + exception = + \case + Text.DecodeError message byte -> fromString message + _ -> $bug "Unexpected unicode exception" + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_strict #-} +bytea_strict :: Value ByteString +bytea_strict = + remainders + +-- | +-- BYTEA or any other type in its undecoded form. +{-# INLINE bytea_lazy #-} +bytea_lazy :: Value LazyByteString +bytea_lazy = + fmap LazyByteString.fromStrict remainders + + +-- * Date and Time +------------------------- + +-- | +-- @DATE@ values decoding. +date :: Value Day +date = + fmap (Time.postgresJulianToDay . fromIntegral) (int :: Value Int32) + +-- | +-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled. +time_int :: Value TimeOfDay +time_int = + fmap Time.microsToTimeOfDay int + +-- | +-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled. +time_float :: Value TimeOfDay +time_float = + fmap Time.secsToTimeOfDay float8 + +-- | +-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled. +timetz_int :: Value (TimeOfDay, TimeZone) +timetz_int = + (,) <$> sized 8 time_int <*> tz + +-- | +-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timetz_float :: Value (TimeOfDay, TimeZone) +timetz_float = + (,) <$> sized 8 time_float <*> tz + +{-# INLINE tz #-} +tz :: Value TimeZone +tz = + fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Value Int32) + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamp_int :: Value LocalTime +timestamp_int = + fmap Time.microsToLocalTime int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamp_float :: Value LocalTime +timestamp_float = + fmap Time.secsToLocalTime float8 + +-- | +-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled. +timestamptz_int :: Value UTCTime +timestamptz_int = + fmap Time.microsToUTC int + +-- | +-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled. +timestamptz_float :: Value UTCTime +timestamptz_float = + fmap Time.secsToUTC float8 + +-- | +-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled. +interval_int :: Value DiffTime +interval_int = + do + u <- sized 8 int + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + +-- | +-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled. +interval_float :: Value DiffTime +interval_float = + do + u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8) + d <- sized 4 int + m <- int + return $ Interval.toDiffTime $ Interval.Interval u d m + + +-- * Exotic +------------------------- + +-- | +-- A function for generic in place parsing of an HStore value. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines how to produce the final datastructure from the rows. +-- +-- * A decoder for keys. +-- +-- * A decoder for values. +-- +-- Here's how you can use it to produce a parser to list: +-- +-- @ +-- hstoreAsList :: Value [ ( Text , Maybe Text ) ] +-- hstoreAsList = +-- hstore replicateM text text +-- @ +-- +{-# INLINABLE hstore #-} +hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Value k -> Value v -> Value r +hstore replicateM keyContent valueContent = + do + componentsAmount <- intOfSize 4 + replicateM componentsAmount component + where + component = + (,) <$> key <*> value + where + key = + onContent keyContent >>= nonNull + value = + onContent valueContent + + +-- * Composite +------------------------- + +newtype Composite a = + Composite ( Value a ) + deriving ( Functor , Applicative , Monad ) + +-- | +-- Unlift a 'Composite' to a value 'Value'. +{-# INLINE composite #-} +composite :: Composite a -> Value a +composite (Composite decoder) = + numOfComponents *> decoder + where + numOfComponents = + unitOfSize 4 + +-- | +-- Lift a value 'Value' into 'Composite'. +{-# INLINE nullableValueComposite #-} +nullableValueComposite :: Value a -> Composite ( Maybe a ) +nullableValueComposite valueValue = + Composite (skipOid *> onContent valueValue) + where + skipOid = + unitOfSize 4 + +-- | +-- Lift a non-nullable value 'Value' into 'Composite'. +{-# INLINE valueComposite #-} +valueComposite :: Value a -> Composite a +valueComposite valueValue = + Composite (skipOid *> onContent valueValue >>= maybe (failure "Unexpected NULL") return) + where + skipOid = + unitOfSize 4 + + +-- * Array +------------------------- + +-- | +-- An efficient generic array decoder, +-- which constructs the result value in place while parsing. +-- +-- Here's how you can use it to produce a specific array value decoder: +-- +-- @ +-- x :: Value [ [ Text ] ] +-- x = +-- array (dimensionArray replicateM (fmap catMaybes (dimensionArray replicateM (nullableValueArray text)))) +-- @ +-- +newtype Array a = + Array ( [ Word32 ] -> Value a ) + deriving ( Functor ) + +-- | +-- Unlift an 'Array' to a value 'Value'. +{-# INLINE array #-} +array :: Array a -> Value a +array (Array decoder) = + do + dimensionsAmount <- intOfSize 4 + if dimensionsAmount /= 0 + then do + unitOfSize (4 + 4) + dimensionSizes <- replicateM dimensionsAmount dimensionSize + decoder dimensionSizes + else decoder [0] + where + dimensionSize = + intOfSize 4 <* unitOfSize 4 + +-- | +-- A function for parsing a dimension of an array. +-- Provides support for multi-dimensional arrays. +-- +-- Accepts: +-- +-- * An implementation of the @replicateM@ function +-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), +-- which determines the output value. +-- +-- * A decoder of its components, which can be either another 'dimensionArray' or 'nullableValueArray'. +-- +{-# INLINE dimensionArray #-} +dimensionArray :: ( forall m. Monad m => Int -> m a -> m b ) -> Array a -> Array b +dimensionArray replicateM (Array component) = + Array $ \case + head : tail -> replicateM (fromIntegral head) (component tail) + _ -> failure "A missing dimension length" + +-- | +-- Lift a value 'Value' into 'Array' for parsing of nullable leaf values. +{-# INLINE nullableValueArray #-} +nullableValueArray :: Value a -> Array ( Maybe a ) +nullableValueArray = + Array . const . onContent + +-- | +-- Lift a value 'Value' into 'Array' for parsing of non-nullable leaf values. +{-# INLINE valueArray #-} +valueArray :: Value a -> Array a +valueArray = + Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent + + +-- * Enum +------------------------- + +-- | +-- Given a partial mapping from text to value, +-- produces a decoder of that value. +{-# INLINE enum #-} +enum :: (Text -> Maybe a) -> Value a +enum mapping = + text_strict >>= onText + where + onText text = + maybe onNothing onJust (mapping text) + where + onNothing = + failure ("No mapping for text \"" <> text <> "\"") + onJust = + pure diff --git a/library/PostgreSQL/Binary/Encoder.hs b/library/PostgreSQL/Binary/Encoder.hs deleted file mode 100644 --- a/library/PostgreSQL/Binary/Encoder.hs +++ /dev/null @@ -1,576 +0,0 @@ -{-# LANGUAGE CPP #-} -module PostgreSQL.Binary.Encoder -( - run, - -- * Value encoder - Encoder, - int2_int16, - int2_word16, - int4_int32, - int4_word32, - int8_int64, - int8_word64, - float4, - float8, - composite, - bool, - numeric, - uuid, - inet, - json_ast, - json_bytes, - jsonb_ast, - jsonb_bytes, - char, - text_strict, - text_lazy, - bytea_strict, - bytea_lazy, - date, - time_int, - time_float, - timetz_int, - timetz_float, - timestamp_int, - timestamp_float, - timestamptz_int, - timestamptz_float, - interval_int, - interval_float, - hstore, - hstoreRep, - array, - -- * Array encoder - ArrayEncoder, - arrayValue, - arrayNullableValue, - arrayDimension, - arrayRep, - -- * Enum - enum, -) -where - -import PostgreSQL.Binary.Prelude hiding (take, bool, maybe) -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Encoding as LazyText -import qualified Data.Vector as Vector -import qualified Data.Scientific as Scientific -import qualified Data.Aeson as Aeson -import qualified Data.UUID as UUID -import qualified PostgreSQL.Binary.Data as Data -import qualified PostgreSQL.Binary.Integral as Integral -import qualified PostgreSQL.Binary.Numeric as Numeric -import qualified PostgreSQL.Binary.Time as Time -import qualified PostgreSQL.Binary.Interval as Interval -import qualified PostgreSQL.Binary.BuilderPrim as BuilderPrim -import qualified PostgreSQL.Binary.Inet as Inet -import qualified Control.Foldl as Foldl -import qualified Network.IP.Addr as IPAddr - - -type Encoder a = - a -> Builder - -{-# INLINE run #-} -run :: Encoder a -> a -> ByteString -run encoder = - LazyByteString.toStrict . Builder.toLazyByteString . encoder - -{-# INLINE tuple2 #-} -tuple2 :: Encoder a -> Encoder b -> Encoder (a, b) -tuple2 e1 e2 = - \(v1, v2) -> e1 v1 <> e2 v2 - -{-# INLINE tuple3 #-} -tuple3 :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c) -tuple3 e1 e2 e3 = - \(v1, v2, v3) -> e1 v1 <> e2 v2 <> e3 v3 - -{-# INLINE tuple4 #-} -tuple4 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder (a, b, c, d) -tuple4 e1 e2 e3 e4 = - \(v1, v2, v3, v4) -> e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 - -{-# INLINE tuple5 #-} -tuple5 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder e -> Encoder (a, b, c, d, e) -tuple5 e1 e2 e3 e4 e5 (v1, v2, v3, v4, v5) = e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 <> e5 v5 - -{-# INLINE tuple8 #-} -tuple8 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder e -> Encoder f -> Encoder g -> Encoder h -> Encoder (a, b, c, d, e, f, g, h) -tuple8 e1 e2 e3 e4 e5 e6 e7 e8 (v1, v2, v3, v4, v5, v6, v7, v8) = e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 <> e5 v5 <> e6 v6 <> e7 v7 <> e8 v8 - -{-# INLINE premap #-} -premap :: (a -> b) -> Encoder b -> Encoder a -premap f e = - e . f - -{-# INLINE int_int8 #-} -int_int8 :: Encoder Int8 -int_int8 = - Builder.int8 - -{-# INLINE int_word8 #-} -int_word8 :: Encoder Word8 -int_word8 = - Builder.word8 - -{-# INLINE int2_int16 #-} -int2_int16 :: Encoder Int16 -int2_int16 = - Builder.int16BE - -{-# INLINE int2_word16 #-} -int2_word16 :: Encoder Word16 -int2_word16 = - Builder.word16BE - -{-# INLINE int4_int32 #-} -int4_int32 :: Encoder Int32 -int4_int32 = - Builder.int32BE - -{-# INLINE int4_word32 #-} -int4_word32 :: Encoder Word32 -int4_word32 = - Builder.word32BE - -{-# INLINE int4_int #-} -int4_int :: Encoder Int -int4_int = - int4_int32 . fromIntegral - -{-# INLINE int8_int64 #-} -int8_int64 :: Encoder Int64 -int8_int64 = - Builder.int64BE - -{-# INLINE int8_word64 #-} -int8_word64 :: Encoder Word64 -int8_word64 = - Builder.word64BE - -{-# INLINE float4 #-} -float4 :: Encoder Float -float4 = - int4_int32 . unsafeCoerce - -{-# INLINE float8 #-} -float8 :: Encoder Double -float8 = - int8_int64 . unsafeCoerce - -{-# INLINE null4 #-} -null4 :: ByteStringBuilder -null4 = - Builder.string7 "\255\255\255\255" - -{-# INLINABLE composite #-} -composite :: Encoder Data.Composite -composite vector = - int4_int (Vector.length vector) <> - foldMap component vector - where - component (oid, theContent) = - int4_word32 oid <> content theContent - -{-# INLINABLE content #-} -content :: Encoder Data.Content -content = - \case - Nothing -> - null4 - Just content -> - int4_int (ByteString.length content) <> - Builder.byteString content - -{-# INLINABLE maybe #-} -maybe :: Encoder a -> Encoder (Maybe a) -maybe encoder = - \case - Nothing -> - null4 - Just value -> - run encoder value & \bytes -> int4_int (ByteString.length bytes) <> Builder.byteString bytes - -{-# INLINE bool #-} -bool :: Encoder Bool -bool = - \case - True -> Builder.word8 1 - False -> Builder.word8 0 - -{-# INLINABLE numeric #-} -numeric :: Encoder Scientific -numeric x = - int2_int16 (fromIntegral componentsAmount) <> - int2_int16 (fromIntegral pointIndex) <> - int2_word16 signCode <> - int2_int16 (fromIntegral trimmedExponent) <> - foldMap int2_int16 components - where - componentsAmount = - length components - coefficient = - Scientific.coefficient x - exponent = - Scientific.base10Exponent x - components = - Numeric.extractComponents tunedCoefficient - pointIndex = - componentsAmount + (tunedExponent `div` 4) - 1 - (tunedCoefficient, tunedExponent) = - case mod exponent 4 of - 0 -> (coefficient, exponent) - x -> (coefficient * 10 ^ x, exponent - x) - trimmedExponent = - if tunedExponent >= 0 - then 0 - else negate tunedExponent - signCode = - if coefficient < 0 - then Numeric.negSignCode - else Numeric.posSignCode - -{-# INLINABLE uuid #-} -uuid :: Encoder UUID -uuid = - premap UUID.toWords (tuple4 int4_word32 int4_word32 int4_word32 int4_word32) - -{-# INLINABLE ip4 #-} -ip4 :: Encoder IPAddr.IP4 -ip4 = - premap IPAddr.ip4ToOctets (tuple4 int_word8 int_word8 int_word8 int_word8) - -{-# INLINABLE ip6 #-} -ip6 :: Encoder IPAddr.IP6 -ip6 = - premap IPAddr.ip6ToWords (tuple8 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16) - -{-# INLINABLE inet #-} -inet :: Encoder (IPAddr.NetAddr IPAddr.IP) -inet i = - case IPAddr.netHost i of - IPAddr.IPv4 x -> inetAddressFamily <> netLength <> isCidr <> ip4Size <> ip4 x - IPAddr.IPv6 x -> inet6AddressFamily <> netLength <> isCidr <> ip6Size <> ip6 x - where - inetAddressFamily = - int_word8 Inet.inetAddressFamily - inet6AddressFamily = - int_word8 Inet.inet6AddressFamily - netLength = - int_word8 (IPAddr.netLength i) - isCidr = - int_word8 0 - ip4Size = - int_int8 4 - ip6Size = - int_int8 16 - -{-# INLINABLE json_ast #-} -json_ast :: Encoder Aeson.Value -#if MIN_VERSION_aeson(0,10,0) -json_ast = - Aeson.fromEncoding . Aeson.toEncoding -#else -json_ast = - Builder.lazyByteString . Aeson.encode -#endif - -{-# INLINABLE json_bytes #-} -json_bytes :: Encoder ByteString -json_bytes = - Builder.byteString - -{-# INLINABLE jsonb_ast #-} -jsonb_ast :: Encoder Aeson.Value -jsonb_ast = - \x -> "\1" <> json_ast x - -{-# INLINABLE jsonb_bytes #-} -jsonb_bytes :: Encoder ByteString -jsonb_bytes = - \x -> "\1" <> Builder.byteString x - --- * 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. -{-# INLINABLE char #-} -char :: Encoder Char -char = - Builder.charUtf8 - -{-# INLINABLE text_strict #-} -text_strict :: Encoder Text -text_strict = - Text.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim - -{-# INLINABLE text_lazy #-} -text_lazy :: Encoder LazyText.Text -text_lazy = - LazyText.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim - -{-# INLINABLE bytea_strict #-} -bytea_strict :: Encoder ByteString -bytea_strict = - Builder.byteString - -{-# INLINABLE bytea_lazy #-} -bytea_lazy :: Encoder LazyByteString.ByteString -bytea_lazy = - Builder.lazyByteString - --- * Date and Time -------------------------- - -{-# INLINABLE date #-} -date :: Encoder Day -date = - int4_int32 . fromIntegral . Time.dayToPostgresJulian - -{-# INLINABLE time_int #-} -time_int :: Encoder TimeOfDay -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)) - -{-# INLINABLE time_float #-} -time_float :: Encoder TimeOfDay -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))) - -{-# INLINABLE timetz_int #-} -timetz_int :: Encoder (TimeOfDay, TimeZone) -timetz_int (timeX, tzX) = - time_int timeX <> tz tzX - -{-# INLINABLE timetz_float #-} -timetz_float :: Encoder (TimeOfDay, TimeZone) -timetz_float (timeX, tzX) = - time_float timeX <> tz tzX - -{-# INLINE tz #-} -tz :: Encoder TimeZone -tz = - int4_int . (*60) . negate . timeZoneMinutes - -{-# INLINABLE timestamp_int #-} -timestamp_int :: Encoder LocalTime -timestamp_int = - int8_int64 . Time.localTimeToMicros - -{-# INLINABLE timestamp_float #-} -timestamp_float :: Encoder LocalTime -timestamp_float = - float8 . Time.localTimeToSecs - -{-# INLINABLE timestamptz_int #-} -timestamptz_int :: Encoder UTCTime -timestamptz_int = - int8_int64 . Time.utcToMicros - -{-# INLINABLE timestamptz_float #-} -timestamptz_float :: Encoder UTCTime -timestamptz_float = - float8 . Time.utcToSecs - -{-# INLINABLE interval_int #-} -interval_int :: Encoder DiffTime -interval_int x = - Builder.int64BE u <> - Builder.int32BE d <> - Builder.int32BE m - where - Interval.Interval u d m = - fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ - Interval.fromDiffTime x - -{-# INLINABLE interval_float #-} -interval_float :: Encoder DiffTime -interval_float x = - Builder.doubleBE s <> - Builder.int32BE d <> - Builder.int32BE m - where - Interval.Interval u d m = - fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ - Interval.fromDiffTime x - s = - fromIntegral u / (10^6) - - --- * Array -------------------------- - -newtype ArrayEncoder a = - ArrayEncoder (a -> (Builder, [Int32], Bool)) - -{-# INLINABLE array #-} -array :: Word32 -> ArrayEncoder a -> Encoder a -array oid (ArrayEncoder encoder) = - \value -> - let - (valuesBuilder, dimensions, nulls) = - encoder value - (dimensionsAmount, dimensionsBuilder) = - let - step (amount, builder) dimension = - (succ amount, builder <> Builder.int32BE dimension <> Builder.word32BE 1) - init = - (0, mempty) - in - foldl' step init dimensions - nullsBuilder = - Builder.word32BE (if nulls then 1 else 0) - in - Builder.word32BE dimensionsAmount <> nullsBuilder <> Builder.word32BE oid <> dimensionsBuilder <> valuesBuilder - -{-# INLINABLE arrayValue #-} -arrayValue :: Encoder a -> ArrayEncoder a -arrayValue encoder = - ArrayEncoder $ \value -> - let - bytes = - run encoder value - builder = - Builder.word32BE (fromIntegral (ByteString.length bytes)) <> - Builder.byteString bytes - in - (builder, [], False) - -{-# INLINABLE arrayNullableValue #-} -arrayNullableValue :: Encoder a -> ArrayEncoder (Maybe a) -arrayNullableValue encoder = - ArrayEncoder $ \case - Nothing -> - (int4_int32 (-1), [], True) - Just value -> - let - bytes = - run encoder value - builder = - Builder.word32BE (fromIntegral (ByteString.length bytes)) <> - Builder.byteString bytes - in - (builder, [], False) - -{-# INLINABLE arrayDimension #-} -arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> ArrayEncoder b -> ArrayEncoder c -arrayDimension foldl (ArrayEncoder encoder) = - ArrayEncoder $ \value -> - let - step (builder, _, length, nulls) value = - let - (valueBuilder, valueDimensions, valueNulls) = encoder value - in - (builder <> valueBuilder, valueDimensions, succ length, nulls || valueNulls) - init = - (mempty, [], 0, False) - (foldedBuilder, foldedDimensions, foldedLength, foldedNulls) = - foldl step init value - resultDimensions = - foldedLength : foldedDimensions - in - (foldedBuilder, resultDimensions, foldedNulls) - - --- * Array rep -------------------------- - -{-# INLINABLE arrayRep #-} -arrayRep :: Encoder Data.Array -arrayRep (dimensionsV, valuesV, nullsV, oidV) = - dimensionsLength <> nulls <> oid <> dimensions <> values - where - dimensionsLength = - int4_word32 $ fromIntegral $ Vector.length dimensionsV - nulls = - int4_word32 $ if nullsV then 1 else 0 - oid = - int4_word32 oidV - dimensions = - foldMap dimension dimensionsV - values = - foldMap value valuesV - dimension (w, l) = - int4_word32 w <> int4_word32 l - value = - \case - Nothing -> int4_int32 (-1) - Just b -> int4_int32 (fromIntegral (ByteString.length b)) <> Builder.byteString b - - --- * 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 :: Encoder (Data.HashMap.Strict.HashMap Text (Maybe Text)) --- hashMapHStore = --- hstore foldl' --- @ --- -{-# INLINABLE hstore #-} -hstore :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> Encoder b -hstore foldl = - fold & \(Foldl.Fold step init fin) -> fin . foldl step init - where - fold = - (<>) <$> componentsAmount <*> components - where - componentsAmount = - fmap int4_int Foldl.length - components = - Foldl.foldMap componentBuilder id - where - componentBuilder (key, value) = - text_strict key <> maybe text_strict value - -{-# INLINABLE hstoreRep #-} -hstoreRep :: Encoder Data.HStore -hstoreRep vector = - int4_int32 (fromIntegral (Vector.length vector)) <> - foldMap component vector - where - component (key, value) = - Builder.byteString key <> content value - - --- * Enum -------------------------- - --- | --- Given a function, --- which maps the value into the textual enum label from the DB side, --- produces an encoder of that value --- -{-# INLINE enum #-} -enum :: (a -> Text) -> Encoder a -enum asText = - text_strict . asText diff --git a/library/PostgreSQL/Binary/Encoding.hs b/library/PostgreSQL/Binary/Encoding.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Encoding.hs @@ -0,0 +1,347 @@ +module PostgreSQL.Binary.Encoding +( + -- * Encoding + Encoding, + encodingBytes, + + -- * + 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, + 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_ast, + jsonb_bytes, + jsonb_ast, + + -- * Array + Array, + encodingArray, + nullArray, + dimensionArray, +) +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.ByteString.Lazy as N +import qualified Data.Text.Lazy as L +import qualified Data.Aeson as R +import qualified Network.IP.Addr as G + + +type Encoding = + C.Builder + +{-# INLINE encodingBytes #-} +encodingBytes :: Encoding -> ByteString +encodingBytes = + C.builderBytes + + +-- * Values +------------------------- + +{-| +Turn an array builder into final value. +The first parameter is OID of the element type. +-} +{-# INLINE array #-} +array :: Word32 -> Array -> Encoding +array oid (Array payload dimensions nulls) = + B.array oid dimensions nulls payload + +{-| +A helper for encoding of arrays of single dimension from foldables. +The first parameter is OID of the element type. +-} +{-# INLINE array_foldable #-} +array_foldable :: Foldable foldable => Word32 -> (element -> Maybe Encoding) -> foldable element -> Encoding +array_foldable oid elementBuilder = + array oid . dimensionArray foldl' (maybe nullArray encodingArray . elementBuilder) + +{-| +A helper for encoding of arrays of single dimension from vectors. +The first parameter is OID of the element type. +-} +{-# INLINE array_vector #-} +array_vector :: Word32 -> (element -> Encoding) -> Vector element -> Encoding +array_vector oid elementBuilder vector = + B.array_vector oid elementBuilder vector + +{-| +A helper for encoding of arrays of single dimension from vectors. +The first parameter is OID of the element type. +-} +{-# INLINE nullableArray_vector #-} +nullableArray_vector :: Word32 -> (element -> Encoding) -> Vector (Maybe element) -> Encoding +nullableArray_vector oid elementBuilder vector = + B.nullableArray_vector oid elementBuilder vector + +{-| +A polymorphic @HSTORE@ encoder. +-} +{-# INLINE hStore_foldable #-} +hStore_foldable :: Foldable foldable => foldable (Text, Maybe Text) -> Encoding +hStore_foldable = + B.hStoreUsingFoldl foldl + +{-| +@HSTORE@ encoder from HashMap. +-} +{-# INLINE hStore_hashMap #-} +hStore_hashMap :: HashMap Text (Maybe Text) -> Encoding +hStore_hashMap = + B.hStore_hashMap + +{-| +@HSTORE@ encoder from Map. +-} +{-# INLINE hStore_map #-} +hStore_map :: Map Text (Maybe Text) -> Encoding +hStore_map = + B.hStore_map + + +-- * Primitive +------------------------- + +{-# INLINE bool #-} +bool :: Bool -> Encoding +bool = + B.bool + +{-# INLINE int2_int16 #-} +int2_int16 :: Int16 -> Encoding +int2_int16 = + B.int2_int16 + +{-# INLINE int2_word16 #-} +int2_word16 :: Word16 -> Encoding +int2_word16 = + B.int2_word16 + +{-# INLINE int4_int32 #-} +int4_int32 :: Int32 -> Encoding +int4_int32 = + B.int4_int32 + +{-# INLINE int4_word32 #-} +int4_word32 :: Word32 -> Encoding +int4_word32 = + B.int4_word32 + +{-# INLINE int8_int64 #-} +int8_int64 :: Int64 -> Encoding +int8_int64 = + B.int8_int64 + +{-# INLINE int8_word64 #-} +int8_word64 :: Word64 -> Encoding +int8_word64 = + B.int8_word64 + +{-# INLINE float4 #-} +float4 :: Float -> Encoding +float4 = + B.float4 + +{-# INLINE float8 #-} +float8 :: Double -> Encoding +float8 = + B.float8 + +{-# INLINE numeric #-} +numeric :: Scientific -> Encoding +numeric = + B.numeric + +{-# INLINE uuid #-} +uuid :: UUID -> Encoding +uuid = + B.uuid + +{-# INLINE inet #-} +inet :: G.NetAddr G.IP -> Encoding +inet = + B.inet + +{-# INLINE char_utf8 #-} +char_utf8 :: Char -> Encoding +char_utf8 = + B.char_utf8 + +{-# INLINE text_strict #-} +text_strict :: Text -> Encoding +text_strict = + B.text_strict + +{-# INLINE text_lazy #-} +text_lazy :: L.Text -> Encoding +text_lazy = + B.text_lazy + +{-# INLINE bytea_strict #-} +bytea_strict :: ByteString -> Encoding +bytea_strict = + B.bytea_strict + +{-# INLINE bytea_lazy #-} +bytea_lazy :: N.ByteString -> Encoding +bytea_lazy = + B.bytea_lazy + +{-# INLINE bytea_lazyBuilder #-} +bytea_lazyBuilder :: M.Builder -> Encoding +bytea_lazyBuilder = + B.bytea_lazyBuilder + +{-# INLINE date #-} +date :: Day -> Encoding +date = + B.date + +{-# INLINE time_int #-} +time_int :: TimeOfDay -> Encoding +time_int = + B.time_int + +{-# INLINE time_float #-} +time_float :: TimeOfDay -> Encoding +time_float = + B.time_float + +{-# INLINE timetz_int #-} +timetz_int :: (TimeOfDay, TimeZone) -> Encoding +timetz_int = + B.timetz_int + +{-# INLINE timetz_float #-} +timetz_float :: (TimeOfDay, TimeZone) -> Encoding +timetz_float = + B.timetz_float + +{-# INLINE timestamp_int #-} +timestamp_int :: LocalTime -> Encoding +timestamp_int = + B.timestamp_int + +{-# INLINE timestamp_float #-} +timestamp_float :: LocalTime -> Encoding +timestamp_float = + B.timestamp_float + +{-# INLINE timestamptz_int #-} +timestamptz_int :: UTCTime -> Encoding +timestamptz_int = + B.timestamptz_int + +{-# INLINE timestamptz_float #-} +timestamptz_float :: UTCTime -> Encoding +timestamptz_float = + B.timestamptz_float + +{-# INLINE interval_int #-} +interval_int :: DiffTime -> Encoding +interval_int = + B.interval_int + +{-# INLINE interval_float #-} +interval_float :: DiffTime -> Encoding +interval_float = + B.interval_float + +{-# INLINE json_bytes #-} +json_bytes :: ByteString -> Encoding +json_bytes = + B.json_bytes + +{-# INLINE json_ast #-} +json_ast :: R.Value -> Encoding +json_ast = + B.json_ast + +{-# INLINE jsonb_bytes #-} +jsonb_bytes :: ByteString -> Encoding +jsonb_bytes = + B.jsonb_bytes + +{-# INLINE jsonb_ast #-} +jsonb_ast :: R.Value -> Encoding +jsonb_ast = + B.jsonb_ast + + +-- * Array +------------------------- + +{-| +Abstraction for encoding into multidimensional array. +-} +data Array = + Array !Encoding ![Int32] !Bool + +encodingArray :: Encoding -> Array +encodingArray value = + Array (B.sized value) [] False + +nullArray :: Array +nullArray = + Array B.null4 [] True + +dimensionArray :: (forall b. (b -> a -> b) -> b -> c -> b) -> (a -> Array) -> c -> Array +dimensionArray foldl' elementArray input = + Array builder dimensions nulls + where + dimensions = + foldedLength : foldedDimensions + (builder, foldedDimensions, foldedLength, nulls) = + foldl' step init input + where + init = + (mempty, [], 0, False) + step (!builder, _, !length, !nulls) element = + (builder <> elementBuilder, elementDimensions, succ length, nulls || elementNulls) + where + Array elementBuilder elementDimensions elementNulls = + elementArray element diff --git a/library/PostgreSQL/Binary/Encoding/Builders.hs b/library/PostgreSQL/Binary/Encoding/Builders.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Encoding/Builders.hs @@ -0,0 +1,456 @@ +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.ByteString.Builder as M +import qualified Data.ByteString.Lazy as N +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 PostgreSQL.Binary.BuilderPrim as I +import qualified PostgreSQL.Binary.Time as O +import qualified PostgreSQL.Binary.Interval as P + + +-- * Helpers +------------------------- + +{-# NOINLINE null4 #-} +null4 :: Builder +null4 = + int4_int (-1) + +{-# INLINE sized #-} +sized :: Builder -> Builder +sized payload = + int4_int (builderLength payload) <> + payload + +{-# INLINE sizedMaybe #-} +sizedMaybe :: (element -> Builder) -> Maybe element -> Builder +sizedMaybe elementBuilder = + B.maybe null4 (sized . elementBuilder) + +{-# NOINLINE true1 #-} +true1 :: Builder +true1 = + word8 1 + +{-# NOINLINE false1 #-} +false1 :: Builder +false1 = + word8 0 + +{-# NOINLINE true4 #-} +true4 :: Builder +true4 = + int4_word32 1 + +{-# NOINLINE false4 #-} +false4 :: Builder +false4 = + int4_word32 0 + + +-- * Primitives +------------------------- + +{-# INLINE bool #-} +bool :: Bool -> Builder +bool = + B.bool false1 true1 + +{-# INLINE int2_int16 #-} +int2_int16 :: Int16 -> Builder +int2_int16 = + int16BE + +{-# INLINE int2_word16 #-} +int2_word16 :: Word16 -> Builder +int2_word16 = + word16BE + +{-# INLINE int4_int32 #-} +int4_int32 :: Int32 -> Builder +int4_int32 = + int32BE + +{-# INLINE int4_word32 #-} +int4_word32 :: Word32 -> Builder +int4_word32 = + word32BE + +{-# INLINE int4_int #-} +int4_int :: Int -> Builder +int4_int = + int4_int32 . fromIntegral + +{-# INLINE int8_int64 #-} +int8_int64 :: Int64 -> Builder +int8_int64 = + int64BE + +{-# INLINE int8_word64 #-} +int8_word64 :: Word64 -> Builder +int8_word64 = + word64BE + +{-# INLINE float4 #-} +float4 :: Float -> Builder +float4 = + int4_int32 . unsafeCoerce + +{-# INLINE float8 #-} +float8 :: Double -> Builder +float8 = + int8_int64 . unsafeCoerce + +{-# INLINABLE numeric #-} +numeric :: Scientific -> Builder +numeric x = + word16BE (fromIntegral componentsAmount) <> + word16BE (fromIntegral pointIndex) <> + signCode <> + word16BE (fromIntegral trimmedExponent) <> + foldMap word16BE components + where + componentsAmount = + length components + coefficient = + D.coefficient x + exponent = + D.base10Exponent x + components = + C.extractComponents tunedCoefficient + pointIndex = + componentsAmount + (tunedExponent `div` 4) - 1 + (tunedCoefficient, tunedExponent) = + case mod exponent 4 of + 0 -> (coefficient, exponent) + x -> (coefficient * 10 ^ x, exponent - x) + trimmedExponent = + if tunedExponent >= 0 + then 0 + else negate tunedExponent + signCode = + if coefficient < 0 + then numericNegSignCode + else numericPosSignCode + +{-# NOINLINE numericNegSignCode #-} +numericNegSignCode :: Builder +numericNegSignCode = + int2_word16 C.negSignCode + +{-# NOINLINE numericPosSignCode #-} +numericPosSignCode :: Builder +numericPosSignCode = + int2_word16 C.posSignCode + +{-# INLINE uuid #-} +uuid :: UUID -> Builder +uuid uuid = + case E.toWords uuid of + (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 + +{-# 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 + +{-# INLINABLE ip6 #-} +ip6 :: G.IP6 -> 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 + +{-# 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 + +{-# NOINLINE inetAddressFamily #-} +inetAddressFamily :: Builder +inetAddressFamily = + word8 H.inetAddressFamily + +{-# NOINLINE inet6AddressFamily #-} +inet6AddressFamily :: Builder +inet6AddressFamily = + word8 H.inet6AddressFamily + +{-# NOINLINE ip4Size #-} +ip4Size :: Builder +ip4Size = + word8 4 + +{-# NOINLINE ip6Size #-} +ip6Size :: Builder +ip6Size = + word8 16 + + +-- * Text +------------------------- + +-- | +-- A UTF-8-encoded char. +-- +-- Note that since it's UTF-8-encoded +-- not the \"char\" but the \"text\" OID should be used with it. +{-# INLINE char_utf8 #-} +char_utf8 :: Char -> Builder +char_utf8 = + utf8Char + +{-# INLINE text_strict #-} +text_strict :: Text -> Builder +text_strict = + bytea_lazyBuilder . J.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim + +{-# INLINE text_lazy #-} +text_lazy :: L.Text -> Builder +text_lazy = + bytea_lazyBuilder . K.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim + +{-# INLINE bytea_strict #-} +bytea_strict :: ByteString -> Builder +bytea_strict = + bytes + +{-# INLINE bytea_lazy #-} +bytea_lazy :: N.ByteString -> Builder +bytea_lazy = + lazyBytes + +{-# INLINE bytea_lazyBuilder #-} +bytea_lazyBuilder :: M.Builder -> Builder +bytea_lazyBuilder = + lazyBytes . M.toLazyByteString + + +-- * Time +------------------------- + +{-# INLINE date #-} +date :: Day -> Builder +date = + int4_int32 . fromIntegral . O.dayToPostgresJulian + +{-# INLINABLE 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)) + +{-# INLINABLE time_float #-} +time_float :: TimeOfDay -> Builder +time_float (TimeOfDay h m s) = + let + p = unsafeCoerce s :: Integer + u = p `div` (10^6) + in float8 (fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h))) + +{-# INLINE timetz_int #-} +timetz_int :: (TimeOfDay, TimeZone) -> Builder +timetz_int (timeX, tzX) = + time_int timeX <> tz tzX + +{-# INLINE timetz_float #-} +timetz_float :: (TimeOfDay, TimeZone) -> Builder +timetz_float (timeX, tzX) = + time_float timeX <> tz tzX + +{-# INLINE tz #-} +tz :: TimeZone -> Builder +tz = + int4_int . (*60) . negate . timeZoneMinutes + +{-# INLINE timestamp_int #-} +timestamp_int :: LocalTime -> Builder +timestamp_int = + int8_int64 . O.localTimeToMicros + +{-# INLINE timestamp_float #-} +timestamp_float :: LocalTime -> Builder +timestamp_float = + float8 . O.localTimeToSecs + +{-# INLINE timestamptz_int #-} +timestamptz_int :: UTCTime -> Builder +timestamptz_int = + int8_int64 . O.utcToMicros + +{-# INLINE timestamptz_float #-} +timestamptz_float :: UTCTime -> Builder +timestamptz_float = + float8 . O.utcToSecs + +{-# INLINABLE interval_int #-} +interval_int :: DiffTime -> Builder +interval_int x = + int64BE u <> + int32BE d <> + int32BE m + where + P.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ + P.fromDiffTime x + +{-# INLINABLE interval_float #-} +interval_float :: DiffTime -> Builder +interval_float x = + float8 s <> + int32BE d <> + int32BE m + where + P.Interval u d m = + fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $ + P.fromDiffTime x + s = + fromIntegral u / (10^6) + + +-- * JSON +------------------------- + +{-# INLINE json_bytes #-} +json_bytes :: ByteString -> Builder +json_bytes = + bytes + +{-# INLINE json_ast #-} +json_ast :: R.Value -> Builder +json_ast = + lazyBytes . R.encode + +{-# INLINE jsonb_bytes #-} +jsonb_bytes :: ByteString -> Builder +jsonb_bytes = + mappend "\1" . bytes + +{-# INLINE jsonb_ast #-} +jsonb_ast :: R.Value -> Builder +jsonb_ast = + mappend "\1" . json_ast + + +-- * Array +------------------------- + +{-# INLINE array_vector #-} +array_vector :: Word32 -> (element -> Builder) -> Vector element -> Builder +array_vector oid elementBuilder vector = + array oid dimensions False payload + where + dimensions = + [fromIntegral (A.length vector)] + payload = + foldMap (sized . elementBuilder) vector + +{-# INLINE nullableArray_vector #-} +nullableArray_vector :: Word32 -> (element -> Builder) -> Vector (Maybe element) -> Builder +nullableArray_vector oid elementBuilder vector = + array oid dimensions True payload + where + dimensions = + [fromIntegral (A.length vector)] + payload = + foldMap (sizedMaybe elementBuilder) vector + +{-# INLINABLE array #-} +array :: Word32 -> [Int32] -> Bool -> Builder -> Builder +array oid dimensions nulls payload = + int4_int (B.length dimensions) <> + B.bool false4 true4 nulls <> + int4_word32 oid <> + foldMap arrayDimension dimensions <> + payload + +{-# INLINE arrayDimension #-} +arrayDimension :: Int32 -> Builder +arrayDimension dimension = + int4_int32 dimension <> true4 + + +-- * HStore +------------------------- + +{-| +A polymorphic in-place @HSTORE@ encoder. + +Accepts: + +* An implementation of the @foldl@ function +(e.g., @Data.Foldable.'foldl''@), +which determines the input value. + +Here's how you can use it to produce a specific encoder: + +@ +hashMapHStore :: Data.HashMap.Strict.HashMap Text (Maybe Text) -> Builder +hashMapHStore = + hStoreUsingFoldl foldl' +@ +-} +{-# INLINABLE hStoreUsingFoldl #-} +hStoreUsingFoldl :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> b -> Builder +hStoreUsingFoldl foldl = + exit . foldl progress enter + where + enter = + (0, mempty) + progress (!count, !payload) (key, value) = + (succ count, payload <> hStoreRow key value) + exit (count, payload) = + int4_int count <> payload + +{-# INLINE hStoreUsingFoldMapAndSize #-} +hStoreUsingFoldMapAndSize :: (forall a. Monoid a => ((Text, Maybe Text) -> a) -> b -> a) -> Int -> b -> Builder +hStoreUsingFoldMapAndSize foldMap size input = + int4_int size <> foldMap (uncurry hStoreRow) input + +{-# INLINE hStoreFromFoldMapAndSize #-} +hStoreFromFoldMapAndSize :: (forall a. Monoid a => (Text -> Maybe Text -> a) -> a) -> Int -> Builder +hStoreFromFoldMapAndSize foldMap size = + int4_int size <> foldMap hStoreRow + +{-# INLINE hStoreRow #-} +hStoreRow :: Text -> Maybe Text -> Builder +hStoreRow key value = + sized (text_strict key) <> sizedMaybe text_strict value + +{-# INLINE hStore_hashMap #-} +hStore_hashMap :: HashMap Text (Maybe Text) -> Builder +hStore_hashMap input = + int4_int (F.size input) <> + F.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input + +{-# INLINE hStore_map #-} +hStore_map :: Map Text (Maybe Text) -> Builder +hStore_map input = + int4_int (Q.size input) <> + Q.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input diff --git a/library/PostgreSQL/Binary/Numeric.hs b/library/PostgreSQL/Binary/Numeric.hs --- a/library/PostgreSQL/Binary/Numeric.hs +++ b/library/PostgreSQL/Binary/Numeric.hs @@ -18,7 +18,7 @@ nanSignCode = 0xC000 {-# INLINE extractComponents #-} -extractComponents :: Integral a => a -> [Int16] +extractComponents :: Integral a => a -> [Word16] extractComponents = (reverse .) . (. abs) . unfoldr $ \case 0 -> Nothing diff --git a/library/PostgreSQL/Binary/Prelude.hs b/library/PostgreSQL/Binary/Prelude.hs --- a/library/PostgreSQL/Binary/Prelude.hs +++ b/library/PostgreSQL/Binary/Prelude.hs @@ -48,6 +48,14 @@ ------------------------- import Data.Time as Exports +-- unordered-containers +------------------------- +import Data.HashMap.Strict as Exports (HashMap) + +-- containers +------------------------- +import Data.Map.Strict as Exports (Map) + -- placeholders ------------------------- import Development.Placeholders as Exports diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,7 +1,7 @@ name: postgresql-binary version: - 0.10 + 0.12.1 synopsis: Encoders and decoders for the PostgreSQL's binary format description: @@ -40,14 +40,12 @@ GHC==7.10.1, GHC==8.0.1 - source-repository head type: git location: git://github.com/nikita-volkov/postgresql-binary.git - library hs-source-dirs: library @@ -58,10 +56,11 @@ default-language: Haskell2010 exposed-modules: + PostgreSQL.Binary.Decoding + PostgreSQL.Binary.Encoding PostgreSQL.Binary.Data - PostgreSQL.Binary.Decoder - PostgreSQL.Binary.Encoder other-modules: + PostgreSQL.Binary.Encoding.Builders PostgreSQL.Binary.Prelude PostgreSQL.Binary.Integral PostgreSQL.Binary.Interval @@ -72,6 +71,8 @@ build-depends: -- parsing: binary-parser >= 0.5 && < 0.6, + -- building: + bytestring-strict-builder >= 0.4.2 && < 0.5, -- data: aeson >= 0.9 && < 2, uuid == 1.3.*, @@ -81,16 +82,16 @@ text >= 1 && < 2, vector >= 0.10 && < 0.13, network-ip >= 0.2 && < 1, + unordered-containers == 0.2.*, + containers == 0.5.*, -- errors: loch-th == 0.2.*, placeholders == 0.1.*, -- general: - foldl >= 1.1.1 && < 2, transformers >= 0.3 && < 0.6, base-prelude >= 0.1.19 && < 2, base >= 4.6 && < 5 - -- This test-suite must be executed in a single-thread. test-suite tasty type: @@ -135,7 +136,6 @@ -- general: rerebase >= 1.0.2 && < 2 - benchmark encoding type: exitcode-stdio-1.0 @@ -158,7 +158,6 @@ criterion >= 1.0 && < 1.2, -- general: rerebase < 2 - benchmark decoding type: diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -8,8 +8,8 @@ import qualified Test.Tasty.SmallCheck as SmallCheck import qualified Test.Tasty.QuickCheck as QuickCheck import qualified Test.QuickCheck as QuickCheck -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Encoding as A +import qualified PostgreSQL.Binary.Decoding as B import qualified Data.ByteString as ByteString import qualified Main.DB as DB import qualified Main.Gens as Gens @@ -32,7 +32,7 @@ where jsonb = if version >= 90400 - then [stdRoundtrip "jsonb" Gens.aeson PTI.jsonb Encoder.jsonb_ast Decoder.jsonb_ast] + then [primitiveRoundtrip "jsonb" Gens.aeson PTI.jsonb A.jsonb_ast B.jsonb_ast] else [] other = [ @@ -40,7 +40,7 @@ sql = "select (1, 'a')" decoder _ = - Decoder.composite ((,) <$> Decoder.compositeNonNullValue Decoder.int <*> Decoder.compositeNonNullValue Decoder.char) + B.composite ((,) <$> B.valueComposite B.int <*> B.valueComposite B.char) expected = (1 :: Int64, 'a') in select sql decoder expected @@ -49,27 +49,27 @@ sql = "select (1, null)" decoder _ = - Decoder.composite ((,) <$> Decoder.compositeNonNullValue Decoder.int <*> Decoder.compositeValue Decoder.char) + 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 Decoder.interval_float Decoder.interval_int) + (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 Decoder.interval_float Decoder.interval_int) + (bool B.interval_float B.interval_int) (10 :: DiffTime) , HUnit.testCase "Interval encoder: 10 seconds" $ let pti = PTI.interval - encoder = - (bool Encoder.interval_float Encoder.interval_int) + encoder integerDatetimes = + (bool A.interval_float A.interval_int integerDatetimes) decoder = - (bool Decoder.interval_float Decoder.interval_int) + (bool B.interval_float B.interval_int) value = (10 :: DiffTime) in @@ -77,113 +77,114 @@ IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value , timeRoundtrip "interval" Gens.intervalDiffTime PTI.interval - (bool Encoder.interval_float Encoder.interval_int) - (bool Decoder.interval_float Decoder.interval_int) + (bool A.interval_float A.interval_int) + (bool B.interval_float B.interval_int) , timeRoundtrip "timestamp" (fmap Apx Gens.auto) PTI.timestamp - ((. unApx) . bool Encoder.timestamp_float Encoder.timestamp_int) - (fmap Apx . bool Decoder.timestamp_float Decoder.timestamp_int) + ((. unApx) . bool A.timestamp_float A.timestamp_int) + (fmap Apx . bool B.timestamp_float B.timestamp_int) , HUnit.testCase "timestamptz offset" $ do Right (textual, decoded) <- DB.session $ do integerDatetimes <- DB.integerDatetimes - let encoder = bool Encoder.timestamptz_float Encoder.timestamptz_int integerDatetimes - decoder = bool Decoder.timestamptz_float Decoder.timestamptz_int integerDatetimes + let encoder = bool A.timestamptz_float A.timestamptz_int integerDatetimes + decoder = bool B.timestamptz_float B.timestamptz_int integerDatetimes DB.unit "DROP TABLE IF EXISTS a" [] DB.unit "CREATE TABLE a (b TIMESTAMPTZ)" [] DB.unit "set timezone to 'America/Los_Angeles'" [] let p = (,,) (PTI.oidPQ (PTI.ptiOID PTI.timestamptz)) - (Encoder.run encoder x) + ((A.encodingBytes . encoder) x) (LibPQ.Binary) x = read "2011-09-28 00:17:25" DB.unit "insert into a (b) values ($1)" [Just p] DB.unit "set timezone to 'Europe/Stockholm'" [] textual <- DB.oneRow "SELECT * FROM a" [] LibPQ.Text - decoded <- fmap (Decoder.run decoder) (DB.oneRow "SELECT * FROM a" [] LibPQ.Binary) + 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:25")) decoded , timeRoundtrip "timestamptz" (fmap Apx Gens.auto) PTI.timestamptz - ((. unApx) . bool Encoder.timestamptz_float Encoder.timestamptz_int) - (fmap Apx . bool Decoder.timestamptz_float Decoder.timestamptz_int) + ((. 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 Encoder.timetz_float Encoder.timetz_int) - (fmap Apx . bool Decoder.timetz_float Decoder.timetz_int) + ((. 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 Encoder.time_float Encoder.time_int) - (fmap Apx . bool Decoder.time_float Decoder.time_int) + ((. unApx) . bool A.time_float A.time_int) + (fmap Apx . bool B.time_float B.time_int) , - stdRoundtrip "numeric" Gens.scientific PTI.numeric Encoder.numeric Decoder.numeric + primitiveRoundtrip "numeric" Gens.scientific PTI.numeric A.numeric B.numeric , - select "SELECT -1234560.789 :: numeric" (const Decoder.numeric) (read "-1234560.789") + select "SELECT -1234560.789 :: numeric" (const B.numeric) (read "-1234560.789") , - select "SELECT -0.0789 :: numeric" (const Decoder.numeric) (read "-0.0789") + select "SELECT -0.0789 :: numeric" (const B.numeric) (read "-0.0789") , - select "SELECT 10000 :: numeric" (const Decoder.numeric) (read "10000") + select "SELECT 10000 :: numeric" (const B.numeric) (read "10000") , - stdRoundtrip "float4" Gens.auto PTI.float4 Encoder.float4 Decoder.float4 + primitiveRoundtrip "float4" Gens.auto PTI.float4 A.float4 B.float4 , - stdRoundtrip "float8" Gens.auto PTI.float8 Encoder.float8 Decoder.float8 + primitiveRoundtrip "float8" Gens.auto PTI.float8 A.float8 B.float8 , - stdRoundtrip "char" Gens.char PTI.text Encoder.char Decoder.char + primitiveRoundtrip "char" Gens.char PTI.text A.char_utf8 B.char , - stdRoundtrip "text_strict" Gens.text PTI.text Encoder.text_strict Decoder.text_strict + primitiveRoundtrip "text_strict" Gens.text PTI.text A.text_strict B.text_strict , - stdRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text Encoder.text_lazy Decoder.text_lazy + primitiveRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text A.text_lazy B.text_lazy , - stdRoundtrip "bytea_strict" Gens.auto PTI.bytea Encoder.bytea_strict Decoder.bytea_strict + primitiveRoundtrip "bytea_strict" Gens.auto PTI.bytea A.bytea_strict B.bytea_strict , - stdRoundtrip "bytea_lazy" Gens.auto PTI.bytea Encoder.bytea_lazy Decoder.bytea_lazy + primitiveRoundtrip "bytea_lazy" Gens.auto PTI.bytea A.bytea_lazy B.bytea_lazy , - stdRoundtrip "uuid" Gens.uuid PTI.uuid Encoder.uuid Decoder.uuid + primitiveRoundtrip "uuid" Gens.uuid PTI.uuid A.uuid B.uuid , - stdRoundtrip "inet" Gens.inet PTI.inet Encoder.inet Decoder.inet + primitiveRoundtrip "inet" Gens.inet PTI.inet A.inet B.inet , - stdRoundtrip "int2_int16" Gens.auto PTI.int2 Encoder.int2_int16 Decoder.int + primitiveRoundtrip "int2_int16" Gens.auto PTI.int2 A.int2_int16 B.int , - stdRoundtrip "int2_word16" Gens.auto PTI.int2 Encoder.int2_word16 Decoder.int + primitiveRoundtrip "int2_word16" Gens.auto PTI.int2 A.int2_word16 B.int , - stdRoundtrip "int4_int32" Gens.auto PTI.int4 Encoder.int4_int32 Decoder.int + primitiveRoundtrip "int4_int32" Gens.auto PTI.int4 A.int4_int32 B.int , - stdRoundtrip "int4_word32" Gens.auto PTI.int4 Encoder.int4_word32 Decoder.int + primitiveRoundtrip "int4_word32" Gens.auto PTI.int4 A.int4_word32 B.int , - stdRoundtrip "int8_int64" Gens.auto PTI.int8 Encoder.int8_int64 Decoder.int + primitiveRoundtrip "int8_int64" Gens.auto PTI.int8 A.int8_int64 B.int , - stdRoundtrip "int8_word64" Gens.auto PTI.int8 Encoder.int8_word64 Decoder.int + primitiveRoundtrip "int8_word64" Gens.auto PTI.int8 A.int8_word64 B.int , - stdRoundtrip "bool" Gens.auto PTI.bool Encoder.bool Decoder.bool + primitiveRoundtrip "bool" Gens.auto PTI.bool A.bool B.bool , - stdRoundtrip "date" Gens.auto PTI.date Encoder.date Decoder.date + primitiveRoundtrip "date" Gens.auto PTI.date A.date B.date , let decoder = - Decoder.array $ - Decoder.arrayDimension replicateM $ - Decoder.arrayDimension replicateM $ - Decoder.arrayNonNullValue $ - Decoder.int + 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 = - Encoder.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) $ - Encoder.arrayDimension foldl' $ - Encoder.arrayDimension foldl' $ - Encoder.arrayDimension foldl' $ - Encoder.arrayValue $ - Encoder.int8_int64 + 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 = - Decoder.array $ - Decoder.arrayDimension replicateM $ - Decoder.arrayDimension replicateM $ - Decoder.arrayDimension replicateM $ - Decoder.arrayNonNullValue $ - Decoder.int + B.array $ + B.dimensionArray replicateM $ + B.dimensionArray replicateM $ + B.dimensionArray replicateM $ + B.valueArray $ + B.int in arrayCodec (Gens.array3 Gens.auto) encoder decoder , @@ -191,19 +192,20 @@ pti = PTI.text encoder = - Encoder.array (PTI.oidWord32 (PTI.ptiOID pti)) $ - Encoder.arrayDimension foldl' $ - Encoder.arrayDimension foldl' $ - Encoder.arrayDimension foldl' $ - Encoder.arrayValue $ - Encoder.text_strict + 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 = - Decoder.array $ - Decoder.arrayDimension replicateM $ - Decoder.arrayDimension replicateM $ - Decoder.arrayDimension replicateM $ - Decoder.arrayNonNullValue $ - Decoder.text_strict + 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 ] @@ -211,27 +213,27 @@ textual = testGroup "Textual format" $ [ - test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const Decoder.numeric) + test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const B.numeric) , - test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const Decoder.float4) + test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const B.float4) , - test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const Decoder.float8) + test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const B.float8) , - test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const Decoder.uuid) + test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const B.uuid) , - test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const Decoder.int) + test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const B.int) , - test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const Decoder.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 Decoder.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 Decoder.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 Decoder.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 Decoder.int) + test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const B.int) , - test "bool" Gens.auto PTI.bool TextEncoder.bool (const Decoder.bool) + test "bool" Gens.auto PTI.bool TextEncoder.bool (const B.bool) ] where test typeName gen pti encoder decoder = @@ -241,7 +243,7 @@ arrayCodec gen encoder decoder = QuickCheck.testProperty ("Array codec") $ QuickCheck.forAll gen $ - \value -> (QuickCheck.===) (Right value) (Decoder.run decoder (Encoder.run encoder value)) + \value -> (QuickCheck.===) (Right value) (B.valueParser decoder ((A.encodingBytes . encoder) value)) arrayRoundtrip gen pti encoder decoder = QuickCheck.testProperty ("Array roundtrip") $ @@ -251,9 +253,12 @@ QuickCheck.testProperty (typeName <> " roundtrip") $ QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder +primitiveRoundtrip typeName gen pti encoder decoder = + stdRoundtrip typeName gen pti (encoder) decoder + timeRoundtrip typeName gen pti encoder decoder = QuickCheck.testProperty (typeName <> " roundtrip") $ - QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder + QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) (\x -> encoder x) decoder select statement decoder value = HUnit.testCase (show statement) $ diff --git a/tasty/Main/Gens.hs b/tasty/Main/Gens.hs --- a/tasty/Main/Gens.hs +++ b/tasty/Main/Gens.hs @@ -9,8 +9,7 @@ import qualified Data.UUID as UUID import qualified Data.Vector as Vector import qualified Data.HashMap.Strict as HashMap -import qualified PostgreSQL.Binary.Data as Data -import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified PostgreSQL.Binary.Encoding as Encoder import qualified Data.Text as Text import qualified Data.Aeson as Aeson import qualified Network.IP.Addr as IPAddr @@ -128,34 +127,6 @@ 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) - -arrayRep :: Gen (Word32, Data.Array) -arrayRep = - do - ndims <- choose (1, 4) - dims <- Vector.replicateM ndims dimGen - (valueGen', oid, arrayOID) <- valueGen - values <- Vector.replicateM (dimsToNValues dims) valueGen' - let nulls = Vector.elem Nothing values - return (arrayOID, (dims, values, nulls, oid)) - where - dimGen = - (,) <$> choose (1, 7) <*> pure 1 - valueGen = - do - (pti, gen) <- elements [(PTI.int8, mkGen Encoder.int8_int64), - (PTI.bool, mkGen Encoder.bool), - (PTI.date, mkGen Encoder.date), - (PTI.text, mkGen Encoder.text_strict), - (PTI.bytea, mkGen Encoder.bytea_strict)] - return (gen, PTI.oidWord32 (PTI.ptiOID pti), PTI.oidWord32 (fromJust (PTI.ptiArrayOID pti))) - where - mkGen renderer = - fmap (fmap (convert . renderer)) arbitrary - dimsToNValues = - Vector.product . fmap dimensionWidth - where - dimensionWidth (x, _) = fromIntegral x array3 :: Gen a -> Gen [[[a]]] array3 gen = diff --git a/tasty/Main/IO.hs b/tasty/Main/IO.hs --- a/tasty/Main/IO.hs +++ b/tasty/Main/IO.hs @@ -12,19 +12,18 @@ import qualified Data.UUID as UUID import qualified Data.Vector as Vector import qualified Data.Text.Encoding as Text -import qualified PostgreSQL.Binary.Data as Data -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Encoding as B import qualified Database.PostgreSQL.LibPQ as LibPQ -textRoundtrip :: LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a) +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 $ Decoder.run (decoder integerDatetimes) bytes + return $ A.valueParser (decoder integerDatetimes) bytes where params integerDatetimes = [ Just ( oid , bytes , LibPQ.Text ) ] @@ -32,24 +31,24 @@ bytes = (convert . encoder) value -roundtrip :: LibPQ.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder b) -> a -> IO (Either Text b) +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 $ Decoder.run (decoder integerDatetimes) bytes + return $ A.valueParser (decoder integerDatetimes) bytes where params integerDatetimes = [ Just ( oid , bytes , LibPQ.Binary ) ] where bytes = - (convert . encoder integerDatetimes) value + (B.encodingBytes . encoder integerDatetimes) value -parameterlessStatement :: ByteString -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a) +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 $ Decoder.run (decoder integerDatetimes) bytes + return $ A.valueParser (decoder integerDatetimes) bytes diff --git a/tasty/Main/Properties.hs b/tasty/Main/Properties.hs --- a/tasty/Main/Properties.hs +++ b/tasty/Main/Properties.hs @@ -6,10 +6,9 @@ import qualified Data.Scientific as Scientific import qualified Data.UUID as UUID import qualified Data.Vector as Vector -import qualified PostgreSQL.Binary.Data as Data -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified PostgreSQL.Binary.Decoder as Decoder -import qualified Main.TextEncoder as TextEncoder +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 @@ -17,14 +16,14 @@ roundtrip :: (Show a, Eq a) => - LibPQ.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> Property + LibPQ.Oid -> (Bool -> (a -> B.Encoding)) -> (Bool -> A.Value a) -> a -> Property roundtrip oid encoder decoder value = Right value === unsafePerformIO (IO.roundtrip oid encoder decoder value) -stdRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> Encoder.Encoder a -> Decoder.Decoder a -> a -> Property +stdRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> (a -> B.Encoding) -> A.Value a -> a -> Property stdRoundtrip oid encoder decoder value = roundtrip oid (const encoder) (const decoder) value -textRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> Property +textRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> C.Encoder a -> (Bool -> A.Value a) -> a -> Property textRoundtrip oid encoder decoder value = Right value === unsafePerformIO (IO.textRoundtrip oid encoder decoder value)