packages feed

postgresql-binary 0.10 → 0.12.1

raw patch · 15 files changed

+1534/−1410 lines, 15 filesdep +bytestring-strict-builderdep +containersdep +unordered-containersdep −foldl

Dependencies added: bytestring-strict-builder, containers, unordered-containers

Dependencies removed: foldl

Files

decoding/Main.hs view
@@ -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
encoding/Main.hs view
@@ -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
library/PostgreSQL/Binary/Data.hs view
@@ -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)
− library/PostgreSQL/Binary/Decoder.hs 
@@ -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
+ library/PostgreSQL/Binary/Decoding.hs view
@@ -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
− library/PostgreSQL/Binary/Encoder.hs 
@@ -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
+ library/PostgreSQL/Binary/Encoding.hs view
@@ -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
+ library/PostgreSQL/Binary/Encoding/Builders.hs view
@@ -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
library/PostgreSQL/Binary/Numeric.hs view
@@ -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
library/PostgreSQL/Binary/Prelude.hs view
@@ -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
postgresql-binary.cabal view
@@ -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:
tasty/Main.hs view
@@ -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) $
tasty/Main/Gens.hs view
@@ -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 =
tasty/Main/IO.hs view
@@ -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
tasty/Main/Properties.hs view
@@ -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)