module PostgreSQL.Binary.Decoding
  ( valueParser,
    --
    Value,

    -- * Primitive
    int,
    float4,
    float8,
    bool,
    bytea_strict,
    bytea_lazy,

    -- * Textual
    text_strict,
    text_lazy,
    char,

    -- * Misc
    fn,
    numeric,
    uuid,
    inet,
    json_ast,
    json_bytes,
    jsonb_ast,
    jsonb_bytes,

    -- * Time
    date,
    time_int,
    time_float,
    timetz_int,
    timetz_float,
    timestamp_int,
    timestamp_float,
    timestamptz_int,
    timestamptz_float,
    interval_int,
    interval_float,

    -- * Exotic

    -- ** Array
    Array,
    array,
    valueArray,
    nullableValueArray,
    dimensionArray,

    -- ** Composite
    Composite,
    composite,
    valueComposite,
    nullableValueComposite,

    -- ** HStore
    hstore,
    enum,
    refine,
  )
where

import BinaryParser
import qualified Data.Aeson as Aeson
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.Vector as Vector
import qualified Network.IP.Addr as IPAddr
import qualified PostgreSQL.Binary.Inet as Inet
import qualified PostgreSQL.Binary.Integral as Integral
import qualified PostgreSQL.Binary.Interval as Interval
import qualified PostgreSQL.Binary.Numeric as Numeric
import PostgreSQL.Binary.Prelude hiding (bool, drop, fail, failure, state, take)
import qualified PostgreSQL.Binary.Time as Time

type Value =
  BinaryParser

valueParser :: Value a -> ByteString -> Either Text a
valueParser :: forall a. Value a -> ByteString -> Either Text a
valueParser =
  forall a. Value a -> ByteString -> Either Text a
BinaryParser.run

-- * Helpers

