{-# LANGUAGE
AllowAmbiguousTypes
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveTraversable
, DefaultSignatures
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, LambdaCase
, OverloadedStrings
, MultiParamTypeClasses
, ScopedTypeVariables
, TypeApplications
, TypeInType
, TypeOperators
, UndecidableInstances
#-}
module Squeal.PostgreSQL.Binary
(
ToParam (..)
, ToParams (..)
, FromValue (..)
, FromRow (..)
, Only (..)
) where
import BinaryParser
import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
import Control.Arrow (left)
import Control.Monad
import Data.Int
import Data.Kind
import Data.Scientific
import Data.Time
import Data.UUID.Types
import Data.Vector (Vector)
import Data.Word
import Generics.SOP
import Generics.SOP.Record
import GHC.TypeLits
import Network.IP.Addr
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text as Strict (Text)
import qualified Data.Text as Strict.Text
import qualified Data.Vector as Vector
import qualified GHC.Generics as GHC
import qualified PostgreSQL.Binary.Decoding as Decoding
import qualified PostgreSQL.Binary.Encoding as Encoding
import Squeal.PostgreSQL.Schema
class ToParam (x :: Type) (pg :: PGType) where
toParam :: x -> K Encoding.Encoding pg
instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy
instance ToParam String 'PGtext where
toParam = K . Encoding.text_strict . Strict.Text.pack
instance ToParam Strict.ByteString 'PGbytea where
toParam = K . Encoding.bytea_strict
instance ToParam Lazy.ByteString 'PGbytea where
toParam = K . Encoding.bytea_lazy
instance ToParam Day 'PGdate where toParam = K . Encoding.date
instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int
instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where
toParam = K . Encoding.timetz_int
instance ToParam LocalTime 'PGtimestamp where
toParam = K . Encoding.timestamp_int
instance ToParam UTCTime 'PGtimestamptz where
toParam = K . Encoding.timestamptz_int
instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast
instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
toParam = K . Encoding.json_bytes
. Lazy.ByteString.toStrict . Aeson.encode . getJson
instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
toParam = K . Encoding.jsonb_bytes
. Lazy.ByteString.toStrict . Aeson.encode . getJsonb
instance ToArray x ('NotNull ('PGvararray ty))
=> ToParam x ('PGvararray ty) where
toParam
= K . Encoding.array (baseOid @x @('NotNull ('PGvararray ty)))
. unK . toArray @x @('NotNull ('PGvararray ty))
instance ToArray x ('NotNull ('PGfixarray n ty))
=> ToParam x ('PGfixarray n ty) where
toParam
= K . Encoding.array (baseOid @x @('NotNull ('PGfixarray n ty)))
. unK . toArray @x @('NotNull ('PGfixarray n ty))
instance
( IsEnumType x
, HasDatatypeInfo x
, LabelsPG x ~ labels
) => ToParam (Enumerated x) ('PGenum labels) where
toParam =
let
gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String
gshowConstructor Nil _ = ""
gshowConstructor (constructor :* _) (SOP (Z _)) =
constructorName constructor
gshowConstructor (_ :* constructors) (SOP (S xs)) =
gshowConstructor constructors (SOP xs)
in
K . Encoding.text_strict
. Strict.Text.pack
. gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))
. from
. getEnumerated
instance
( SListI fields
, IsRecord x xs
, AllZip ToField xs fields
, All HasAliasedOid fields
) => ToParam (Composite x) ('PGcomposite fields) where
toParam =
let
encoders = htrans (Proxy @ToField) toField
composite
:: All HasAliasedOid row
=> NP (K (Maybe Encoding.Encoding)) row
-> K Encoding.Encoding ('PGcomposite row)
composite fields = K $
int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
let
each
:: HasAliasedOid field
=> K (Maybe Encoding.Encoding) field
-> Encoding.Encoding
each (K field :: K (Maybe Encoding.Encoding) field) =
word32BE (aliasedOid @field)
<> case field of
Nothing -> int64BE (-1)
Just value ->
int32BE (fromIntegral (builderLength value))
<> value
in
hcfoldMap (Proxy @HasAliasedOid) each fields
in
composite . encoders . toRecord . getComposite
class HasAliasedOid (field :: (Symbol, NullityType)) where
aliasedOid :: Word32
instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
aliasedOid = oid @ty
class ToNullityParam (x :: Type) (ty :: NullityType) where
toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
instance ToParam x pg => ToNullityParam x ('NotNull pg) where
toNullityParam = K . Just . unK . toParam @x @pg
instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
toNullityParam = K . fmap (unK . toParam @x @pg)
class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
toField :: P x -> K (Maybe Encoding.Encoding) field
instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
toField (P x) = K . unK $ toNullityParam @x @ty x
class ToArray (x :: Type) (array :: NullityType) where
toArray :: x -> K Encoding.Array array
baseOid :: Word32
default baseOid :: HasOid (PGTypeOf array) => Word32
baseOid = oid @(PGTypeOf array)
instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)
=> ToArray x ('NotNull pg) where
toArray = K . Encoding.encodingArray . unK . toParam @x @pg
instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)
=> ToArray (Maybe x) ('Null pg) where
toArray = K . maybe Encoding.nullArray
(Encoding.encodingArray . unK . toParam @x @pg)
instance {-# OVERLAPPING #-} ToArray x array
=> ToArray (Vector x) ('NotNull ('PGvararray array)) where
toArray = K . Encoding.dimensionArray Vector.foldl'
(unK . toArray @x @array)
baseOid = baseOid @x @array
instance {-# OVERLAPPING #-} ToArray x array
=> ToArray (Maybe (Vector x)) ('Null ('PGvararray array)) where
toArray = K . maybe Encoding.nullArray
(Encoding.dimensionArray Vector.foldl' (unK . toArray @x @array))
baseOid = baseOid @x @array
instance {-# OVERLAPPING #-}
( IsProductType product xs
, Length xs ~ n
, All ((~) x) xs
, ToArray x array )
=> ToArray product ('NotNull ('PGfixarray n array)) where
toArray = K . Encoding.dimensionArray foldlN
(unK . toArray @x @array) . unZ . unSOP . from
baseOid = baseOid @x @array
instance {-# OVERLAPPING #-}
( IsProductType product xs
, Length xs ~ n
, All ((~) x) xs
, ToArray x array )
=> ToArray (Maybe product) ('Null ('PGfixarray n array)) where
toArray = K . maybe Encoding.nullArray
(Encoding.dimensionArray foldlN (unK . toArray @x @array) . unZ . unSOP . from)
baseOid = baseOid @x @array
class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys
instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)
=> ToParams x tys where
toParams
= htrans (Proxy @ToNullityParam) (toNullityParam . unI)
. unZ . unSOP . from
class FromValue (pg :: PGType) (y :: Type) where
fromValue :: Decoding.Value y
instance FromValue 'PGbool Bool where fromValue = Decoding.bool
instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict
instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy
instance FromValue 'PGtext String where
fromValue = Strict.Text.unpack <$> Decoding.text_strict
instance FromValue 'PGbytea Strict.ByteString where
fromValue = Decoding.bytea_strict
instance FromValue 'PGbytea Lazy.ByteString where
fromValue = Decoding.bytea_lazy
instance FromValue 'PGdate Day where fromValue = Decoding.date
instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int
instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
fromValue = Decoding.timetz_int
instance FromValue 'PGtimestamp LocalTime where
fromValue = Decoding.timestamp_int
instance FromValue 'PGtimestamptz UTCTime where
fromValue = Decoding.timestamptz_int
instance FromValue 'PGinterval DiffTime where
fromValue = Decoding.interval_int
instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast
instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast
instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where
fromValue = Json <$>
Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where
fromValue = Jsonb <$>
Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
instance FromArray ('NotNull ('PGvararray ty)) y
=> FromValue ('PGvararray ty) y where
fromValue = Decoding.array (fromArray @('NotNull ('PGvararray ty)) @y)
instance FromArray ('NotNull ('PGfixarray n ty)) y
=> FromValue ('PGfixarray n ty) y where
fromValue = Decoding.array (fromArray @('NotNull ('PGfixarray n ty)) @y)
instance
( IsEnumType y
, HasDatatypeInfo y
, LabelsPG y ~ labels
) => FromValue ('PGenum labels) (Enumerated y) where
fromValue =
let
greadConstructor
:: All ((~) '[]) xss
=> NP ConstructorInfo xss
-> String
-> Maybe (SOP I xss)
greadConstructor Nil _ = Nothing
greadConstructor (constructor :* constructors) name =
if name == constructorName constructor
then Just (SOP (Z Nil))
else SOP . S . unSOP <$> greadConstructor constructors name
in
fmap Enumerated
. Decoding.enum
$ fmap to
. greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))
. Strict.Text.unpack
instance
( FromRow fields y
) => FromValue ('PGcomposite fields) (Composite y) where
fromValue =
let
composite = Decoding.valueParser $ do
unitOfSize 4
hsequence' $ hpure $ Comp $ do
unitOfSize 4
len <- sized 4 Decoding.int
if len == -1
then return (K Nothing)
else K . Just <$> bytesOfSize len
in
fmap Composite (Decoding.fn (fromRow @fields <=< composite))
class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where
fromField
:: K (Maybe Strict.ByteString) pg
-> (Either Strict.Text :.: P) y
instance FromValue pg y
=> FromField (column ::: ('NotNull pg)) (column ::: y) where
fromField = Comp . \case
K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"
K (Just bytestring) -> P <$>
Decoding.valueParser (fromValue @pg) bytestring
instance FromValue pg y
=> FromField (column ::: 'Null pg) (column ::: Maybe y) where
fromField = Comp . \case
K Nothing -> Right $ P Nothing
K (Just bytestring) -> P . Just <$>
Decoding.valueParser (fromValue @pg) bytestring
class FromArray (ty :: NullityType) (y :: Type) where
fromArray :: Decoding.Array y
instance {-# OVERLAPPABLE #-} FromValue pg y
=> FromArray ('NotNull pg) y where
fromArray = Decoding.valueArray (fromValue @pg @y)
instance {-# OVERLAPPABLE #-} FromValue pg y
=> FromArray ('Null pg) (Maybe y) where
fromArray = Decoding.nullableValueArray (fromValue @pg @y)
instance {-# OVERLAPPING #-} FromArray array y
=> FromArray ('NotNull ('PGvararray array)) (Vector y) where
fromArray =
Decoding.dimensionArray Vector.replicateM (fromArray @array @y)
instance {-# OVERLAPPING #-} FromArray array y
=> FromArray ('Null ('PGvararray array)) (Maybe (Vector y)) where
fromArray = Just <$>
Decoding.dimensionArray Vector.replicateM (fromArray @array @y)
instance {-# OVERLAPPING #-}
( FromArray array y
, All ((~) y) ys
, SListI ys
, IsProductType product ys )
=> FromArray ('NotNull ('PGfixarray n array)) product where
fromArray =
let
rep _ = fmap (to . SOP . Z) . replicateMN
in
Decoding.dimensionArray rep (fromArray @array @y)
instance {-# OVERLAPPING #-}
( FromArray array y
, All ((~) y) ys
, SListI ys
, IsProductType product ys )
=> FromArray ('Null ('PGfixarray n array)) (Maybe product) where
fromArray =
let
rep _ = fmap (to . SOP . Z) . replicateMN
in
Just <$> Decoding.dimensionArray rep (fromArray @array @y)
class SListI result => FromRow (result :: RowType) y where
fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y
instance
( SListI result
, IsRecord y ys
, AllZip FromField result ys
) => FromRow result y where
fromRow
= fmap fromRecord
. hsequence'
. htrans (Proxy @FromField) fromField
newtype Only x = Only { fromOnly :: x }
deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
instance Generic (Only x)
instance HasDatatypeInfo (Only x)
foldlN
:: All ((~) x) xs
=> (z -> x -> z) -> z -> NP I xs -> z
foldlN f z = \case
Nil -> z
I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs
replicateMN
:: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
=> m x -> m (NP I xs)
replicateMN mx = hsequence' $
hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))