module Hpgsql.Types
  ( Only (..),
    Aeson (..),
    PgJson, -- Do not export ctor
    PGArray (..),
    (:.) (..),
    pgJsonByteString,
  )
where

import Control.Monad (replicateM)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as AesonInternal
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Tuple.Only (Only (..))
import Data.Typeable (Proxy (..), Typeable)
import Hpgsql.Builder (BinaryField (..))
import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField)
import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid)

-- | Encodes a Haskell list as a postgres array. You can also use `Vector` if you prefer.
-- The reason for this type instead of allowing @[a]@ to be a field is that an instance
-- for @[a]@ would require an overlappable instance for @String@, and that is not ideal.
newtype PGArray a = PGArray {forall a. PGArray a -> [a]
fromPGArray :: [a]}
  deriving (PGArray a -> PGArray a -> Bool
(PGArray a -> PGArray a -> Bool)
-> (PGArray a -> PGArray a -> Bool) -> Eq (PGArray a)
forall a. Eq a => PGArray a -> PGArray a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PGArray a -> PGArray a -> Bool
== :: PGArray a -> PGArray a -> Bool
$c/= :: forall a. Eq a => PGArray a -> PGArray a -> Bool
/= :: PGArray a -> PGArray a -> Bool
Eq, Eq (PGArray a)
Eq (PGArray a) =>
(PGArray a -> PGArray a -> Ordering)
-> (PGArray a -> PGArray a -> Bool)
-> (PGArray a -> PGArray a -> Bool)
-> (PGArray a -> PGArray a -> Bool)
-> (PGArray a -> PGArray a -> Bool)
-> (PGArray a -> PGArray a -> PGArray a)
-> (PGArray a -> PGArray a -> PGArray a)
-> Ord (PGArray a)
PGArray a -> PGArray a -> Bool
PGArray a -> PGArray a -> Ordering
PGArray a -> PGArray a -> PGArray a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PGArray a)
forall a. Ord a => PGArray a -> PGArray a -> Bool
forall a. Ord a => PGArray a -> PGArray a -> Ordering
forall a. Ord a => PGArray a -> PGArray a -> PGArray a
$ccompare :: forall a. Ord a => PGArray a -> PGArray a -> Ordering
compare :: PGArray a -> PGArray a -> Ordering
$c< :: forall a. Ord a => PGArray a -> PGArray a -> Bool
< :: PGArray a -> PGArray a -> Bool
$c<= :: forall a. Ord a => PGArray a -> PGArray a -> Bool
<= :: PGArray a -> PGArray a -> Bool
$c> :: forall a. Ord a => PGArray a -> PGArray a -> Bool
> :: PGArray a -> PGArray a -> Bool
$c>= :: forall a. Ord a => PGArray a -> PGArray a -> Bool
>= :: PGArray a -> PGArray a -> Bool
$cmax :: forall a. Ord a => PGArray a -> PGArray a -> PGArray a
max :: PGArray a -> PGArray a -> PGArray a
$cmin :: forall a. Ord a => PGArray a -> PGArray a -> PGArray a
min :: PGArray a -> PGArray a -> PGArray a
Ord, ReadPrec [PGArray a]
ReadPrec (PGArray a)
Int -> ReadS (PGArray a)
ReadS [PGArray a]
(Int -> ReadS (PGArray a))
-> ReadS [PGArray a]
-> ReadPrec (PGArray a)
-> ReadPrec [PGArray a]
-> Read (PGArray a)
forall a. Read a => ReadPrec [PGArray a]
forall a. Read a => ReadPrec (PGArray a)
forall a. Read a => Int -> ReadS (PGArray a)
forall a. Read a => ReadS [PGArray a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (PGArray a)
readsPrec :: Int -> ReadS (PGArray a)
$creadList :: forall a. Read a => ReadS [PGArray a]
readList :: ReadS [PGArray a]
$creadPrec :: forall a. Read a => ReadPrec (PGArray a)
readPrec :: ReadPrec (PGArray a)
$creadListPrec :: forall a. Read a => ReadPrec [PGArray a]
readListPrec :: ReadPrec [PGArray a]
Read, Int -> PGArray a -> ShowS
[PGArray a] -> ShowS
PGArray a -> String
(Int -> PGArray a -> ShowS)
-> (PGArray a -> String)
-> ([PGArray a] -> ShowS)
-> Show (PGArray a)
forall a. Show a => Int -> PGArray a -> ShowS
forall a. Show a => [PGArray a] -> ShowS
forall a. Show a => PGArray a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PGArray a -> ShowS
showsPrec :: Int -> PGArray a -> ShowS
$cshow :: forall a. Show a => PGArray a -> String
show :: PGArray a -> String
$cshowList :: forall a. Show a => [PGArray a] -> ShowS
showList :: [PGArray a] -> ShowS
Show, (forall a b. (a -> b) -> PGArray a -> PGArray b)
-> (forall a b. a -> PGArray b -> PGArray a) -> Functor PGArray
forall a b. a -> PGArray b -> PGArray a
forall a b. (a -> b) -> PGArray a -> PGArray b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PGArray a -> PGArray b
fmap :: forall a b. (a -> b) -> PGArray a -> PGArray b
$c<$ :: forall a b. a -> PGArray b -> PGArray a
<$ :: forall a b. a -> PGArray b -> PGArray a
Functor)