-- |
-- Any int number of a limited byte-size.
{-# INLINE intOfSize #-}
intOfSize :: (Integral a, Bits a) => Int -> Value a
intOfSize :: forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
x =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (Bits a, Num a) => ByteString -> a
Integral.pack (Int -> BinaryParser ByteString
bytesOfSize Int
x)

{-# INLINEABLE onContent #-}
onContent :: Value a -> Value (Maybe a)
onContent :: forall a. Value a -> Value (Maybe a)
onContent Value a
decoder =
  Value Int32
size
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (-1) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Int32
n -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. Int -> BinaryParser a -> BinaryParser a
sized (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) Value a
decoder)
  where
    size :: Value Int32
size =
      forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 :: Value Int32

{-# INLINEABLE content #-}
content :: Value (Maybe ByteString)
content :: Value (Maybe ByteString)
content =
  forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (-1) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Int
n -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (Int -> BinaryParser ByteString
bytesOfSize Int
n)

{-# INLINE nonNull #-}
nonNull :: Maybe a -> Value a
nonNull :: forall a. Maybe a -> Value a
nonNull =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") forall (m :: * -> *) a. Monad m => a -> m a
return

-- * Primitive

-- |
-- Lifts a custom decoder implementation.
{-# INLINE fn #-}
fn :: (ByteString -> Either Text a) -> Value a
fn :: forall a. (ByteString -> Either Text a) -> Value a
fn ByteString -> Either Text a
fn =
  BinaryParser ByteString
BinaryParser.remainders forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> BinaryParser a
BinaryParser.failure forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
fn

{-# INLINE int #-}
int :: (Integral a, Bits a) => Value a
int :: forall a. (Integral a, Bits a) => Value a
int =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (Bits a, Num a) => ByteString -> a
Integral.pack BinaryParser ByteString
remainders

float4 :: Value Float
float4 :: Value Float
float4 =
  forall a b. a -> b
unsafeCoerce (forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

float8 :: Value Double
float8 :: Value Double
float8 =
  forall a b. a -> b
unsafeCoerce (forall a. (Integral a, Bits a) => Value a
int :: Value Int64)

{-# INLINE bool #-}
bool :: Value Bool
bool :: Value Bool
bool =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Word8
1) BinaryParser Word8
byte

{-# NOINLINE numeric #-}
numeric :: Value Scientific
numeric :: Value Scientific
numeric =
  do
    Int
componentsAmount <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Int16
pointIndex <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Word16
signCode <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Int -> BinaryParser ()
unitOfSize Int
2
    Vector Word16
components <- forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
componentsAmount (forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> BinaryParser a
failure forall (m :: * -> *) a. Monad m => a -> m a
return (Int16 -> Word16 -> Vector Word16 -> Either Text Scientific
Numeric.scientific Int16
pointIndex Word16
signCode Vector Word16
components)

{-# INLINEABLE uuid #-}
uuid :: Value UUID
uuid :: Value UUID
uuid =
  Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4

{-# INLINE ip4 #-}
ip4 :: Value IPAddr.IP4
ip4 :: Value IP4
ip4 =
  Word8 -> Word8 -> Word8 -> Word8 -> IP4
IPAddr.ip4FromOctets forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1

{-# INLINE ip6 #-}
ip6 :: Value IPAddr.IP6
ip6 :: Value IP6
ip6 =
  Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> IP6
IPAddr.ip6FromWords forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2

{-# INLINEABLE inet #-}
inet :: Value (IPAddr.NetAddr IPAddr.IP)
inet :: Value (NetAddr IP)
inet = do
  Word8
af <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Word8
netmask <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Word8
isCidr <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Int8
ipSize <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  if
      | Word8
af forall a. Eq a => a -> a -> Bool
== Word8
Inet.inetAddressFamily ->
          do
            IP4
ip <- Value IP4
ip4
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
af Word8
netmask Word8
isCidr Int8
ipSize (forall t₄ t₆. t₄ -> IP46 t₄ t₆
IPAddr.IPv4 IP4
ip)
      | Word8
af forall a. Eq a => a -> a -> Bool
== Word8
Inet.inet6AddressFamily ->
          do
            IP6
ip <- Value IP6
ip6
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
af Word8
netmask Word8
isCidr Int8
ipSize (forall t₄ t₆. t₆ -> IP46 t₄ t₆
IPAddr.IPv6 IP6
ip)
      | Bool
otherwise -> forall a. Text -> BinaryParser a
BinaryParser.failure (Text
"Unknown address family: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Word8
af))
  where
    inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IPAddr.IP -> IPAddr.NetAddr IPAddr.IP
    inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
_ Word8
netmask Word8
_ Int8
_ IP
ip = forall n. IsNetAddr n => NetHost n -> Word8 -> n
IPAddr.netAddr IP
ip Word8
netmask

{-# INLINEABLE json_ast #-}
json_ast :: Value Aeson.Value
json_ast :: Value Value
json_ast =
  BinaryParser ByteString
bytea_strict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Text -> BinaryParser a
BinaryParser.failure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. IsString a => String -> a
fromString) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict'

-- |
-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array,
-- produces a decoder.
{-# INLINEABLE json_bytes #-}
json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes :: forall a. (ByteString -> Either Text a) -> Value a
json_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser a
parseJSON
  where
    getAllBytes :: BinaryParser ByteString
getAllBytes =
      BinaryParser ByteString
BinaryParser.remainders
    parseJSON :: ByteString -> BinaryParser a
parseJSON =
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> BinaryParser a
BinaryParser.failure forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
cont

{-# INLINEABLE jsonb_ast #-}
jsonb_ast :: Value Aeson.Value
jsonb_ast :: Value Value
jsonb_ast =
  forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes forall a b. (a -> b) -> a -> b
$ forall a b x. (a -> b) -> Either a x -> Either b x
mapLeft forall a. IsString a => String -> a
fromString forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict'

-- |
-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array,
-- produces a decoder.
--
-- For those wondering, yes,
-- JSONB is encoded as plain JSON string in the binary format of Postgres.
-- Sad, but true.
{-# INLINEABLE jsonb_bytes #-}
jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes :: forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser ByteString
trimBytes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser a
parseJSON
  where
    getAllBytes :: BinaryParser ByteString
getAllBytes =
      BinaryParser ByteString
BinaryParser.remainders
    trimBytes :: ByteString -> BinaryParser ByteString
trimBytes =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> BinaryParser a
BinaryParser.failure Text
"Empty input") forall (m :: * -> *) a. Monad m => a -> m a
return
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Maybe (Word8, ByteString)
ByteString.uncons
    parseJSON :: ByteString -> BinaryParser a
parseJSON =
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> BinaryParser a
BinaryParser.failure forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
cont

-- ** Textual

-- |
-- A UTF-8-decoded char.
{-# INLINEABLE char #-}
char :: Value Char
char :: Value Char
char =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe (Char, Text)
Text.uncons Value Text
text_strict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Char
c, Text
"") -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
    Maybe (Char, Text)
Nothing -> forall a. Text -> BinaryParser a
failure Text
"Empty input"
    Maybe (Char, Text)
_ -> forall a. Text -> BinaryParser a
failure Text
"Consumed too much"

-- |
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINEABLE text_strict #-}
text_strict :: Value Text
text_strict :: Value Text
text_strict =
  do
    ByteString
input <- BinaryParser ByteString
remainders
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Text -> BinaryParser a
failure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {a} {a}. (IsString a, Show a) => a -> UnicodeException -> a
exception ByteString
input) forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
input)
  where
    exception :: a -> UnicodeException -> a
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> forall a. IsString a => String -> a
fromString (String
"Failed to decode the following bytes in UTF-8: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
input)
        UnicodeException
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected unicode exception"

-- |
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINEABLE text_lazy #-}
text_lazy :: Value LazyText
text_lazy :: Value LazyText
text_lazy =
  do
    LazyByteString
input <- Value LazyByteString
bytea_lazy
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Text -> BinaryParser a
failure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {a} {a}. (IsString a, Show a) => a -> UnicodeException -> a
exception LazyByteString
input) forall (m :: * -> *) a. Monad m => a -> m a
return (LazyByteString -> Either UnicodeException LazyText
LazyText.decodeUtf8' LazyByteString
input)
  where
    exception :: a -> UnicodeException -> a
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> forall a. IsString a => String -> a
fromString (String
"Failed to decode the following bytes in UTF-8: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
input)
        UnicodeException
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected unicode exception"

-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_strict #-}
bytea_strict :: Value ByteString
bytea_strict :: BinaryParser ByteString
bytea_strict =
  BinaryParser ByteString
remainders

-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_lazy #-}
bytea_lazy :: Value LazyByteString
bytea_lazy :: Value LazyByteString
bytea_lazy =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> LazyByteString
LazyByteString.fromStrict BinaryParser ByteString
remainders

-- * Date and Time

-- |
-- @DATE@ values decoding.
date :: Value Day
date :: Value Day
date =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Integral a => a -> Day
Time.postgresJulianToDay forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

-- |
-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled.
time_int :: Value TimeOfDay
time_int :: Value TimeOfDay
time_int =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> TimeOfDay
Time.microsToTimeOfDay forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled.
time_float :: Value TimeOfDay
time_float :: Value TimeOfDay
time_float =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> TimeOfDay
Time.secsToTimeOfDay Value Double
float8

-- |
-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled.
timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int =
  (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 Value TimeOfDay
time_int forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value TimeZone
tz

-- |
-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float =
  (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 Value TimeOfDay
time_float forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value TimeZone
tz

{-# INLINE tz #-}
tz :: Value TimeZone
tz :: Value TimeZone
tz =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> TimeZone
minutesToTimeZone forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Num a => a -> a
negate forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Integral a => a -> a -> a
div Int
60) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
timestamp_int :: Value LocalTime
timestamp_int :: Value LocalTime
timestamp_int =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> LocalTime
Time.microsToLocalTime forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timestamp_float :: Value LocalTime
timestamp_float :: Value LocalTime
timestamp_float =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> LocalTime
Time.secsToLocalTime Value Double
float8

-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
timestamptz_int :: Value UTCTime
timestamptz_int :: Value UTCTime
timestamptz_int =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> UTCTime
Time.microsToUTC forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timestamptz_float :: Value UTCTime
timestamptz_float :: Value UTCTime
timestamptz_float =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> UTCTime
Time.secsToUTC Value Double
float8

-- |
-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled.
interval_int :: Value DiffTime
interval_int :: Value DiffTime
interval_int =
  do
    Int64
u <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 forall a. (Integral a, Bits a) => Value a
int
    Int32
d <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 forall a. (Integral a, Bits a) => Value a
int
    Int32
m <- forall a. (Integral a, Bits a) => Value a
int
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Interval -> DiffTime
Interval.toDiffTime forall a b. (a -> b) -> a -> b
$ Int64 -> Int32 -> Int32 -> Interval
Interval.Interval Int64
u Int32
d Int32
m

-- |
-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled.
interval_float :: Value DiffTime
interval_float :: Value DiffTime
interval_float =
  do
    Int64
u <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (RealFrac a, Integral b) => a -> b
round forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall a. Num a => a -> a -> a
* (Rational
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
6)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Real a => a -> Rational
toRational) Value Double
float8)
    Int32
d <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 forall a. (Integral a, Bits a) => Value a
int
    Int32
m <- forall a. (Integral a, Bits a) => Value a
int
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Interval -> DiffTime
Interval.toDiffTime forall a b. (a -> b) -> a -> b
$ Int64 -> Int32 -> Int32 -> Interval
Interval.Interval Int64
u Int32
d Int32
m

-- * Exotic

-- |
-- A function for generic in place parsing of an HStore value.
--
-- Accepts:
--
-- * An implementation of the @replicateM@ function
-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
-- which determines how to produce the final datastructure from the rows.
--
-- * A decoder for keys.
--
-- * A decoder for values.
--
-- Here's how you can use it to produce a parser to list:
--
-- @
-- hstoreAsList :: Value [ ( Text , Maybe Text ) ]
-- hstoreAsList =
--   hstore replicateM text text
-- @
{-# INLINEABLE hstore #-}
hstore :: (forall m. Monad m => Int -> m (k, Maybe v) -> m r) -> Value k -> Value v -> Value r
hstore :: forall k v r.
(forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r)
-> Value k -> Value v -> Value r
hstore forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r
replicateM Value k
keyContent Value v
valueContent =
  do
    Int
componentsAmount <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r
replicateM Int
componentsAmount BinaryParser (k, Maybe v)
component
  where
    component :: BinaryParser (k, Maybe v)
component =
      (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value k
key forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value (Maybe v)
value
      where
        key :: Value k
key =
          forall a. Value a -> Value (Maybe a)
onContent Value k
keyContent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Maybe a -> Value a
nonNull
        value :: Value (Maybe v)
value =
          forall a. Value a -> Value (Maybe a)
onContent Value v
valueContent

-- * Composite

newtype Composite a
  = Composite (Value a)
  deriving (forall a b. a -> Composite b -> Composite a
forall a b. (a -> b) -> Composite a -> Composite b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Composite b -> Composite a
$c<$ :: forall a b. a -> Composite b -> Composite a
fmap :: forall a b. (a -> b) -> Composite a -> Composite b
$cfmap :: forall a b. (a -> b) -> Composite a -> Composite b
Functor, Functor Composite
forall a. a -> Composite a
forall a b. Composite a -> Composite b -> Composite a
forall a b. Composite a -> Composite b -> Composite b
forall a b. Composite (a -> b) -> Composite a -> Composite b
forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Composite a -> Composite b -> Composite a
$c<* :: forall a b. Composite a -> Composite b -> Composite a
*> :: forall a b. Composite a -> Composite b -> Composite b
$c*> :: forall a b. Composite a -> Composite b -> Composite b
liftA2 :: forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
<*> :: forall a b. Composite (a -> b) -> Composite a -> Composite b
$c<*> :: forall a b. Composite (a -> b) -> Composite a -> Composite b
pure :: forall a. a -> Composite a
$cpure :: forall a. a -> Composite a
Applicative, Applicative Composite
forall a. a -> Composite a
forall a b. Composite a -> Composite b -> Composite b
forall a b. Composite a -> (a -> Composite b) -> Composite b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Composite a
$creturn :: forall a. a -> Composite a
>> :: forall a b. Composite a -> Composite b -> Composite b
$c>> :: forall a b. Composite a -> Composite b -> Composite b
>>= :: forall a b. Composite a -> (a -> Composite b) -> Composite b
$c>>= :: forall a b. Composite a -> (a -> Composite b) -> Composite b
Monad, Monad Composite
forall a. String -> Composite a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> Composite a
$cfail :: forall a. String -> Composite a
MonadFail)

-- |
-- Unlift a 'Composite' to a value 'Value'.
{-# INLINE composite #-}
composite :: Composite a -> Value a
composite :: forall a. Composite a -> Value a
composite (Composite Value a
decoder) =
  BinaryParser ()
numOfComponents forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value a
decoder
  where
    numOfComponents :: BinaryParser ()
numOfComponents =
      Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- Lift a value 'Value' into 'Composite'.
{-# INLINE nullableValueComposite #-}
nullableValueComposite :: Value a -> Composite (Maybe a)
nullableValueComposite :: forall a. Value a -> Composite (Maybe a)
nullableValueComposite Value a
valueValue =
  forall a. Value a -> Composite a
Composite (BinaryParser ()
skipOid forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Value a -> Value (Maybe a)
onContent Value a
valueValue)
  where
    skipOid :: BinaryParser ()
skipOid =
      Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- Lift a non-nullable value 'Value' into 'Composite'.
{-# INLINE valueComposite #-}
valueComposite :: Value a -> Composite a
valueComposite :: forall a. Value a -> Composite a
valueComposite Value a
valueValue =
  forall a. Value a -> Composite a
Composite (BinaryParser ()
skipOid forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Value a -> Value (Maybe a)
onContent Value a
valueValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") forall (m :: * -> *) a. Monad m => a -> m a
return)
  where
    skipOid :: BinaryParser ()
skipOid =
      Int -> BinaryParser ()
unitOfSize Int
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 (forall a b. a -> Array b -> Array a
forall a b. (a -> b) -> Array a -> Array b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Array b -> Array a
$c<$ :: forall a b. a -> Array b -> Array a
fmap :: forall a b. (a -> b) -> Array a -> Array b
$cfmap :: forall a b. (a -> b) -> Array a -> Array b
Functor)

-- |
-- Unlift an 'Array' to a value 'Value'.
{-# INLINE array #-}
array :: Array a -> Value a
array :: forall a. Array a -> Value a
array (Array [Word32] -> Value a
decoder) =
  do
    Int
dimensionsAmount <- forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    if Int
dimensionsAmount forall a. Eq a => a -> a -> Bool
/= Int
0
      then do
        Int -> BinaryParser ()
unitOfSize (Int
4 forall a. Num a => a -> a -> a
+ Int
4)
        [Word32]
dimensionSizes <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
dimensionsAmount forall a. (Integral a, Bits a) => Value a
dimensionSize
        [Word32] -> Value a
decoder [Word32]
dimensionSizes
      else [Word32] -> Value a
decoder [Word32
0]
  where
    dimensionSize :: BinaryParser a
dimensionSize =
      forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> BinaryParser ()
unitOfSize Int
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 :: forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall (m :: * -> *). Monad m => Int -> m a -> m b
replicateM (Array [Word32] -> Value a
component) =
  forall a. ([Word32] -> Value a) -> Array a
Array forall a b. (a -> b) -> a -> b
$ \case
    Word32
head : [Word32]
tail -> forall (m :: * -> *). Monad m => Int -> m a -> m b
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
head) ([Word32] -> Value a
component [Word32]
tail)
    [Word32]
_ -> forall a. Text -> BinaryParser a
failure Text
"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 :: forall a. Value a -> Array (Maybe a)
nullableValueArray =
  forall a. ([Word32] -> Value a) -> Array a
Array forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Value a -> Value (Maybe a)
onContent

-- |
-- Lift a value 'Value' into 'Array' for parsing of non-nullable leaf values.
{-# INLINE valueArray #-}
valueArray :: Value a -> Array a
valueArray :: forall a. Value a -> Array a
valueArray =
  forall a. ([Word32] -> Value a) -> Array a
Array forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") forall (m :: * -> *) a. Monad m => a -> m a
return) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Value a -> Value (Maybe a)
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 :: forall a. (Text -> Maybe a) -> Value a
enum Text -> Maybe a
mapping =
  Value Text
text_strict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> BinaryParser a
onText
  where
    onText :: Text -> BinaryParser a
onText Text
text =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinaryParser a
onNothing forall {f :: * -> *} {a}. Applicative f => a -> f a
onJust (Text -> Maybe a
mapping Text
text)
      where
        onNothing :: BinaryParser a
onNothing =
          forall a. Text -> BinaryParser a
failure (Text
"No mapping for text \"" forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
"\"")
        onJust :: a -> f a
onJust =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- * Refining values

-- | Given additional constraints when
-- using an existing value decoder, produces
-- a decoder of that value.
{-# INLINE refine #-}
refine :: (a -> Either Text b) -> Value a -> Value b
refine :: forall a b. (a -> Either Text b) -> Value a -> Value b
refine a -> Either Text b
fn Value a
m = Value a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> BinaryParser a
failure forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Either Text b
fn)