@@ -9,7 +9,8 @@ Binary encoding and decoding between Haskell and PostgreSQL types.
99-}
1010
1111{-# LANGUAGE
12− DeriveFoldable
12+ AllowAmbiguousTypes
13+ , DeriveFoldable
1314 , DeriveFunctor
1415 , DeriveGeneric
1516 , DeriveTraversable
@@ -39,9 +40,11 @@ module Squeal.PostgreSQL.Binary
3940 ) where
4041
4142import BinaryParser
43+import ByteString.StrictBuilder
4244import Data.Aeson hiding (Null)
4345import Data.Int
4446import Data.Kind
47+import Data.Monoid hiding (All)
4548import Data.Scientific
4649import Data.Time
4750import Data.UUID.Types
@@ -119,13 +122,66 @@ instance (HasOid pg, ToParam x pg)
119122instance
120123 ( IsEnumType x
121124 , Show x
122− -- , SameLabels (DatatypeInfoOf y) labels
123− --
124− -- uncomment above constraint when GHC issue #11671 is fixed
125− -- Allow labels starting with uppercase with OverloadedLabels
126− -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8
125+ , SameLabels (DatatypeInfoOf x) labels
127126 ) => ToParam x ('PGenum labels) where
128127 toParam = K . Encoding.text_strict . Strict.pack . show
128+instance
129+ ( SListI fields
130+ , MapMaybes xs
131+ , IsProductType x (Maybes xs)
132+ , AllZip ToAliasedParam xs fields
133+ , SameFields (DatatypeInfoOf x) fields
134+ , All HasAliasedOid fields
135+ ) => ToParam x ('PGcomposite fields) where
136+ toParam =
137+ let
138+
139+ encoders = htrans (Proxy @ToAliasedParam) toAliasedParam
140+
141+ composite
142+ :: All HasAliasedOid row
143+ => NP (K (Maybe Encoding.Encoding)) row
144+ -> K Encoding.Encoding ('PGcomposite row)
145+ composite fields = K $
146+ -- <number of fields: 4 bytes>
147+ -- [for each field]
148+ -- <OID of field's type: sizeof(Oid) bytes>
149+ -- [if value is NULL]
150+ -- <-1: 4 bytes>
151+ -- [else]
152+ -- <length of value: 4 bytes>
153+ -- <value: <length> bytes>
154+ -- [end if]
155+ -- [end for]
156+ int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
157+ let
158+ each
159+ :: HasAliasedOid field
160+ => K (Maybe Encoding.Encoding) field
161+ -> Encoding.Encoding
162+ each (K field :: K (Maybe Encoding.Encoding) field) =
163+ word32BE (aliasedOid @field)
164+ <> case field of
165+ Nothing -> int64BE (-1)
166+ Just value ->
167+ int32BE (fromIntegral (builderLength value))
168+ <> value
169+ in
170+ hcfoldMap (Proxy @HasAliasedOid) each fields
171+
172+ in
173+ composite . encoders . unMaybes . unZ . unSOP . from
174+
175+class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32
176+instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty
177+
178+class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where
179+ toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field
180+instance ToParam x ty => ToAliasedParam x (alias ::: ty) where
181+ toAliasedParam = \case
182+ Nothing -> K Nothing
183+ Just x -> K . Just . unK $ toParam @x @ty x
184+
129185-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
130186-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
131187-- not define instances of `ToColumnParam`, just use the provided instances.
@@ -231,6 +287,7 @@ instance
231287 (hpure Proxy :: NP Proxy pgs)
232288
233289 composite fields = do
290+ -- <number of fields: 4 bytes>
234291 -- [for each field]
235292 -- <OID of field's type: sizeof(Oid) bytes>
236293 -- [if value is NULL]
@@ -240,7 +297,6 @@ instance
240297 -- <value: <length> bytes>
241298 -- [end if]
242299 -- [end for]
243− -- <number of fields: 4 bytes>
244300 unitOfSize 4
245301 let
246302 each field = do
@@ -274,10 +330,10 @@ instance FromValue pg y
274330 => FromColumnValue (column ::: ('NotNull pg)) y where
275331 fromColumnValue = \case
276332 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
277− K (Just bytes) ->
333+ K (Just bs) ->
278334 let
279335 errOrValue =
280− Decoding.valueParser (fromValue @pg @y Proxy) bytes
336+ Decoding.valueParser (fromValue @pg @y Proxy) bs
281337 err str = error $ "fromColumnValue: " ++ Strict.unpack str
282338 in
283339 either err id errOrValue