mirror of
https://github.com/ilyakooo0/squeal.git
synced 2024-09-11 13:57:29 +03:00
Merge pull request #163 from morphismtech/dev-params-oids
parameter oids
This commit is contained in:
Eitan Chatav
GitHub
commit
b63086cdbb
@ -216,8 +216,9 @@ module Squeal.PostgreSQL.Binary
|
||||
-- * Only
|
||||
, Only (..)
|
||||
-- * Oid
|
||||
, HasOid (..)
|
||||
, HasAliasedOid (..)
|
||||
, OidOf (..)
|
||||
, OidOfParam (..)
|
||||
, OidOfField (..)
|
||||
) where
|
||||
|
||||
import BinaryParser
|
||||
@ -231,6 +232,7 @@ import Data.Time
|
||||
import Data.UUID.Types
|
||||
import Data.Vector (Vector)
|
||||
import Data.Word
|
||||
import Foreign.C.Types (CUInt(CUInt))
|
||||
import Generics.SOP
|
||||
import Generics.SOP.Record
|
||||
import GHC.TypeLits
|
||||
@ -244,6 +246,7 @@ 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 Database.PostgreSQL.LibPQ as LibPQ
|
||||
import qualified GHC.Generics as GHC
|
||||
import qualified PostgreSQL.Binary.Decoding as Decoding
|
||||
import qualified PostgreSQL.Binary.Encoding as Encoding
|
||||
@ -309,24 +312,24 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
|
||||
instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
|
||||
toParam = K . Encoding.jsonb_bytes
|
||||
. Lazy.ByteString.toStrict . Aeson.encode . getJsonb
|
||||
instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
|
||||
instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
|
||||
=> ToParam (VarArray [x]) ('PGvararray ty) where
|
||||
toParam = K
|
||||
. Encoding.array_foldable
|
||||
(getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
|
||||
. getVarArray
|
||||
instance (ToParam x pg, HasOid pg)
|
||||
instance (ToParam x pg, OidOf pg)
|
||||
=> ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
|
||||
toParam = K
|
||||
. Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
|
||||
. getVarArray
|
||||
instance (ToParam x pg, HasOid pg)
|
||||
instance (ToParam x pg, OidOf pg)
|
||||
=> ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
|
||||
toParam = K
|
||||
. Encoding.nullableArray_vector
|
||||
(getOid (oidOf @pg)) (unK . toParam @x @pg)
|
||||
. getVarArray
|
||||
instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
|
||||
instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
|
||||
=> ToParam (FixArray x) ('PGfixarray dims ty) where
|
||||
toParam = K . Encoding.array (getOid (oidOf @pg))
|
||||
. unK . unK . toFixArray @x @dims @ty . getFixArray
|
||||
@ -353,7 +356,7 @@ instance
|
||||
( SListI fields
|
||||
, IsRecord x xs
|
||||
, AllZip ToField xs fields
|
||||
, All HasAliasedOid fields
|
||||
, All OidOfField fields
|
||||
) => ToParam (Composite x) ('PGcomposite fields) where
|
||||
toParam =
|
||||
let
|
||||
@ -361,7 +364,7 @@ instance
|
||||
encoders = htrans (Proxy @ToField) toField
|
||||
|
||||
composite
|
||||
:: All HasAliasedOid row
|
||||
:: All OidOfField row
|
||||
=> NP (K (Maybe Encoding.Encoding)) row
|
||||
-> K Encoding.Encoding ('PGcomposite row)
|
||||
composite fields = K $
|
||||
@ -378,18 +381,18 @@ instance
|
||||
int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
|
||||
let
|
||||
each
|
||||
:: HasAliasedOid field
|
||||
:: OidOfField field
|
||||
=> K (Maybe Encoding.Encoding) field
|
||||
-> Encoding.Encoding
|
||||
each (K field :: K (Maybe Encoding.Encoding) field) =
|
||||
word32BE (getOid (aliasedOid @field))
|
||||
word32BE (getOid (oidOfField @field))
|
||||
<> case field of
|
||||
Nothing -> int64BE (-1)
|
||||
Just value ->
|
||||
int32BE (fromIntegral (builderLength value))
|
||||
<> value
|
||||
in
|
||||
hcfoldMap (Proxy @HasAliasedOid) each fields
|
||||
hcfoldMap (Proxy @OidOfField) each fields
|
||||
|
||||
in
|
||||
composite . encoders . toRecord . getComposite
|
||||
@ -398,35 +401,119 @@ instance
|
||||
--
|
||||
-- >>> :set -XTypeApplications
|
||||
-- >>> oidOf @'PGbool
|
||||
-- Oid {getOid = 16}
|
||||
class HasOid (ty :: PGType) where oidOf :: Oid
|
||||
instance HasOid 'PGbool where oidOf = Oid 16
|
||||
instance HasOid 'PGint2 where oidOf = Oid 21
|
||||
instance HasOid 'PGint4 where oidOf = Oid 23
|
||||
instance HasOid 'PGint8 where oidOf = Oid 20
|
||||
instance HasOid 'PGnumeric where oidOf = Oid 1700
|
||||
instance HasOid 'PGfloat4 where oidOf = Oid 700
|
||||
instance HasOid 'PGfloat8 where oidOf = Oid 701
|
||||
instance HasOid ('PGchar n) where oidOf = Oid 18
|
||||
instance HasOid ('PGvarchar n) where oidOf = Oid 1043
|
||||
instance HasOid 'PGtext where oidOf = Oid 25
|
||||
instance HasOid 'PGbytea where oidOf = Oid 17
|
||||
instance HasOid 'PGtimestamp where oidOf = Oid 1114
|
||||
instance HasOid 'PGtimestamptz where oidOf = Oid 1184
|
||||
instance HasOid 'PGdate where oidOf = Oid 1082
|
||||
instance HasOid 'PGtime where oidOf = Oid 1083
|
||||
instance HasOid 'PGtimetz where oidOf = Oid 1266
|
||||
instance HasOid 'PGinterval where oidOf = Oid 1186
|
||||
instance HasOid 'PGuuid where oidOf = Oid 2950
|
||||
instance HasOid 'PGinet where oidOf = Oid 869
|
||||
instance HasOid 'PGjson where oidOf = Oid 114
|
||||
instance HasOid 'PGjsonb where oidOf = Oid 3802
|
||||
-- Oid 16
|
||||
class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
|
||||
instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
|
||||
instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
|
||||
instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
|
||||
instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
|
||||
instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
|
||||
instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
|
||||
instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
|
||||
instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
|
||||
instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
|
||||
instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
|
||||
instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
|
||||
instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
|
||||
instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
|
||||
instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
|
||||
instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
|
||||
instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
|
||||
instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
|
||||
instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
|
||||
instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
|
||||
instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
|
||||
instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
|
||||
instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790
|
||||
instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791
|
||||
instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791
|
||||
instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
|
||||
instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
|
||||
instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
|
||||
instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
|
||||
instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
|
||||
instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
|
||||
instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
|
||||
instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
|
||||
instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
|
||||
instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
|
||||
instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
|
||||
instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
|
||||
instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
|
||||
instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
|
||||
instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
|
||||
instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
|
||||
instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
|
||||
instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
|
||||
instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
|
||||
instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
|
||||
instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
|
||||
instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
|
||||
instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
|
||||
instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
|
||||
instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
|
||||
instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
|
||||
instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
|
||||
instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
|
||||
instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
|
||||
instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
|
||||
instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
|
||||
instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
|
||||
instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
|
||||
instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
|
||||
instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
|
||||
instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
|
||||
instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
|
||||
instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
|
||||
instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
|
||||
instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
|
||||
instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
|
||||
instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
|
||||
instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614
|
||||
instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
|
||||
instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
|
||||
instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615
|
||||
instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
|
||||
instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
|
||||
instance OidOf 'PGoid where oidOf = LibPQ.Oid 26
|
||||
instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028
|
||||
instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028
|
||||
instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
|
||||
instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
|
||||
instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
|
||||
instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
|
||||
instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
|
||||
instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912
|
||||
instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
|
||||
instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
|
||||
instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
|
||||
|
||||
-- | Lifts a `HasOid` constraint to a field.
|
||||
class HasAliasedOid (field :: (Symbol, NullityType)) where
|
||||
aliasedOid :: Oid
|
||||
instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
|
||||
aliasedOid = oidOf @ty
|
||||
class OidOfParam (ty :: NullityType) where oidOfParam :: Oid
|
||||
instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty
|
||||
|
||||
-- | Lifts a `OidOf` constraint to a field.
|
||||
class OidOfField (field :: (Symbol, NullityType)) where
|
||||
oidOfField :: Oid
|
||||
instance OidOf ty => OidOfField (alias ::: nullity ty) where
|
||||
oidOfField = oidOf @ty
|
||||
|
||||
-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
|
||||
-- into the binary format of a PostgreSQL `NullityType`.
|
||||
@ -756,3 +843,6 @@ replicateMN
|
||||
=> m x -> m (NP I xs)
|
||||
replicateMN mx = hsequence' $
|
||||
hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
|
||||
|
||||
getOid :: LibPQ.Oid -> Word32
|
||||
getOid (LibPQ.Oid (CUInt oid)) = oid
|
||||
|
||||
@ -340,6 +340,12 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
|
||||
instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
|
||||
instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
|
||||
instance PGTyped schemas (null 'PGoid) where pgtype = oid
|
||||
instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
|
||||
instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
|
||||
instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
|
||||
instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
|
||||
instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
|
||||
instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
|
||||
|
||||
-- | Lift `PGTyped` to a field
|
||||
class FieldTyped schemas ty where
|
||||
|
||||
@ -47,7 +47,7 @@ module Squeal.PostgreSQL.PG
|
||||
, Enumerated (..)
|
||||
, VarArray (..)
|
||||
, FixArray (..)
|
||||
, Oid (..)
|
||||
, LibPQ.Oid (..)
|
||||
-- * Type families
|
||||
, LabelsPG
|
||||
, DimPG
|
||||
@ -66,7 +66,6 @@ import Data.Int (Int16, Int32, Int64)
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
|
||||
import Data.Vector (Vector)
|
||||
import Data.Word (Word32)
|
||||
import Data.UUID.Types (UUID)
|
||||
import GHC.TypeLits
|
||||
import Network.IP.Addr (NetAddr, IP)
|
||||
@ -75,6 +74,7 @@ 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 Database.PostgreSQL.LibPQ as LibPQ
|
||||
import qualified GHC.Generics as GHC
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified Generics.SOP.Record as SOP
|
||||
@ -108,7 +108,7 @@ type instance PG Int32 = 'PGint4
|
||||
-- | `PGint8`
|
||||
type instance PG Int64 = 'PGint8
|
||||
-- | `PGint2`
|
||||
type instance PG Oid = 'PGoid
|
||||
type instance PG LibPQ.Oid = 'PGoid
|
||||
-- | `PGnumeric`
|
||||
type instance PG Scientific = 'PGnumeric
|
||||
-- | `PGfloat4`
|
||||
@ -386,10 +386,3 @@ newtype FixArray arr = FixArray {getFixArray :: arr}
|
||||
deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
|
||||
-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
|
||||
type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
|
||||
|
||||
{- | Object identifiers (`Oid`s) are used internally by PostgreSQL
|
||||
as primary keys for various system tables.
|
||||
-}
|
||||
newtype Oid = Oid { getOid :: Word32 }
|
||||
deriving stock (Eq, Ord, Show, Read, GHC.Generic)
|
||||
deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
|
||||
|
||||
@ -78,6 +78,7 @@ import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Kind
|
||||
import Data.Text (pack, Text)
|
||||
import Data.Traversable
|
||||
@ -86,6 +87,7 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
|
||||
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
||||
import qualified PostgreSQL.Binary.Encoding as Encoding
|
||||
|
||||
import Squeal.PostgreSQL.Binary
|
||||
import Squeal.PostgreSQL.Definition
|
||||
@ -315,13 +317,13 @@ a default instance.
|
||||
-}
|
||||
class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
manipulateParams
|
||||
:: ToParams x params
|
||||
:: (ToParams x params, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params ys
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
-> x -> pq (K LibPQ.Result ys)
|
||||
default manipulateParams
|
||||
:: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
|
||||
=> ToParams x params
|
||||
=> (ToParams x params, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params ys
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
-> x -> pq (K LibPQ.Result ys)
|
||||
@ -329,7 +331,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
manipulateParams manipulation params
|
||||
|
||||
manipulateParams_
|
||||
:: ToParams x params
|
||||
:: (ToParams x params, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params '[]
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
-> x -> pq ()
|
||||
@ -342,7 +344,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
manipulate_ = void . manipulate
|
||||
|
||||
runQueryParams
|
||||
:: ToParams x params
|
||||
:: (ToParams x params, All OidOfParam params)
|
||||
=> Query '[] '[] schemas params ys
|
||||
-- ^ `select` and friends
|
||||
-> x -> pq (K LibPQ.Result ys)
|
||||
@ -355,19 +357,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
runQuery q = runQueryParams q ()
|
||||
|
||||
traversePrepared
|
||||
:: (ToParams x params, Traversable list)
|
||||
:: (ToParams x params, Traversable list, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params ys
|
||||
-- ^ `insertInto`, `update`, or `deleteFrom`, and friends
|
||||
-> list x -> pq (list (K LibPQ.Result ys))
|
||||
default traversePrepared
|
||||
:: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
|
||||
=> (ToParams x params, Traversable list)
|
||||
=> (ToParams x params, Traversable list, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
|
||||
traversePrepared manipulation params = lift $
|
||||
traversePrepared manipulation params
|
||||
|
||||
forPrepared
|
||||
:: (ToParams x params, Traversable list)
|
||||
:: (ToParams x params, Traversable list, All OidOfParam params)
|
||||
=> list x
|
||||
-> Manipulation '[] schemas params ys
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
@ -375,13 +377,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
forPrepared = flip traversePrepared
|
||||
|
||||
traversePrepared_
|
||||
:: (ToParams x params, Foldable list)
|
||||
:: (ToParams x params, Foldable list, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params '[]
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
-> list x -> pq ()
|
||||
default traversePrepared_
|
||||
:: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
|
||||
=> (ToParams x params, Foldable list)
|
||||
=> (ToParams x params, Foldable list, All OidOfParam params)
|
||||
=> Manipulation '[] schemas params '[]
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
-> list x -> pq ()
|
||||
@ -389,7 +391,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
|
||||
traversePrepared_ manipulation params
|
||||
|
||||
forPrepared_
|
||||
:: (ToParams x params, Foldable list)
|
||||
:: (ToParams x params, Foldable list, All OidOfParam params)
|
||||
=> list x
|
||||
-> Manipulation '[] schemas params '[]
|
||||
-- ^ `insertInto`, `update` or `deleteFrom`
|
||||
@ -409,9 +411,17 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
|
||||
(UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
|
||||
PQ $ \ (K conn) -> do
|
||||
let
|
||||
toParam' encoding =
|
||||
(LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
|
||||
params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
|
||||
paramSet
|
||||
:: forall param. OidOfParam param
|
||||
=> K (Maybe Encoding.Encoding) param
|
||||
-> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
|
||||
paramSet (K maybeEncoding) = K $
|
||||
maybeEncoding <&> \encoding ->
|
||||
(oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
|
||||
params'
|
||||
= hcollapse
|
||||
. hcmap (Proxy @OidOfParam) paramSet
|
||||
$ toParams @x @ps params
|
||||
q' = q <> ";"
|
||||
resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
|
||||
case resultMaybe of
|
||||
@ -424,8 +434,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
|
||||
traversePrepared
|
||||
(UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
|
||||
PQ $ \ (K conn) -> liftIO $ do
|
||||
let temp = "temporary_statement"
|
||||
prepResultMaybe <- LibPQ.prepare conn temp q Nothing
|
||||
let
|
||||
temp = "temporary_statement"
|
||||
paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
|
||||
paramOid = K (oidOfParam @p)
|
||||
paramOids :: NP (K LibPQ.Oid) xs
|
||||
paramOids = hcpure (Proxy @OidOfParam) paramOid
|
||||
paramOids' :: [LibPQ.Oid]
|
||||
paramOids' = hcollapse paramOids
|
||||
prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
|
||||
case prepResultMaybe of
|
||||
Nothing -> throw $ ResultException
|
||||
"traversePrepared: LibPQ.prepare returned no results"
|
||||
@ -451,8 +468,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
|
||||
traversePrepared_
|
||||
(UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
|
||||
PQ $ \ (K conn) -> liftIO $ do
|
||||
let temp = "temporary_statement"
|
||||
prepResultMaybe <- LibPQ.prepare conn temp q Nothing
|
||||
let
|
||||
temp = "temporary_statement"
|
||||
paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
|
||||
paramOid = K (oidOfParam @p)
|
||||
paramOids :: NP (K LibPQ.Oid) xs
|
||||
paramOids = hcpure (Proxy @OidOfParam) paramOid
|
||||
paramOids' :: [LibPQ.Oid]
|
||||
paramOids' = hcollapse paramOids
|
||||
prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
|
||||
case prepResultMaybe of
|
||||
Nothing -> throw $ ResultException
|
||||
"traversePrepared_: LibPQ.prepare returned no results"
|
||||
|
||||
@ -92,14 +92,14 @@ roundtrips = Group "roundtrips"
|
||||
-- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
|
||||
|
||||
roundtrip
|
||||
:: (ToParam x ty, FromValue ty x, Show x, Eq x)
|
||||
:: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
|
||||
=> TypeExpression schemas ('NotNull ty)
|
||||
-> Gen x
|
||||
-> (PropertyName, Property)
|
||||
roundtrip = roundtripOn id
|
||||
|
||||
roundtripOn
|
||||
:: (ToParam x ty, FromValue ty x, Show x, Eq x)
|
||||
:: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
|
||||
=> (x -> x)
|
||||
-> TypeExpression schemas ('NotNull ty)
|
||||
-> Gen x
|
||||
|
||||
@ -123,3 +123,14 @@ spec = before_ setupDB . after_ dropDB $ do
|
||||
getRows =<< runQuery query
|
||||
(fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
|
||||
[ atLeast 3, 3 <=..< 5, Empty, whole ]
|
||||
|
||||
describe "Parameters" $ do
|
||||
|
||||
it "should run queries that don't reference all their parameters" $ do
|
||||
|
||||
out <- withConnection connectionString $ do
|
||||
let
|
||||
query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
|
||||
query = values_ (param @2 `as` #fromOnly)
|
||||
firstRow =<< runQueryParams query ('a', 3 :: Int32)
|
||||
(fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
|
||||
|
||||
Loading…
Reference in New Issue
Block a user