instance forall a. (ToPgField a) => ToPgField (PGArray a) where
  fieldEncoder :: FieldEncoder (PGArray a)
fieldEncoder =
    let fe :: FieldEncoder a
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @a
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
encodingContext -> do
              elOid <- FieldEncoder a
fe.toTypeOid EncodingContext
encodingContext
              arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache
              arrayTypInfo.oidOfArrayType,
            toPgField :: EncodingContext -> PGArray a -> BinaryField
toPgField = \EncodingContext
encCtx -> EncodingContext -> [a] -> BinaryField
forall (f :: * -> *) a.
(Foldable f, ToPgField a) =>
EncodingContext -> f a -> BinaryField
toPgVectorField EncodingContext
encCtx ([a] -> BinaryField)
-> (PGArray a -> [a]) -> PGArray a -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGArray a -> [a]
forall a. PGArray a -> [a]
fromPGArray
          }

instance forall a. (FromPgField a) => FromPgField (PGArray a) where
  fieldDecoder :: FieldDecoder (PGArray a)
fieldDecoder = [a] -> PGArray a
forall a. [a] -> PGArray a
PGArray ([a] -> PGArray a) -> FieldDecoder [a] -> FieldDecoder (PGArray a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). Monad m => Int -> m a -> m [a])
-> FieldDecoder a -> FieldDecoder [a]
forall a (f :: * -> *).
Monoid (f a) =>
(forall (m :: * -> *). Monad m => Int -> m a -> m (f a))
-> FieldDecoder a -> FieldDecoder (f a)
arrayField Int -> m a -> m [a]
forall (m :: * -> *). Monad m => Int -> m a -> m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder

