git.iko.soy/squeal
on dev help sign in
encode composites
d3bfaa5Eitan Chatav
squeal-postgresql/squeal-postgresql.cabal+1
compare with dev
unifiedsplit
@@ -39,6 +39,7 @@ library
39 aeson >= 1.2.4.0
39 aeson >= 1.2.4.0
40 , base >= 4.10.1.0 && < 5.0
40 , base >= 4.10.1.0 && < 5.0
41 , binary-parser
41 , binary-parser
42+ , bytestring-strict-builder
42 , bytestring >= 0.10.8.2
43 , bytestring >= 0.10.8.2
43 , deepseq >= 1.4.3.0
44 , deepseq >= 1.4.3.0
44 , generics-sop >= 0.3.2.0
45 , generics-sop >= 0.3.2.0
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+65−9
@@ -9,7 +9,8 @@ Binary encoding and decoding between Haskell and PostgreSQL types.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12+ AllowAmbiguousTypes
12− DeriveFoldable
13+ , DeriveFoldable
13 , DeriveFunctor
14 , DeriveFunctor
14 , DeriveGeneric
15 , DeriveGeneric
15 , DeriveTraversable
16 , DeriveTraversable
@@ -39,9 +40,11 @@ module Squeal.PostgreSQL.Binary
39 ) where
40 ) where
40
41
41import BinaryParser
42import BinaryParser
43+import ByteString.StrictBuilder
42import Data.Aeson hiding (Null)
44import Data.Aeson hiding (Null)
43import Data.Int
45import Data.Int
44import Data.Kind
46import Data.Kind
47+import Data.Monoid hiding (All)
45import Data.Scientific
48import Data.Scientific
46import Data.Time
49import Data.Time
47import Data.UUID.Types
50import Data.UUID.Types
@@ -119,13 +122,66 @@ instance (HasOid pg, ToParam x pg)
119instance
122instance
120 ( IsEnumType x
123 ( IsEnumType x
121 , Show x
124 , Show x
122− -- , SameLabels (DatatypeInfoOf y) labels
125+ , SameLabels (DatatypeInfoOf x) 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
127 ) => ToParam x ('PGenum labels) where
126 ) => ToParam x ('PGenum labels) where
128 toParam = K . Encoding.text_strict . Strict.pack . show
127 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+
129-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
185-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
130-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
186-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
131-- not define instances of `ToColumnParam`, just use the provided instances.
187-- not define instances of `ToColumnParam`, just use the provided instances.
@@ -231,6 +287,7 @@ instance
231 (hpure Proxy :: NP Proxy pgs)
287 (hpure Proxy :: NP Proxy pgs)
232
288
233 composite fields = do
289 composite fields = do
290+ -- <number of fields: 4 bytes>
234 -- [for each field]
291 -- [for each field]
235 -- <OID of field's type: sizeof(Oid) bytes>
292 -- <OID of field's type: sizeof(Oid) bytes>
236 -- [if value is NULL]
293 -- [if value is NULL]
@@ -240,7 +297,6 @@ instance
240 -- <value: <length> bytes>
297 -- <value: <length> bytes>
241 -- [end if]
298 -- [end if]
242 -- [end for]
299 -- [end for]
243− -- <number of fields: 4 bytes>
244 unitOfSize 4
300 unitOfSize 4
245 let
301 let
246 each field = do
302 each field = do
@@ -274,10 +330,10 @@ instance FromValue pg y
274 => FromColumnValue (column ::: ('NotNull pg)) y where
330 => FromColumnValue (column ::: ('NotNull pg)) y where
275 fromColumnValue = \case
331 fromColumnValue = \case
276 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
332 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
277− K (Just bytes) ->
333+ K (Just bs) ->
278 let
334 let
279 errOrValue =
335 errOrValue =
280− Decoding.valueParser (fromValue @pg @y Proxy) bytes
336+ Decoding.valueParser (fromValue @pg @y Proxy) bs
281 err str = error $ "fromColumnValue: " ++ Strict.unpack str
337 err str = error $ "fromColumnValue: " ++ Strict.unpack str
282 in
338 in
283 either err id errOrValue
339 either err id errOrValue
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+3
@@ -582,12 +582,15 @@ type family SameLabels
582class MapMaybes xs where
582class MapMaybes xs where
583 type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs
583 type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs
584 maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs)
584 maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs)
585+ unMaybes :: SOP.NP SOP.I (Maybes xs) -> SOP.NP Maybe xs
585instance MapMaybes '[] where
586instance MapMaybes '[] where
586 type Maybes '[] = '[]
587 type Maybes '[] = '[]
587 maybes SOP.Nil = SOP.Nil
588 maybes SOP.Nil = SOP.Nil
589+ unMaybes SOP.Nil = SOP.Nil
588instance MapMaybes xs => MapMaybes (x ': xs) where
590instance MapMaybes xs => MapMaybes (x ': xs) where
589 type Maybes (x ': xs) = Maybe x ': Maybes xs
591 type Maybes (x ': xs) = Maybe x ': Maybes xs
590 maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs
592 maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs
593+ unMaybes (SOP.I mx SOP.:* xs) = mx SOP.:* unMaybes xs
591
594
592type family Nulls tys where
595type family Nulls tys where
593 Nulls '[] = '[]
596 Nulls '[] = '[]