Skip to content

Commit cb14c31

Browse files
LaurentRDCLaurentRDC
committed
Support Postgres array migrations
1 parent 00eeec4 commit cb14c31

File tree

2 files changed

+86
-74
lines changed

2 files changed

+86
-74
lines changed

‎beam-postgres/Database/Beam/Postgres/Syntax.hs

Lines changed: 65 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -580,8 +580,8 @@ instance IsSql99DataTypeSyntax PgDataTypeSyntax where
580580
binaryLargeObjectType = pgByteaType { pgDataTypeSerialized = binaryLargeObjectType }
581581
booleanType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bool) Nothing) (emit "BOOLEAN")
582582
booleanType
583-
arrayType (PgDataTypeSyntax _ syntax serialized) sz =
584-
PgDataTypeSyntax (error "TODO: array migrations")
583+
arrayType (PgDataTypeSyntax descr syntax serialized) sz =
584+
PgDataTypeSyntax (PgDataTypeDescrOid (fromMaybe (error "Unsupported array type") (arrayTypeDescr descr)) Nothing)
585585
(syntax <> emit "[" <> emit (fromString (show sz)) <> emit "]")
586586
(arrayType serialized sz)
587587
rowType = error "rowType"
@@ -647,12 +647,73 @@ pgLineType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.line) Nothing) (
647647
pgLineSegmentType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.lseg) Nothing) (emit "LSEG") (pgDataTypeJSON "lseg")
648648
pgBoxType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.box) Nothing) (emit "BOX") (pgDataTypeJSON "box")
649649

650+
-- TODO: better mechanism to tell, at compile time, that some type
651+
-- cannot be placed in an array
650652
pgUnboundedArrayType :: PgDataTypeSyntax -> PgDataTypeSyntax
651-
pgUnboundedArrayType (PgDataTypeSyntax _ syntax serialized) =
652-
PgDataTypeSyntax (error "Can't do array migrations yet")
653+
pgUnboundedArrayType (PgDataTypeSyntax descr syntax serialized) =
654+
PgDataTypeSyntax (PgDataTypeDescrOid (fromMaybe (error "Unsupported array type") (arrayTypeDescr descr)) Nothing)
653655
(syntax <> emit "[]")
654656
(pgDataTypeJSON (object [ "unbounded-array" .= fromBeamSerializedDataType serialized ]))
655657