-- | A way to compose two rows.
data h :. t = !h :. !t deriving ((h :. t) -> (h :. t) -> Bool
((h :. t) -> (h :. t) -> Bool)
-> ((h :. t) -> (h :. t) -> Bool) -> Eq (h :. t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall h t. (Eq h, Eq t) => (h :. t) -> (h :. t) -> Bool
$c== :: forall h t. (Eq h, Eq t) => (h :. t) -> (h :. t) -> Bool
== :: (h :. t) -> (h :. t) -> Bool
$c/= :: forall h t. (Eq h, Eq t) => (h :. t) -> (h :. t) -> Bool
/= :: (h :. t) -> (h :. t) -> Bool
Eq, Eq (h :. t)
Eq (h :. t) =>
((h :. t) -> (h :. t) -> Ordering)
-> ((h :. t) -> (h :. t) -> Bool)
-> ((h :. t) -> (h :. t) -> Bool)
-> ((h :. t) -> (h :. t) -> Bool)
-> ((h :. t) -> (h :. t) -> Bool)
-> ((h :. t) -> (h :. t) -> h :. t)
-> ((h :. t) -> (h :. t) -> h :. t)
-> Ord (h :. t)
(h :. t) -> (h :. t) -> Bool
(h :. t) -> (h :. t) -> Ordering
(h :. t) -> (h :. t) -> h :. t
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall h t. (Ord h, Ord t) => Eq (h :. t)
forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Bool
forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Ordering
forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> h :. t
$ccompare :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Ordering
compare :: (h :. t) -> (h :. t) -> Ordering
$c< :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Bool
< :: (h :. t) -> (h :. t) -> Bool
$c<= :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Bool
<= :: (h :. t) -> (h :. t) -> Bool
$c> :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Bool
> :: (h :. t) -> (h :. t) -> Bool
$c>= :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> Bool
>= :: (h :. t) -> (h :. t) -> Bool
$cmax :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> h :. t
max :: (h :. t) -> (h :. t) -> h :. t
$cmin :: forall h t. (Ord h, Ord t) => (h :. t) -> (h :. t) -> h :. t
min :: (h :. t) -> (h :. t) -> h :. t
Ord, Int -> (h :. t) -> ShowS
[h :. t] -> ShowS
(h :. t) -> String
(Int -> (h :. t) -> ShowS)
-> ((h :. t) -> String) -> ([h :. t] -> ShowS) -> Show (h :. t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall h t. (Show h, Show t) => Int -> (h :. t) -> ShowS
forall h t. (Show h, Show t) => [h :. t] -> ShowS
forall h t. (Show h, Show t) => (h :. t) -> String
$cshowsPrec :: forall h t. (Show h, Show t) => Int -> (h :. t) -> ShowS
showsPrec :: Int -> (h :. t) -> ShowS
$cshow :: forall h t. (Show h, Show t) => (h :. t) -> String
show :: (h :. t) -> String
$cshowList :: forall h t. (Show h, Show t) => [h :. t] -> ShowS
showList :: [h :. t] -> ShowS
Show, ReadPrec [h :. t]
ReadPrec (h :. t)
Int -> ReadS (h :. t)
ReadS [h :. t]
(Int -> ReadS (h :. t))
-> ReadS [h :. t]
-> ReadPrec (h :. t)
-> ReadPrec [h :. t]
-> Read (h :. t)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall h t. (Read h, Read t) => ReadPrec [h :. t]
forall h t. (Read h, Read t) => ReadPrec (h :. t)
forall h t. (Read h, Read t) => Int -> ReadS (h :. t)
forall h t. (Read h, Read t) => ReadS [h :. t]
$creadsPrec :: forall h t. (Read h, Read t) => Int -> ReadS (h :. t)
readsPrec :: Int -> ReadS (h :. t)
$creadList :: forall h t. (Read h, Read t) => ReadS [h :. t]
readList :: ReadS [h :. t]
$creadPrec :: forall h t. (Read h, Read t) => ReadPrec (h :. t)
readPrec :: ReadPrec (h :. t)
$creadListPrec :: forall h t. (Read h, Read t) => ReadPrec [h :. t]
readListPrec :: ReadPrec [h :. t]
Read)

infixr 3 :.

instance forall a b. (ToPgRow a, ToPgRow b) => ToPgRow (a :. b) where
  rowEncoder :: RowEncoder (a :. b)
rowEncoder =
    let !re1 :: RowEncoder a
re1 = forall a. ToPgRow a => RowEncoder a
rowEncoder @a
        !re2 :: RowEncoder b
re2 = forall a. ToPgRow a => RowEncoder a
rowEncoder @b
     in RowEncoder
          { toPgParams :: (a :. b) -> [EncodingContext -> (Maybe Oid, BinaryField)]
toPgParams = \(a
a :. b
b) -> RowEncoder a
re1.toPgParams a
a [EncodingContext -> (Maybe Oid, BinaryField)]
-> [EncodingContext -> (Maybe Oid, BinaryField)]
-> [EncodingContext -> (Maybe Oid, BinaryField)]
forall a. [a] -> [a] -> [a]
++ RowEncoder b
re2.toPgParams b
b,
            toTypeOids :: Proxy (a :. b) -> [EncodingContext -> Maybe Oid]
toTypeOids = \Proxy (a :. b)
_ -> RowEncoder a
re1.toTypeOids (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) [EncodingContext -> Maybe Oid]
-> [EncodingContext -> Maybe Oid] -> [EncodingContext -> Maybe Oid]
forall a. [a] -> [a] -> [a]
++ RowEncoder b
re2.toTypeOids (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b),
            toBinaryCopyBytes :: EncodingContext -> (a :. b) -> Builder
toBinaryCopyBytes = \EncodingContext
encCtx ->
              let !toBytes1 :: a -> Builder
toBytes1 = RowEncoder a
re1.toBinaryCopyBytes EncodingContext
encCtx
                  !toBytes2 :: b -> Builder
toBytes2 = RowEncoder b
re2.toBinaryCopyBytes EncodingContext
encCtx
               in \(a
a :. b
b) -> a -> Builder
toBytes1 a
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> b -> Builder
toBytes2 b
b
          }

instance (FromPgRow a, FromPgRow b) => FromPgRow (a :. b) where
  rowDecoder :: RowDecoder (a :. b)
rowDecoder = a -> b -> a :. b
forall h t. h -> t -> h :. t
(:.) (a -> b -> a :. b) -> RowDecoder a -> RowDecoder (b -> a :. b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowDecoder a
forall a. FromPgRow a => RowDecoder a
rowDecoder RowDecoder (b -> a :. b) -> RowDecoder b -> RowDecoder (a :. b)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowDecoder b
forall a. FromPgRow a => RowDecoder a
rowDecoder

-- | A JSON type that does not incur the costs of deserializing
-- in its `FromPgField` instance because it assumes postgres only generates
-- valid JSON. Useful for extra performance if its opaqueness is not a problem.
-- Although it does have a `toJSON` method, using it will incur a
-- deserialization cost, so if you find yourself using that too much consider just using
-- `Aeson.Value` or the `Aeson` newtype instead of this.
newtype PgJson = PgJson ByteString

instance ToJSON PgJson where
  toJSON :: PgJson -> Value
toJSON (PgJson ByteString
bs) = case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
bs of
    Left String
err -> String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"Bug in Hpgsql. PgJson not valid JSON: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
    Right Value
v -> Value
v

  toEncoding :: PgJson -> Encoding
toEncoding (PgJson ByteString
bs) = Builder -> Encoding
forall a. Builder -> Encoding' a
AesonInternal.unsafeToEncoding (ByteString -> Builder
Builder.byteString ByteString
bs)

-- | A valid UTF8 representation of the JSON value.
pgJsonByteString :: PgJson -> ByteString
pgJsonByteString :: PgJson -> ByteString
pgJsonByteString (PgJson ByteString
bs) = ByteString
bs

instance FromPgField PgJson where
  fieldDecoder :: FieldDecoder PgJson
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String PgJson
fieldValueDecoder =
          \FieldInfo {Oid
fieldTypeOid :: Oid
fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid} ->
            let
              -- jsonb has a byte prepended to the contents and json does not
              !fixJsonb :: ByteString -> ByteString
fixJsonb = if Oid
fieldTypeOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
jsonbOid then Int -> ByteString -> ByteString
BS.drop Int
1 else ByteString -> ByteString
forall a. a -> a
Prelude.id
             in
              \case
                Just ByteString
bs -> PgJson -> Either String PgJson
forall a b. b -> Either a b
Right (PgJson -> Either String PgJson) -> PgJson -> Either String PgJson
forall a b. (a -> b) -> a -> b
$ ByteString -> PgJson
PgJson (ByteString -> PgJson) -> ByteString -> PgJson
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fixJsonb ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String PgJson
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
jsonOid, Oid
jsonbOid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

-- | A newtype wrapper to decode a JSON value with Aeson
-- into your type (from either json or jsonb), and to encode
-- to jsonb.
newtype Aeson a = Aeson {forall a. Aeson a -> a
getAeson :: a}
  deriving (Aeson a -> Aeson a -> Bool
(Aeson a -> Aeson a -> Bool)
-> (Aeson a -> Aeson a -> Bool) -> Eq (Aeson a)
forall a. Eq a => Aeson a -> Aeson a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Aeson a -> Aeson a -> Bool
== :: Aeson a -> Aeson a -> Bool
$c/= :: forall a. Eq a => Aeson a -> Aeson a -> Bool
/= :: Aeson a -> Aeson a -> Bool
Eq, Int -> Aeson a -> ShowS
[Aeson a] -> ShowS
Aeson a -> String
(Int -> Aeson a -> ShowS)
-> (Aeson a -> String) -> ([Aeson a] -> ShowS) -> Show (Aeson a)
forall a. Show a => Int -> Aeson a -> ShowS
forall a. Show a => [Aeson a] -> ShowS
forall a. Show a => Aeson a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Aeson a -> ShowS
showsPrec :: Int -> Aeson a -> ShowS
$cshow :: forall a. Show a => Aeson a -> String
show :: Aeson a -> String
$cshowList :: forall a. Show a => [Aeson a] -> ShowS
showList :: [Aeson a] -> ShowS
Show, ReadPrec [Aeson a]
ReadPrec (Aeson a)
Int -> ReadS (Aeson a)
ReadS [Aeson a]
(Int -> ReadS (Aeson a))
-> ReadS [Aeson a]
-> ReadPrec (Aeson a)
-> ReadPrec [Aeson a]
-> Read (Aeson a)
forall a. Read a => ReadPrec [Aeson a]
forall a. Read a => ReadPrec (Aeson a)
forall a. Read a => Int -> ReadS (Aeson a)
forall a. Read a => ReadS [Aeson a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Aeson a)
readsPrec :: Int -> ReadS (Aeson a)
$creadList :: forall a. Read a => ReadS [Aeson a]
readList :: ReadS [Aeson a]
$creadPrec :: forall a. Read a => ReadPrec (Aeson a)
readPrec :: ReadPrec (Aeson a)
$creadListPrec :: forall a. Read a => ReadPrec [Aeson a]
readListPrec :: ReadPrec [Aeson a]
Read, Typeable, (forall a b. (a -> b) -> Aeson a -> Aeson b)
-> (forall a b. a -> Aeson b -> Aeson a) -> Functor Aeson
forall a b. a -> Aeson b -> Aeson a
forall a b. (a -> b) -> Aeson a -> Aeson b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Aeson a -> Aeson b
fmap :: forall a b. (a -> b) -> Aeson a -> Aeson b
$c<$ :: forall a b. a -> Aeson b -> Aeson a
<$ :: forall a b. a -> Aeson b -> Aeson a
Functor)

instance (FromJSON a) => FromPgField (Aeson a) where
  fieldDecoder :: FieldDecoder (Aeson a)
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (Aeson a)
fieldValueDecoder =
          \FieldInfo {Oid
fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid :: Oid
fieldTypeOid} ->
            let
              -- jsonb has a byte prepended to the contents and json does not
              !fixJsonb :: ByteString -> ByteString
fixJsonb = if Oid
fieldTypeOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
jsonbOid then Int -> ByteString -> ByteString
BS.drop Int
1 else ByteString -> ByteString
forall a. a -> a
Prelude.id
             in
              \case
                Just ByteString
bs -> case ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (ByteString -> Maybe a) -> ByteString -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fixJsonb ByteString
bs of
                  Just a
v -> Aeson a -> Either String (Aeson a)
forall a b. b -> Either a b
Right (Aeson a -> Either String (Aeson a))
-> Aeson a -> Either String (Aeson a)
forall a b. (a -> b) -> a -> b
$ a -> Aeson a
forall a. a -> Aeson a
Aeson a
v
                  Maybe a
Nothing -> String -> Either String (Aeson a)
forall a b. a -> Either a b
Left String
"Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?"
                Maybe ByteString
Nothing -> String -> Either String (Aeson a)
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
jsonOid, Oid
jsonbOid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance (ToJSON a) => ToPgField (Aeson a) where
  fieldEncoder :: FieldEncoder (Aeson a)
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
jsonbOid,
        toPgField :: EncodingContext -> Aeson a -> BinaryField
toPgField = \EncodingContext
_ (Aeson a
v) ->
          ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> ByteString
BS.cons Word8
1 (LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode a
v)
      }