658+
-- TODO: define CPP macro to make sure the left hand side (e.g. `Pg.recordOid`)
659+
-- always matches right hand side (e.g. `Pg.array_recordOid)
660+
661+
-- | Get the Oid of Pg arrays which contains elements of a certain type
662+
arrayTypeDescr :: PgDataTypeDescr -> Maybe Pg.Oid
663+
arrayTypeDescr (PgDataTypeDescrDomain _) = Nothing
664+
arrayTypeDescr (PgDataTypeDescrOid elemOid _)
665+
| elemOid == Pg.recordOid = Just $ Pg.array_recordOid
666+
| elemOid == Pg.xmlOid = Just $ Pg.array_xmlOid
667+
| elemOid == Pg.jsonOid = Just $ Pg.array_jsonOid
668+
| elemOid == Pg.lineOid = Just $ Pg.array_lineOid
669+
| elemOid == Pg.cidrOid = Just $ Pg.array_cidOid
670+
| elemOid == Pg.circleOid = Just $ Pg.array_circleOid
671+
| elemOid == Pg.moneyOid = Just $ Pg.array_moneyOid
672+
| elemOid == Pg.boolOid = Just $ Pg.array_boolOid
673+
| elemOid == Pg.byteaOid = Just $ Pg.array_byteaOid
674+
| elemOid == Pg.charOid = Just $ Pg.array_charOid
675+
| elemOid == Pg.nameOid = Just $ Pg.array_nameOid
676+
| elemOid == Pg.int2Oid = Just $ Pg.array_int2Oid
677+
| elemOid == Pg.int2vectorOid = Just $ Pg.array_int2vectorOid
678+
| elemOid == Pg.int4Oid = Just $ Pg.array_int4Oid
679+
| elemOid == Pg.regprocOid = Just $ Pg.array_regprocOid
680+
| elemOid == Pg.textOid = Just $ Pg.array_textOid
681+
| elemOid == Pg.tidOid = Just $ Pg.array_tidOid
682+
| elemOid == Pg.xidOid = Just $ Pg.array_xidOid
683+
| elemOid == Pg.cidOid = Just $ Pg.array_cidOid
684+
| elemOid == Pg.bpcharOid = Just $ Pg.array_bpcharOid
685+
| elemOid == Pg.varcharOid = Just $ Pg.array_varcharOid
686+
| elemOid == Pg.int8Oid = Just $ Pg.array_int8Oid
687+
| elemOid == Pg.pointOid = Just $ Pg.array_pointOid
688+
| elemOid == Pg.lsegOid = Just $ Pg.array_lsegOid
689+
| elemOid == Pg.pathOid = Just $ Pg.array_pathOid
690+
| elemOid == Pg.boxOid = Just $ Pg.array_boxOid
691+
| elemOid == Pg.float4Oid = Just $ Pg.array_float4Oid
692+
| elemOid == Pg.float8Oid = Just $ Pg.array_float8Oid
693+
| elemOid == Pg.polygonOid = Just $ Pg.array_polygonOid
694+
| elemOid == Pg.oidOid = Just $ Pg.array_oidOid
695+
| elemOid == Pg.macaddrOid = Just $ Pg.array_macaddrOid
696+
| elemOid == Pg.inetOid = Just $ Pg.array_inetOid
697+
| elemOid == Pg.timestampOid = Just $ Pg.array_timestampOid
698+
| elemOid == Pg.dateOid = Just $ Pg.array_dateOid
699+
| elemOid == Pg.timeOid = Just $ Pg.array_timeOid
700+
| elemOid == Pg.timestamptzOid = Just $ Pg.array_timestamptzOid
701+
| elemOid == Pg.intervalOid = Just $ Pg.array_intervalOid
702+
| elemOid == Pg.numericOid = Just $ Pg.array_numericOid
703+
| elemOid == Pg.timetzOid = Just $ Pg.array_timetzOid
704+
| elemOid == Pg.bitOid = Just $ Pg.array_bitOid
705+
| elemOid == Pg.varbitOid = Just $ Pg.array_varbitOid
706+
| elemOid == Pg.refcursorOid = Just $ Pg.array_refcursorOid
707+
| elemOid == Pg.regprocedureOid = Just $ Pg.array_regprocedureOid
708+
| elemOid == Pg.regoperOid = Just $ Pg.array_regoperOid
709+
| elemOid == Pg.regoperatorOid = Just $ Pg.array_regoperatorOid
710+
| elemOid == Pg.regclassOid = Just $ Pg.array_regclassOid
711+
| elemOid == Pg.regtypeOid = Just $ Pg.array_regtypeOid
712+
| elemOid == Pg.uuidOid = Just $ Pg.array_uuidOid
713+
| elemOid == Pg.jsonbOid = Just $ Pg.array_jsonbOid
714+
| otherwise = Nothing
715+
716+
656717
pgTsQueryTypeInfo :: Pg.TypeInfo
657718
pgTsQueryTypeInfo = Pg.Basic (Pg.Oid 3615) 'U' ',' "tsquery"
658719

‎beam-postgres/test/Database/Beam/Postgres/Test/Marshal.hs

Lines changed: 21 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,10 @@ boxGen = do PgPoint x1 y1 <- pointGen
5151
pure (PgBox (PgPoint (min x1 x2) (min y1 y2))
5252
(PgPoint (max x1 x2) (max y1 y2)))
5353

54+
arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a)
55+
arrayGen = fmap Vector.fromList
56+
. Gen.list (Range.linear 0 5) -- small arrays == quick tests
57+
5458
boxCmp :: PgBox -> PgBox -> Bool
5559
boxCmp (PgBox a1 b1) (PgBox a2 b2) =
5660
(a1 `ptCmp` a2 && b1 `ptCmp` b2) ||
@@ -90,13 +94,27 @@ tests postgresConn =
9094
, marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn
9195
, marshalTest (Gen.maybe textGen) postgresConn
9296
, marshalTest (Gen.maybe uuidGen) postgresConn
93-
, marshalTest692 postgresConn
9497

9598
, marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b)) (Gen.maybe pointGen) postgresConn
9699
, marshalTest' (\a b -> Hedgehog.assert (liftEq boxCmp a b)) (Gen.maybe boxGen) postgresConn
97100

98-
-- , marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn
99-
-- , marshalTest (Gen.integral (Range.constantBounded @Word)) postgresConn
101+
-- Arrays
102+
--
103+
-- Testing lots of element types for arrays is important, because
104+
-- the mapping between array Oid and element Oid is not type
105+
-- safe, and hence error-prone.
106+
, marshalTest (arrayGen textGen) postgresConn
107+
, marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn
108+
, marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int16)))) postgresConn
109+
, marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int32)))) postgresConn
110+
, marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int64)))) postgresConn
111+
, marshalTest (Gen.maybe (arrayGen textGen)) postgresConn
112+
, marshalTest (Gen.maybe (arrayGen (Gen.double (Range.exponentialFloat 0 1e40)))) postgresConn
113+
, marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int16))))) postgresConn
114+
, marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int32))))) postgresConn
115+
, marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int64))))) postgresConn
116+
117+
, marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn
100118
-- , marshalTest (Gen.integral (Range.constantBounded @Int)) postgresConn
101119

102120
-- , marshalTest @Int8 postgresConn
@@ -164,70 +182,3 @@ marshalTest' cmp gen postgresConn =
164182
v' `cmp` a
165183

166184
assertBool "Hedgehog test failed" passes
167-
168-
169-
-- Ensure that both `Vector Text` and `Maybe (Vector Text)` can be
170-
-- marshalled correctly (see issue 692).
171-
--
172-
-- At this time, the postgres migration backend can't create columns of arrays,
173-
-- and hence this test does not use `marshalTest`.
174-
marshalTest692 :: IO ByteString -> TestTree
175-
marshalTest692 postgresConn =
176-
testCase "Can marshal Vector Text and Maybe (Vector Text) (#692)" $
177-
withTestPostgres ("db_marshal_maybe_vector_text_issue_692") postgresConn $ \conn -> do
178-
liftIO $ execute_ conn $ "CREATE TABLE mytable (\nmyid SERIAL PRIMARY KEY, mycolumn text[], mynullablecolumn text[]\n);"
179-
180-
passes <- Hedgehog.check . Hedgehog.property $ do
181-
nullable <- Hedgehog.forAll (Gen.maybe (Vector.fromList <$> (Gen.list (Range.linear 0 10) textGen)))
182-
nonnull <- Hedgehog.forAll (Vector.fromList <$> (Gen.list (Range.linear 0 10) textGen))
183-
184-
[MkTbl692 rowId v vnull] <-
185-
liftIO . runBeamPostgres conn
186-
$ runInsertReturningList
187-
$ insert (_myTable myDB)
188-
$ insertExpressions [ MkTbl692 default_ (val_ nonnull) (val_ nullable) ]
189-
190-
v === nonnull
191-
vnull === nullable
192-
193-
Just (MkTbl692 _ v' vnull') <-
194-
liftIO . runBeamPostgres conn
195-
$ runSelectReturningOne (lookup_ (_myTable myDB) (Tbl692Key rowId))
196-
v' === nonnull
197-
vnull' === nullable
198-
199-
assertBool "Hedgehog test failed" passes
200-
where
201-
myDB :: DatabaseSettings Postgres MyDB692
202-
myDB = defaultDbSettings `withDbModification`
203-
MkMyDB692 {
204-
_myTable =
205-
setEntityName "mytable" <>
206-
modifyTableFields
207-
tableModification {
208-
myid = fieldNamed "myid",
209-
mycolumn = fieldNamed "mycolumn",
210-
mynullablecolumn = fieldNamed "mynullablecolumn"
211-
}
212-
}
213-
214-
data Tbl692 f
215-
= MkTbl692
216-
{ myid :: C f (SqlSerial Int32)
217-
, mycolumn :: C f (Vector.Vector T.Text)
218-
, mynullablecolumn :: C f (Maybe (Vector.Vector T.Text))
219-
}
220-
deriving (Generic, Beamable)
221-
222-
deriving instance Show (Tbl692 Identity)
223-
deriving instance Eq (Tbl692 Identity)
224-
225-
instance Table Tbl692 where
226-
data PrimaryKey Tbl692 f = Tbl692Key (C f (SqlSerial Int32))
227-
deriving (Generic, Beamable)
228-
primaryKey = Tbl692Key <$> myid
229-
data MyDB692 entity
230-
= MkMyDB692
231-
{ _myTable :: entity (TableEntity Tbl692)
232-
} deriving (Generic)
233-
instance Database Postgres MyDB692

0 commit comments

Comments
 (0)