From f2f39a2a64a6167fc2955e1bb55787d663a6ce21 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Sep 2024 15:56:45 -0400 Subject: [PATCH 01/58] add new field and refactor away from entityDB --- persistent-redis/Database/Persist/Redis/Internal.hs | 4 ++-- persistent/Database/Persist/Quasi/Internal.hs | 2 ++ persistent/Database/Persist/TH.hs | 4 ++-- persistent/Database/Persist/Types/Base.hs | 2 ++ 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/persistent-redis/Database/Persist/Redis/Internal.hs b/persistent-redis/Database/Persist/Redis/Internal.hs index 8f4ab66d4..82876b66a 100644 --- a/persistent-redis/Database/Persist/Redis/Internal.hs +++ b/persistent-redis/Database/Persist/Redis/Internal.hs @@ -23,10 +23,10 @@ toLabel :: FieldDef -> B.ByteString toLabel = U.fromString . unpack . unFieldNameDB . fieldDB toEntityString :: PersistEntity val => val -> Text -toEntityString = unEntityNameDB . entityDB . entityDef . Just +toEntityString = unEntityNameDB . getEntityDBName . entityDef . Just toEntityName :: EntityDef -> B.ByteString -toEntityName = U.fromString . unpack . unEntityNameDB . entityDB +toEntityName = U.fromString . unpack . unEntityNameDB . getEntityDBName mkEntity :: (MonadFail m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val) mkEntity key fields = do diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index aad9ec76f..ce817b216 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -712,6 +712,8 @@ mkUnboundEntityDef ps parsedEntDef = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) + , -- TODO: start parsing the schema attribute and write it here. + entitySchema = Nothing } } where diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index de01e8f25..0a2df94cc 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -335,7 +335,7 @@ liftAndFixKeys mps emEntities entityMap unboundEnt = |] where fixForeignRefTableDBName = - entityDB (unboundEntityDef parentDef) + getEntityDBName (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of FieldListImpliedId ffns -> @@ -1968,7 +1968,7 @@ fromValues entDef funName constructExpr fields = do return [ suc, normalClause [VarP x] patternMatchFailure ] where tableName = - unEntityNameDB (entityDB (unboundEntityDef entDef)) + unEntityNameDB (getEntityDBName (unboundEntityDef entDef)) patternSuccess = case fields of [] -> do diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index cd45d8b3c..f978674f6 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -153,6 +153,8 @@ data EntityDef = EntityDef -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. + , entitySchema :: !(Maybe Text) + -- ^ The schema the entity belongs to. -- -- @since 2.10.0 } From 9c09206e2f332fc300c884e21e4feee4a971e6fa Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Sep 2024 16:14:55 -0400 Subject: [PATCH 02/58] add new field to construction --- persistent/test/Database/Persist/THSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index ed971977d..cfba70c6b 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -371,6 +371,7 @@ spec = describe "THSpec" $ do , entityExtra = mempty , entitySum = False , entityComments = Nothing + , entitySchema = Nothing } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected From 1700101d74e880b9ea204fa66845ca67e65e82b8 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Sep 2024 16:17:32 -0400 Subject: [PATCH 03/58] prepend schema to entity db name --- persistent/Database/Persist/EntityDef.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index 4e2fe93fc..ea4c4504e 100644 --- a/persistent/Database/Persist/EntityDef.hs +++ b/persistent/Database/Persist/EntityDef.hs @@ -84,7 +84,9 @@ getEntityHaskellName = entityHaskell getEntityDBName :: EntityDef -> EntityNameDB -getEntityDBName = entityDB +getEntityDBName entityDef = case entitySchema entityDef of + Nothing -> entityDB entityDef + Just schema -> EntityNameDB $ schema <> "." <> unEntityNameDB (entityDB entityDef) getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra From e07cae1a4742c5e1792343f9e3144e5531c8137b Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 15:26:24 -0400 Subject: [PATCH 04/58] add schema test --- persistent-postgresql/test/main.hs | 3 +++ persistent-test/persistent-test.cabal | 1 + persistent-test/src/SchemaTest.hs | 37 +++++++++++++++++++++++++++ 3 files changed, 41 insertions(+) create mode 100644 persistent-test/src/SchemaTest.hs diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 10a726623..890a0871a 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -56,6 +56,7 @@ import qualified RawSqlTest import qualified ReadWriteTest import qualified Recursive import qualified RenameTest +import qualified SchemaTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified TreeTest @@ -140,6 +141,7 @@ main = do , PgIntervalTest.pgIntervalMigrate , UpsertWhere.upsertWhereMigrate , ImplicitUuidSpec.implicitUuidMigrate + , SchemaTest.migration ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -215,3 +217,4 @@ main = do PgIntervalTest.specs ArrayAggTest.specs GeneratedColumnTestSQL.specsWith runConnAssert + SchemaTest.specsWith runConnAssert diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 72e900b80..0a1b798f6 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -57,6 +57,7 @@ library UniqueTest UpsertTest LongIdentifierTest + SchemaTest hs-source-dirs: src diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs new file mode 100644 index 000000000..19d02dced --- /dev/null +++ b/persistent-test/src/SchemaTest.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +module SchemaTest (specsWith, migration, cleanDB) where + +import Database.Persist.Sql +import Database.Persist.TH + +import Init + +share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| +SchemaEntity schema="foo" + foo Int + Primary foo +|] + +cleanDB + :: + ( PersistQueryWrite backend + , MonadIO m + , PersistStoreWrite (BaseBackend backend) + ) + => ReaderT backend m () +cleanDB = deleteWhere ([] :: [Filter (SchemaEntityGeneric backend)]) + +specsWith + :: Runner backend m + => RunDb backend m + -> Spec +specsWith runConn = describe "entity with non-null schema" $ + it "inserts and selects work as expected" $ asIO $ runConn $ do + -- Ensure we can write to the database + x <- insert $ + SchemaEntity + { schemaEntityFoo = 42 + } + Just _ <- get x + return () From 6fea10ea7e9871c527253faf17735326f4f03615 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 15:30:07 -0400 Subject: [PATCH 05/58] remove redundant quotation marks --- persistent-test/src/SchemaTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs index 19d02dced..f51492db8 100644 --- a/persistent-test/src/SchemaTest.hs +++ b/persistent-test/src/SchemaTest.hs @@ -8,7 +8,7 @@ import Database.Persist.TH import Init share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| -SchemaEntity schema="foo" +SchemaEntity schema=foo foo Int Primary foo |] From eb49123d9d119aa298aeaa4d4511db0f0bd6a256 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 16:13:56 -0400 Subject: [PATCH 06/58] revert --- persistent/Database/Persist/EntityDef.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index ea4c4504e..4e2fe93fc 100644 --- a/persistent/Database/Persist/EntityDef.hs +++ b/persistent/Database/Persist/EntityDef.hs @@ -84,9 +84,7 @@ getEntityHaskellName = entityHaskell getEntityDBName :: EntityDef -> EntityNameDB -getEntityDBName entityDef = case entitySchema entityDef of - Nothing -> entityDB entityDef - Just schema -> EntityNameDB $ schema <> "." <> unEntityNameDB (entityDB entityDef) +getEntityDBName = entityDB getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra From e0a7d2737e6b6bfc92588925b5f32b8a266e46d1 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 16:22:38 -0400 Subject: [PATCH 07/58] create newtype for schema name --- persistent/Database/Persist/Names.hs | 3 +++ persistent/Database/Persist/Types/Base.hs | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/Names.hs b/persistent/Database/Persist/Names.hs index 5616e627c..b75f81301 100644 --- a/persistent/Database/Persist/Names.hs +++ b/persistent/Database/Persist/Names.hs @@ -70,3 +70,6 @@ instance DatabaseName ConstraintNameDB where -- @since 2.12.0.0 newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) + +newtype SchemaName = SchemaName { unSchemaName :: Text } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index f978674f6..0dba9ea35 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -153,7 +153,7 @@ data EntityDef = EntityDef -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. - , entitySchema :: !(Maybe Text) + , entitySchema :: !(Maybe SchemaName) -- ^ The schema the entity belongs to. -- -- @since 2.10.0 From ea96742268b55ecdb35fc2b179317fd6b2ca1ae2 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 16:36:13 -0400 Subject: [PATCH 08/58] add setters and getters --- persistent/Database/Persist/EntityDef.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index 4e2fe93fc..d939c0b23 100644 --- a/persistent/Database/Persist/EntityDef.hs +++ b/persistent/Database/Persist/EntityDef.hs @@ -19,6 +19,7 @@ module Database.Persist.EntityDef , getEntityKeyFields , getEntityComments , getEntityExtra + , getEntitySchema , isEntitySum , entityPrimary , entitiesPrimary @@ -27,6 +28,7 @@ module Database.Persist.EntityDef , setEntityId , setEntityIdDef , setEntityDBName + , setEntitySchema , overEntityFields -- * Related Types , EntityIdDef(..) @@ -89,6 +91,9 @@ getEntityDBName = entityDB getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra +getEntitySchema :: EntityDef -> Maybe SchemaName +getEntitySchema = entitySchema + -- | -- -- @since 2.13.0.0 @@ -195,6 +200,9 @@ getEntityKeyFields = entityKeyFields setEntityFields :: [FieldDef] -> EntityDef -> EntityDef setEntityFields fd ed = ed { entityFields = fd } +setEntitySchema :: Maybe SchemaName -> EntityDef -> EntityDef +setEntitySchema sn ed = ed { entitySchema = sn } + -- | Perform a mapping function over all of the entity fields, as determined by -- 'getEntityFieldsDatabase'. -- From 27e4ee7be27c9f1f1f81bcd7f54a6764b85a57f8 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 16:46:18 -0400 Subject: [PATCH 09/58] suffix with DB --- persistent/Database/Persist/EntityDef.hs | 6 ++++++ persistent/Database/Persist/Names.hs | 5 ++++- persistent/Database/Persist/Types/Base.hs | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index 4e2fe93fc..4bf80e7e9 100644 --- a/persistent/Database/Persist/EntityDef.hs +++ b/persistent/Database/Persist/EntityDef.hs @@ -89,6 +89,9 @@ getEntityDBName = entityDB getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra +getEntitySchema :: EntityDef -> Maybe SchemaNameDB +getEntitySchema = entitySchema + -- | -- -- @since 2.13.0.0 @@ -195,6 +198,9 @@ getEntityKeyFields = entityKeyFields setEntityFields :: [FieldDef] -> EntityDef -> EntityDef setEntityFields fd ed = ed { entityFields = fd } +setEntitySchema :: Maybe SchemaNameDB -> EntityDef -> EntityDef +setEntitySchema sn ed = ed { entitySchema = sn } + -- | Perform a mapping function over all of the entity fields, as determined by -- 'getEntityFieldsDatabase'. -- diff --git a/persistent/Database/Persist/Names.hs b/persistent/Database/Persist/Names.hs index b75f81301..dc8b07bb0 100644 --- a/persistent/Database/Persist/Names.hs +++ b/persistent/Database/Persist/Names.hs @@ -71,5 +71,8 @@ instance DatabaseName ConstraintNameDB where newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) -newtype SchemaName = SchemaName { unSchemaName :: Text } +newtype SchemaNameDB = SchemaNameDB { unSchemaNameDB :: Text } deriving (Show, Eq, Read, Ord, Lift) + +instance DatabaseName SchemaNameDB where + escapeWith f (SchemaNameDB n) = f n diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 0dba9ea35..e7f88d353 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -153,7 +153,7 @@ data EntityDef = EntityDef -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. - , entitySchema :: !(Maybe SchemaName) + , entitySchema :: !(Maybe SchemaNameDB) -- ^ The schema the entity belongs to. -- -- @since 2.10.0 From ab479e6a6e51f460a471d8967d4c3aa1503e25e5 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Tue, 1 Oct 2024 17:56:48 -0400 Subject: [PATCH 10/58] save wip --- .../Database/Persist/Postgresql.hs | 112 ++++++++++-------- persistent/Database/Persist/Quasi/Internal.hs | 2 + persistent/Database/Persist/Sql/Internal.hs | 33 +++--- persistent/Database/Persist/Sql/Types.hs | 2 +- persistent/Database/Persist/Types/Base.hs | 1 + 5 files changed, 85 insertions(+), 65 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index a34aafda6..4c7992c54 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -469,7 +469,7 @@ createBackend logFunc serverVersion smap conn = , connCommit = const $ PG.commit conn , connRollback = const $ PG.rollback conn , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . getEntityDBName + , connEscapeTableName = entityIdentifier , connEscapeRawName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql" @@ -498,7 +498,7 @@ insertSql' ent vals = (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO " - , escapeE $ getEntityDBName ent + , entityIdentifier ent , if null (getEntityFields ent) then " DEFAULT VALUES" else T.concat @@ -514,7 +514,7 @@ upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat [ "INSERT INTO " - , escapeE (getEntityDBName ent) + , entityIdentifier ent , "(" , T.intercalate "," fieldNames , ") VALUES (" @@ -543,7 +543,7 @@ insertManySql' ent valss = (fieldNames, placeholders)= unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO " - , escapeE (getEntityDBName ent) + , entityIdentifier ent , "(" , T.intercalate "," fieldNames , ") VALUES (" @@ -657,6 +657,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do (errs, _) -> return $ Left errs where name = getEntityDBName entity + schema = getEntitySchema entity (newcols', udefs, fdefs) = postgresMkColumns allDefs entity migrationText exists' old'' | not exists' = @@ -664,8 +665,8 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do | otherwise = let (acs, ats) = getAlters allDefs entity (newcols, udspair) old' - acs' = map (AlterColumn name) acs - ats' = map (AlterTable name) ats + acs' = map (AlterColumn name schema) acs + ats' = map (AlterTable name schema) ats in acs' ++ ats' where @@ -679,7 +680,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do (addTable newcols entity) : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] + [AlterTable name schema $ AddUniqueConstraint uname ucols] references = mapMaybe (\Column { cName, cReference } -> @@ -692,12 +693,14 @@ mkForeignAlt :: EntityDef -> ForeignDef -> Maybe AlterDB -mkForeignAlt entity fdef = pure $ AlterColumn tableName_ addReference +mkForeignAlt entity fdef = pure $ AlterColumn tableName_ schemaName_ addReference where tableName_ = getEntityDBName entity + schemaName_ = getEntitySchema entity addReference = AddReference (foreignRefTableDBName fdef) + (foreignRefSchemaName fdef) constraintName childfields escapedParentFields @@ -714,7 +717,7 @@ addTable cols entity = AddTable $ T.concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! - , escapeE name + , entityIdentifier entity , "(" , idtxt , if null nonIdCols then "" else "," @@ -773,7 +776,7 @@ data AlterColumn | Default Column Text | NoDefault Column | Update' Column Text - | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [Text] FieldCascade + | AddReference EntityNameDB (Maybe SchemaNameDB) ConstraintNameDB [FieldNameDB] [Text] FieldCascade | DropReference ConstraintNameDB deriving Show @@ -783,8 +786,8 @@ data AlterTable deriving Show data AlterDB = AddTable Text - | AlterColumn EntityNameDB AlterColumn - | AlterTable EntityNameDB AlterTable + | AlterColumn EntityNameDB (Maybe SchemaNameDB) AlterColumn + | AlterTable EntityNameDB (Maybe SchemaNameDB) AlterTable deriving Show -- | Returns all of the columns in the given table currently in the database. @@ -1140,6 +1143,7 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName -> [AddReference (crTableName colRef) + (crSchemaName colRef) (crConstraintName colRef) [name] (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef) @@ -1217,14 +1221,16 @@ getAddReference -> FieldNameDB -> ColumnReference -> Maybe AlterDB -getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do +getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crSchemaName = refschema, crConstraintName=constraintName} = do guard $ Just cname /= fmap fieldDB (getEntityIdField entity) pure $ AlterColumn table - (AddReference s constraintName [cname] id_ (crFieldCascade cr) + schema + (AddReference s refschema constraintName [cname] id_ (crFieldCascade cr) ) where table = getEntityDBName entity + schema = getEntitySchema entity id_ = fromMaybe (error $ "Could not find ID of entity " ++ show s) @@ -1266,90 +1272,90 @@ showSqlType (SqlOther t) = t showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, s) -showAlterDb (AlterColumn t ac) = - (isUnsafe ac, showAlter t ac) +showAlterDb (AlterColumn t s ac) = + (isUnsafe ac, showAlter t s ac) where isUnsafe (Drop _ safeRemove) = not safeRemove isUnsafe _ = False -showAlterDb (AlterTable t at) = (False, showAlterTable t at) +showAlterDb (AlterTable t s at) = (False, showAlterTable t s at) -showAlterTable :: EntityNameDB -> AlterTable -> Text -showAlterTable table (AddUniqueConstraint cname cols) = T.concat +showAlterTable :: EntityNameDB -> Maybe SchemaNameDB -> AlterTable -> Text +showAlterTable table schema (AddUniqueConstraint cname cols) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ADD CONSTRAINT " , escapeC cname , " UNIQUE(" , T.intercalate "," $ map escapeF cols , ")" ] -showAlterTable table (DropConstraint cname) = T.concat +showAlterTable table schema (DropConstraint cname) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " DROP CONSTRAINT " , escapeC cname ] -showAlter :: EntityNameDB -> AlterColumn -> Text -showAlter table (ChangeType c t extra) = +showAlter :: EntityNameDB -> Maybe SchemaNameDB -> AlterColumn -> Text +showAlter table schema (ChangeType c t extra) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ALTER COLUMN " , escapeF (cName c) , " TYPE " , showSqlType t , extra ] -showAlter table (IsNull c) = +showAlter table schema (IsNull c) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ALTER COLUMN " , escapeF (cName c) , " DROP NOT NULL" ] -showAlter table (NotNull c) = +showAlter table schema (NotNull c) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ALTER COLUMN " , escapeF (cName c) , " SET NOT NULL" ] -showAlter table (Add' col) = +showAlter table schema (Add' col) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ADD COLUMN " , showColumn col ] -showAlter table (Drop c _) = +showAlter table schema (Drop c _) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " DROP COLUMN " , escapeF (cName c) ] -showAlter table (Default c s) = +showAlter table schema (Default c s) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ALTER COLUMN " , escapeF (cName c) , " SET DEFAULT " , s ] -showAlter table (NoDefault c) = T.concat +showAlter table schema (NoDefault c) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ALTER COLUMN " , escapeF (cName c) , " DROP DEFAULT" ] -showAlter table (Update' c s) = T.concat +showAlter table schema (Update' c s) = T.concat [ "UPDATE " - , escapeE table + , escapeES table schema , " SET " , escapeF (cName c) , "=" @@ -1358,22 +1364,22 @@ showAlter table (Update' c s) = T.concat , escapeF (cName c) , " IS NULL" ] -showAlter table (AddReference reftable fkeyname t2 id2 cascade) = T.concat +showAlter table schema (AddReference reftable refschema fkeyname t2 id2 cascade) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " ADD CONSTRAINT " , escapeC fkeyname , " FOREIGN KEY(" , T.intercalate "," $ map escapeF t2 , ") REFERENCES " - , escapeE reftable + , escapeES reftable refschema , "(" , T.intercalate "," id2 , ")" ] <> renderFieldCascade cascade -showAlter table (DropReference cname) = T.concat +showAlter table schema (DropReference cname) = T.concat [ "ALTER TABLE " - , escapeE table + , escapeES table schema , " DROP CONSTRAINT " , escapeC cname ] @@ -1397,6 +1403,8 @@ escapeE = escapeWith escape escapeF :: FieldNameDB -> Text escapeF = escapeWith escape +escapeS :: SchemaNameDB -> Text +escapeS = escapeWith escape escape :: Text -> Text escape s = @@ -1406,6 +1414,14 @@ escape s = go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs +entityIdentifier :: EntityDef -> Text +entityIdentifier ed = escapeES (getEntityDBName ed) (getEntitySchema ed) + +escapeES :: EntityNameDB -> Maybe SchemaNameDB -> Text +escapeES entityName schemaName = case schemaName of + Nothing -> escapeE entityName + Just schema -> escapeS schema <> "." <> escapeE entityName + -- | Information required to connect to a PostgreSQL database -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withPostgresqlPool'. @@ -1563,12 +1579,13 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do (errs, _) -> return $ Left errs where name = getEntityDBName entity + schema = getEntitySchema entity migrationText exists' old'' = if not exists' then createText newcols fdefs udspair else let (acs, ats) = getAlters allDefs entity (newcols, udspair) old' - acs' = map (AlterColumn name) acs - ats' = map (AlterTable name) ats + acs' = map (AlterColumn name schema) acs + ats' = map (AlterTable name schema) ats in acs' ++ ats' where old' = partitionEithers old'' @@ -1582,7 +1599,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do (addTable newcols entity) : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] + [AlterTable name schema $ AddUniqueConstraint uname ucols] references = mapMaybe (\Column { cName, cReference } -> @@ -2065,4 +2082,3 @@ instance (PersistUniqueWrite b) => PersistUniqueWrite (RawPostgresql b) where upsertBy uniq rec = withReaderT persistentBackend . upsertBy uniq rec putMany = withReaderT persistentBackend . putMany #endif - diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index ce817b216..a55eba514 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -1392,6 +1392,8 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName + , foreignRefSchemaName = + SchemaNameDB $ psToDBName ps refSchemaName , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index c8e099fee..17d018ff6 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -161,8 +161,8 @@ mkColumns allDefs t overrides = mkColumnReference :: FieldDef -> Maybe ColumnReference mkColumnReference fd = fmap - (\(tName, cName) -> - ColumnReference tName cName $ overrideNothings $ fieldCascade fd + (\(tName, sName, cName) -> + ColumnReference tName sName cName $ overrideNothings $ fieldCascade fd ) $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) @@ -178,20 +178,21 @@ mkColumns allDefs t overrides = ref :: FieldNameDB -> ReferenceDef -> [FieldAttr] - -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name - ref c fe [] - | ForeignRef f <- fe = - Just (resolveTableName allDefs f, refNameFn tableName c) - | otherwise = Nothing - ref _ _ (FieldAttrNoreference:_) = Nothing - ref c fe (a:as) = case a of - FieldAttrReference x -> do - (_, constraintName) <- ref c fe as - pure (EntityNameDB x, constraintName) - FieldAttrConstraint x -> do - (tableName_, _) <- ref c fe as - pure (tableName_, ConstraintNameDB x) - _ -> ref c fe as + -> Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB) -- table name, schema name, constraint name + ref = undefined + -- ref c fe [] + -- | ForeignRef f <- fe = + -- Just (resolveTableName allDefs f, refNameFn tableName c) + -- | otherwise = Nothing + -- ref _ _ (FieldAttrNoreference:_) = Nothing + -- ref c fe (a:as) = case a of + -- FieldAttrReference x -> do + -- (_, constraintName) <- ref c fe as + -- pure (EntityNameDB x, constraintName) + -- FieldAttrConstraint x -> do + -- (tableName_, _) <- ref c fe as + -- pure (tableName_, ConstraintNameDB x) + -- _ -> ref c fe as refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB refName (EntityNameDB table) (FieldNameDB column) = diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index a9f592d86..f2fe2e18d 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -39,6 +39,7 @@ data ColumnReference = ColumnReference -- ^ The table name that the -- -- @since 2.11.0.0 + , crSchemaName :: !(Maybe SchemaNameDB) , crConstraintName :: !ConstraintNameDB -- ^ The name of the foreign key constraint. -- @@ -137,4 +138,3 @@ defaultConnectionPoolConfig = ConnectionPoolConfig 1 600 10 -- processing). newtype Single a = Single {unSingle :: a} deriving (Eq, Ord, Show, Read) - diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index e7f88d353..b92f9eeac 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -554,6 +554,7 @@ type ForeignFieldDef = (FieldNameHS, FieldNameDB) data ForeignDef = ForeignDef { foreignRefTableHaskell :: !EntityNameHS , foreignRefTableDBName :: !EntityNameDB + , foreignRefSchemaName :: !SchemaNameDB , foreignConstraintNameHaskell :: !ConstraintNameHS , foreignConstraintNameDBName :: !ConstraintNameDB , foreignFieldCascade :: !FieldCascade From 604824257adf24252712fdf71fbd45770abd790c Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 11:51:18 -0400 Subject: [PATCH 11/58] save wip --- .../Database/Persist/Postgresql.hs | 15 +++++++++++---- persistent/Database/Persist/Quasi/Internal.hs | 4 ++-- persistent/Database/Persist/Types/Base.hs | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 4c7992c54..a2cbeef61 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -700,7 +700,7 @@ mkForeignAlt entity fdef = pure $ AlterColumn tableName_ schemaName_ addReferenc addReference = AddReference (foreignRefTableDBName fdef) - (foreignRefSchemaName fdef) + (foreignRefSchemaDBName fdef) constraintName childfields escapedParentFields @@ -977,7 +977,7 @@ getColumn getter tableName' [ PersistText columnName , cGenerated = fmap stripSuffixes generationExpression' , cDefaultConstraintName = Nothing , cMaxLen = Nothing - , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref + , cReference = fmap (\(a,b,c,d,e) -> ColumnReference a b c (mkCascade d e)) ref } where @@ -1015,8 +1015,13 @@ getColumn getter tableName' [ PersistText columnName Nothing -> loop' ps Just t' -> t' + getRef + :: FieldNameDB + -> (a, ConstraintNameDB) + -> IO (Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB, Text, Text)) getRef cname (_, refName') = do let sql = T.concat + -- TODO @curran: select table schema [ "SELECT DISTINCT " , "ccu.table_name, " , "tc.constraint_name, " @@ -1048,8 +1053,10 @@ getColumn getter tableName' [ PersistText columnName case cntrs of [] -> return Nothing - [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] -> - return $ Just (EntityNameDB table, ConstraintNameDB constraint, updRule, delRule) + [[PersistText table, PersistText schema, PersistText constraint, PersistText updRule, PersistText delRule]] -> + return . Just $ if schema == "public" + then (EntityNameDB table, Nothing, ConstraintNameDB constraint, updRule, delRule) + else (EntityNameDB table, Just (SchemaNameDB schema), ConstraintNameDB constraint, updRule, delRule) xs -> error $ mconcat [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index a55eba514..749b48c72 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -1392,8 +1392,8 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - , foreignRefSchemaName = - SchemaNameDB $ psToDBName ps refSchemaName + , -- TODO: verify that this is correct. + foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index b92f9eeac..e802b1fac 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -554,7 +554,7 @@ type ForeignFieldDef = (FieldNameHS, FieldNameDB) data ForeignDef = ForeignDef { foreignRefTableHaskell :: !EntityNameHS , foreignRefTableDBName :: !EntityNameDB - , foreignRefSchemaName :: !SchemaNameDB + , foreignRefSchemaDBName :: !(Maybe SchemaNameDB) , foreignConstraintNameHaskell :: !ConstraintNameHS , foreignConstraintNameDBName :: !ConstraintNameDB , foreignFieldCascade :: !FieldCascade From b079be26eefd1985adb0ba4003b40f40880797dd Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 12:06:17 -0400 Subject: [PATCH 12/58] add schema lookups to foreign key lookup --- persistent/Database/Persist/Sql/Internal.hs | 32 ++++++++++----------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 17d018ff6..22bf143cd 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -179,27 +179,27 @@ mkColumns allDefs t overrides = -> ReferenceDef -> [FieldAttr] -> Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB) -- table name, schema name, constraint name - ref = undefined - -- ref c fe [] - -- | ForeignRef f <- fe = - -- Just (resolveTableName allDefs f, refNameFn tableName c) - -- | otherwise = Nothing - -- ref _ _ (FieldAttrNoreference:_) = Nothing - -- ref c fe (a:as) = case a of - -- FieldAttrReference x -> do - -- (_, constraintName) <- ref c fe as - -- pure (EntityNameDB x, constraintName) - -- FieldAttrConstraint x -> do - -- (tableName_, _) <- ref c fe as - -- pure (tableName_, ConstraintNameDB x) - -- _ -> ref c fe as + ref c fe [] + | ForeignRef f <- fe = + let (table, schema) = resolveTableName allDefs f + in Just (table, schema, refNameFn tableName c) + | otherwise = Nothing + ref _ _ (FieldAttrNoreference:_) = Nothing + ref c fe (a:as) = case a of + FieldAttrReference x -> do + (_, schema, constraintName) <- ref c fe as + pure (EntityNameDB x, schema, constraintName) + FieldAttrConstraint x -> do + (tableName_, schema, _) <- ref c fe as + pure (tableName_, schema, ConstraintNameDB x) + _ -> ref c fe as refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB refName (EntityNameDB table) (FieldNameDB column) = ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"] -resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB +resolveTableName :: [EntityDef] -> EntityNameHS -> (EntityNameDB, Maybe SchemaNameDB) resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t resolveTableName (e:es) hn - | getEntityHaskellName e == hn = getEntityDBName e + | getEntityHaskellName e == hn = (getEntityDBName e, getEntitySchema e) | otherwise = resolveTableName es hn From ce4eb39a5406c0edbc8f2948fdfda7f5a274f081 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 12:26:36 -0400 Subject: [PATCH 13/58] add schema to information_schema query --- .../Database/Persist/Postgresql.hs | 30 +++++++++++-------- 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index a2cbeef61..3066eda1b 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -868,7 +868,7 @@ getColumns getter def cols = do $ groupBy ((==) `on` fst) rows processColumns = CL.mapM $ \x'@((PersistText cname) : _) -> do - col <- liftIO $ getColumn getter (getEntityDBName def) x' (Map.lookup cname refMap) + col <- liftIO $ getColumn getter (getEntityDBName def) (getEntitySchema def) x' (Map.lookup cname refMap) pure $ case col of Left e -> Left e Right c -> Right $ Left c @@ -926,18 +926,22 @@ getAlters defs def (c1, u1) (c2, u2) = getColumn :: (Text -> IO Statement) -> EntityNameDB + -> Maybe SchemaNameDB -> [PersistValue] -> Maybe (EntityNameDB, ConstraintNameDB) -> IO (Either Text Column) -getColumn getter tableName' [ PersistText columnName - , PersistText isNullable - , PersistText typeName - , defaultValue - , generationExpression - , numericPrecision - , numericScale - , maxlen - ] refName_ = runExceptT $ do +getColumn getter + tableName' + schemaName' + [ PersistText columnName + , PersistText isNullable + , PersistText typeName + , defaultValue + , generationExpression + , numericPrecision + , numericScale + , maxlen + ] refName_ = runExceptT $ do defaultValue' <- case defaultValue of PersistNull -> @@ -1021,9 +1025,9 @@ getColumn getter tableName' [ PersistText columnName -> IO (Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB, Text, Text)) getRef cname (_, refName') = do let sql = T.concat - -- TODO @curran: select table schema [ "SELECT DISTINCT " , "ccu.table_name, " + , "ccu.table_schema, " , "tc.constraint_name, " , "rc.update_rule, " , "rc.delete_rule " @@ -1037,6 +1041,7 @@ getColumn getter tableName' [ PersistText columnName , "WHERE tc.constraint_type='FOREIGN KEY' " , "AND kcu.ordinal_position=1 " , "AND kcu.table_name=? " + , "AND kcu.table_schema=? " , "AND kcu.column_name=? " , "AND tc.constraint_name=?" ] @@ -1045,6 +1050,7 @@ getColumn getter tableName' [ PersistText columnName with (stmtQuery stmt [ PersistText $ unEntityNameDB tableName' + , PersistText $ fromMaybe "public" $ unSchemaNameDB <$> schemaName' , PersistText $ unFieldNameDB cname , PersistText $ unConstraintNameDB refName' ] @@ -1108,7 +1114,7 @@ getColumn getter tableName' [ PersistText columnName , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] -getColumn _ _ columnName _ = +getColumn _ _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName -- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer From 1f8940d26f9a28594c81b0cef21158103cc5db6f Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 12:32:49 -0400 Subject: [PATCH 14/58] change decisions about how to handle the public schema --- persistent-postgresql/Database/Persist/Postgresql.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 3066eda1b..0c91abf62 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -981,7 +981,11 @@ getColumn getter , cGenerated = fmap stripSuffixes generationExpression' , cDefaultConstraintName = Nothing , cMaxLen = Nothing - , cReference = fmap (\(a,b,c,d,e) -> ColumnReference a b c (mkCascade d e)) ref + , -- The ColumnReference always has a non-null SchemaNameDB. The default schema name + -- in Postgres is "public", but Postgres doesn't know whether a table with + -- schema "public" was explicitly given that schema by the Persistent + -- app developer. + cReference = fmap (\(a,b,c,d,e) -> ColumnReference a (Just b) c (mkCascade d e)) ref } where @@ -1022,7 +1026,7 @@ getColumn getter getRef :: FieldNameDB -> (a, ConstraintNameDB) - -> IO (Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB, Text, Text)) + -> IO (Maybe (EntityNameDB, SchemaNameDB, ConstraintNameDB, Text, Text)) getRef cname (_, refName') = do let sql = T.concat [ "SELECT DISTINCT " @@ -1060,9 +1064,7 @@ getColumn getter [] -> return Nothing [[PersistText table, PersistText schema, PersistText constraint, PersistText updRule, PersistText delRule]] -> - return . Just $ if schema == "public" - then (EntityNameDB table, Nothing, ConstraintNameDB constraint, updRule, delRule) - else (EntityNameDB table, Just (SchemaNameDB schema), ConstraintNameDB constraint, updRule, delRule) + return $ Just (EntityNameDB table, SchemaNameDB schema, ConstraintNameDB constraint, updRule, delRule) xs -> error $ mconcat [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " From 4b37e1e264e684d4e5a33461d9da7dc977b4a231 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 12:48:41 -0400 Subject: [PATCH 15/58] delete accidental hardcoding of foo schema --- persistent/Database/Persist/Quasi/Internal.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 749b48c72..9e418c4f3 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -1392,8 +1392,14 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - , -- TODO: verify that this is correct. - foreignRefSchemaDBName = Nothing + , -- TODO: The existing foreign key syntax for + -- UnboundForeignDef is not sufficiently rich to + -- allow specifying the schema of the foreign + -- relation. We need to add the ability to parse + -- schema=foo directives inline for foreign keys + -- and insert those values here. + foreignRefSchemaDBName = + Nothing , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = From 91f56b4db950fa591a068d8f89a68a2327bbc3d4 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 15:03:56 -0400 Subject: [PATCH 16/58] update migrater --- .../Database/Persist/Postgresql.hs | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 0c91abf62..75b322faa 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -626,14 +626,16 @@ withStmt' conn query vals = doesTableExist :: (Text -> IO Statement) -> EntityNameDB + -> (Maybe SchemaNameDB) -> IO Bool -doesTableExist getter (EntityNameDB name) = do +doesTableExist getter (EntityNameDB name) mSchema = do stmt <- getter sql with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) where - sql = "SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" - <> " AND schemaname != 'information_schema' AND tablename=?" - vals = [PersistText name] + schema = maybe "public" escapeS mSchema + sql = "SELECT COUNT(*) FROM pg_catalog.pg_tables " + <> "WHERE tablename=? AND schemaname=?" + vals = [PersistText name, PersistText schema] start = await >>= maybe (error "No results when checking doesTableExist") start' start' [PersistInt64 0] = finish False @@ -651,7 +653,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do ([], old'') -> do exists' <- if null old - then doesTableExist getter name + then doesTableExist getter name schema else return True return $ Right $ migrationText exists' old'' (errs, _) -> return $ Left errs @@ -714,7 +716,13 @@ mkForeignAlt entity fdef = pure $ AlterColumn tableName_ schemaName_ addReferenc addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = - AddTable $ T.concat + AddTable $ T.concat $ + case schema of + Nothing -> stmt + -- Lower case e: see Database.Persist.Sql.Migration + Just s -> "CREATe SCHEMA IF NOT EXISTS " <> s <> ";\n" : stmt + where + stmt = -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! , entityIdentifier entity @@ -724,7 +732,6 @@ addTable cols entity = , T.intercalate "," $ map showColumn nonIdCols , ")" ] - where nonIdCols = case entityPrimary entity of Just _ -> @@ -738,6 +745,8 @@ addTable cols entity = name = getEntityDBName entity + schema = + escapeS <$> getEntitySchema entity idtxt = case getEntityId entity of EntityIdNaturalKey pdef -> From 799b58d4b224f079dde1b0d6311b752292fb8d76 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 15:47:20 -0400 Subject: [PATCH 17/58] update sqlQQ test to consider a case with a schema --- persistent-qq/test/PersistentTestModels.hs | 7 +++++++ persistent-qq/test/Spec.hs | 12 ++++++++++++ 2 files changed, 19 insertions(+) diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs index 5b256cdfc..acdf94f36 100644 --- a/persistent-qq/test/PersistentTestModels.hs +++ b/persistent-qq/test/PersistentTestModels.hs @@ -110,11 +110,17 @@ share ~no Int def Int + PetAnimal schema=animals + ownerId PersonId + name Text |] deriving instance Show (BackendKey backend) => Show (PetGeneric backend) deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) +deriving instance Show (BackendKey backend) => Show (PetAnimalGeneric backend) +deriving instance Eq (BackendKey backend) => Eq (PetAnimalGeneric backend) + share [ mkPersist sqlSettings { mpsPrefixFields = False, mpsGeneric = True } , mkMigrate "noPrefixMigrate" ] [persistLowerCase| @@ -178,3 +184,4 @@ cleanDB = do deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) deleteWhere ([] :: [Filter (UserPTGeneric backend)]) deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) + deleteWhere ([] :: [Filter (PetAnimalGeneric backend)]) diff --git a/persistent-qq/test/Spec.hs b/persistent-qq/test/Spec.hs index 315a15bf7..644bca3af 100644 --- a/persistent-qq/test/Spec.hs +++ b/persistent-qq/test/Spec.hs @@ -115,6 +115,18 @@ spec = describe "persistent-qq" $ do liftIO $ ret1 @?= [Entity p1k p1] liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey p1k) (RFO p1)] + it "sqlQQ/entity in schema" $ db $ do + let person = Person "Zacarias" 93 Nothing + personKey <- insert person + let pet = PetAnimal personKey "Fluffy" + petKey <- insert pet + let runQuery + :: (RawSql a, Functor m, MonadIO m) + => ReaderT SqlBackend m [a] + runQuery = [sqlQQ| SELECT ?? FROM ^{PetAnimal} |] + ret <- runQuery + liftIO $ ret @?= [Entity petKey pet] + it "sqlQQ/OUTER JOIN" $ db $ do let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m, SafeToInsert val) => val -> ReaderT backend m (Key val, val) From 62ed27232c34464fb95e650a0a99ed67d19fb7cf Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Wed, 2 Oct 2024 17:09:18 -0400 Subject: [PATCH 18/58] strengthen test --- persistent-qq/test/Spec.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/persistent-qq/test/Spec.hs b/persistent-qq/test/Spec.hs index 644bca3af..b075d0194 100644 --- a/persistent-qq/test/Spec.hs +++ b/persistent-qq/test/Spec.hs @@ -120,12 +120,15 @@ spec = describe "persistent-qq" $ do personKey <- insert person let pet = PetAnimal personKey "Fluffy" petKey <- insert pet - let runQuery + let runQueryQuoted, runQueryRaw :: (RawSql a, Functor m, MonadIO m) => ReaderT SqlBackend m [a] - runQuery = [sqlQQ| SELECT ?? FROM ^{PetAnimal} |] - ret <- runQuery - liftIO $ ret @?= [Entity petKey pet] + runQueryQuoted = [sqlQQ| SELECT ?? FROM ^{PetAnimal} |] + runQueryRaw = [sqlQQ| SELECT ?? FROM animals.pet_animal |] + retQuoted <- runQueryQuoted + retRaw <- runQueryRaw + liftIO $ retQuoted @?= [Entity petKey pet] + liftIO $ retRaw @?= [Entity petKey pet] it "sqlQQ/OUTER JOIN" $ db $ do let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m, SafeToInsert val) From 170450b1473a303f043237788dc32b41586b1a61 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 15:13:51 -0400 Subject: [PATCH 19/58] add schema to sqlite expressions --- persistent-sqlite/Database/Persist/Sqlite.hs | 43 ++++++++++++-------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 9deddbd28..be2891b29 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -369,7 +369,7 @@ insertSql' ent vals = ISRManyKeys sql vals where sql = T.concat [ "INSERT INTO " - , escapeE $ getEntityDBName ent + , entityIdentifier ent , "(" , T.intercalate "," $ map (escapeF . fieldDB) cols , ") VALUES(" @@ -383,12 +383,12 @@ insertSql' ent vals = [ "SELECT " , escapeF $ fieldDB fd , " FROM " - , escapeE $ getEntityDBName ent + , entityIdentifier ent , " WHERE _ROWID_=last_insert_rowid()" ] ins = T.concat [ "INSERT INTO " - , escapeE $ getEntityDBName ent + , entityIdentifier ent , if null cols then " VALUES(null)" else T.concat @@ -539,7 +539,7 @@ getCopyTable :: [EntityDef] -> EntityDef -> IO [(Bool, Text)] getCopyTable allDefs getter def = do - stmt <- getter $ T.concat [ "PRAGMA table_info(", escapeE table, ")" ] + stmt <- getter $ T.concat [ "PRAGMA table_info(", entityIdentifier def, ")" ] oldCols' <- with (stmtQuery stmt []) (\src -> runConduit $ src .| getCols) let oldCols = map FieldNameDB oldCols' let newCols = filter (not . safeToRemove def) $ map cName cols @@ -561,30 +561,32 @@ getCopyTable allDefs getter def = do return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y table = getEntityDBName def + tableIdentifier = entityIdentifier def tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" + tableTmpIdentifier = escapeES tableTmp (getEntitySchema def) (cols, uniqs, fdef) = sqliteMkColumns allDefs def cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs, fdef) tmpSql = mkCreateTable True (setEntityDBName tableTmp def) (cols', uniqs, []) - dropTmp = "DROP TABLE " <> escapeE tableTmp - dropOld = "DROP TABLE " <> escapeE table + dropTmp = "DROP TABLE " <> tableTmpIdentifier + dropOld = "DROP TABLE " <> tableIdentifier copyToTemp common = T.concat [ "INSERT INTO " - , escapeE tableTmp + , tableTmpIdentifier , "(" , T.intercalate "," $ map escapeF common , ") SELECT " , T.intercalate "," $ map escapeF common , " FROM " - , escapeE table + , tableIdentifier ] copyToFinal newCols = T.concat [ "INSERT INTO " - , escapeE table + , tableIdentifier , " SELECT " , T.intercalate "," $ map escapeF newCols , " FROM " - , escapeE tableTmp + , tableTmpIdentifier ] mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text @@ -595,7 +597,7 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) = [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE " - , escapeE $ getEntityDBName entity + , entityIdentifier entity , "(" ] @@ -646,8 +648,8 @@ sqlColumn noRef (Column name isNull typ def gen _cn _maxLen ref) = T.concat , mayGenerated gen , case ref of Nothing -> "" - Just ColumnReference {crTableName=table, crFieldCascade=cascadeOpts} -> - if noRef then "" else " REFERENCES " <> escapeE table + Just ColumnReference {crTableName=table, crSchemaName=schema, crFieldCascade=cascadeOpts} -> + if noRef then "" else " REFERENCES " <> escapeES table schema <> onDelete cascadeOpts <> onUpdate cascadeOpts ] where @@ -661,7 +663,7 @@ sqlForeign fdef = T.concat $ , " FOREIGN KEY(" , T.intercalate "," $ map (escapeF . snd. fst) $ foreignFields fdef , ") REFERENCES " - , escapeE $ foreignRefTableDBName fdef + , escapeES (foreignRefTableDBName fdef) (foreignRefSchemaDBName fdef) , "(" , T.intercalate "," $ map (escapeF . snd . snd) $ foreignFields fdef , ")" @@ -695,6 +697,13 @@ escapeC = escapeWith escape escapeE :: EntityNameDB -> Text escapeE = escapeWith escape +escapeS :: SchemaNameDB -> Text +escapeS = escapeWith escape + +escapeES :: EntityNameDB -> Maybe SchemaNameDB -> Text +escapeES entity Nothing = escapeE entity +escapeES entity (Just schema) = escapeS schema <> "." <> escapeE entity + escapeF :: FieldNameDB -> Text escapeF = escapeWith escape @@ -706,6 +715,9 @@ escape s = go '"' = "\"\"" go c = T.singleton c +entityIdentifier :: EntityDef -> Text +entityIdentifier entity = escapeES (getEntityDBName entity) (getEntitySchema entity) + putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns (toList fields) ent n where @@ -724,14 +736,13 @@ putManySql' conflictColumns fields ent n = q fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escapeE . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields q = T.concat [ "INSERT INTO " - , table + , entityIdentifier ent , Util.parenWrapped columns , " VALUES " , Util.commaSeparated . replicate n From 1ec4ca7cbb3a2c25744cd65a6e612286efc80288 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 15:16:05 -0400 Subject: [PATCH 20/58] add schema test --- persistent-sqlite/test/main.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 96234efcd..46d805e59 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -44,6 +44,7 @@ import qualified RawSqlTest import qualified ReadWriteTest import qualified Recursive import qualified RenameTest +import qualified SchemaTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified TypeLitFieldDefsTest @@ -176,6 +177,7 @@ main = do , MigrationColumnLengthTest.migration , TransactionLevelTest.migration , LongIdentifierTest.migration + , SchemaTest.migration ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -244,6 +246,7 @@ main = do MigrationTest.specsWith db LongIdentifierTest.specsWith db GeneratedColumnTestSQL.specsWith db + SchemaTest.specsWith db it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do void $ runMigrationSilent migrateAll From 309ce8ba8aa501e539729a8dc108c04432580af2 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 16:41:07 -0400 Subject: [PATCH 21/58] set up migrations and queries for sqlite, improve test --- persistent-sqlite/Database/Persist/Sqlite.hs | 8 +++++--- persistent-sqlite/test/SqliteInit.hs | 5 ++++- persistent-sqlite/test/main.hs | 5 +++++ persistent-test/src/SchemaTest.hs | 8 +++++--- 4 files changed, 19 insertions(+), 7 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index be2891b29..51bface46 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -310,7 +310,7 @@ wrapConnectionInfo connInfo conn logFunc = do , connCommit = helper "COMMIT" , connRollback = ignoreExceptions . helper "ROLLBACK" , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . getEntityDBName + , connEscapeTableName = entityIdentifier , connEscapeRawName = escape , connNoLimit = "LIMIT -1" , connRDBMS = "sqlite" @@ -456,7 +456,7 @@ migrate' migrate' allDefs getter val = do let (cols, uniqs, fdefs) = sqliteMkColumns allDefs val let newSql = mkCreateTable False def (filter (not . safeToRemove val . cName) cols, uniqs, fdefs) - stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?" + stmt <- getter $ "SELECT sql FROM " <> sqliteMaster <> " WHERE type='table' AND name=?" oldSql' <- with (stmtQuery stmt [PersistText $ unEntityNameDB table]) (\src -> runConduit $ src .| go) case oldSql' of @@ -470,6 +470,8 @@ migrate' allDefs getter val = do where def = val table = getEntityDBName def + schema = getEntitySchema def + sqliteMaster = maybe "sqlite_master" (\schema' -> escapeS schema' <> ".sqlite_master") schema go = do x <- CL.head case x of @@ -501,7 +503,7 @@ mockMigration mig = do , connCommit = helper "COMMIT" , connRollback = ignoreExceptions . helper "ROLLBACK" , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . getEntityDBName + , connEscapeTableName = entityIdentifier , connEscapeRawName = escape , connNoLimit = "LIMIT -1" , connRDBMS = "sqlite" diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 2c54ec8bd..ccb787c07 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -16,6 +16,7 @@ module SqliteInit ( , db , sqlite_database , sqlite_database_file + , sqlite_foo_database_file , BackendKey(..) , GenerateKey(..) @@ -90,6 +91,9 @@ type BackendMonad = SqlBackend sqlite_database_file :: Text sqlite_database_file = "testdb.sqlite3" +sqlite_foo_database_file :: Text +sqlite_foo_database_file = "testdb-foo.sqlite3" + sqlite_database :: SqliteConnectionInfo sqlite_database = mkSqliteConnectionInfo sqlite_database_file @@ -104,4 +108,3 @@ runConn f = do db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do runResourceT $ runConn $ actions >> transactionUndo - diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 46d805e59..30e2eb105 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -152,6 +153,9 @@ main :: IO () main = do handle (\(_ :: IOException) -> return ()) $ removeFile $ fromText sqlite_database_file + handle (\(_ :: IOException) -> return ()) + $ removeFile $ fromText sqlite_foo_database_file + runConn $ rawSql @(Single Int64) ("attach '" <> sqlite_foo_database_file <> "' as foo") [] runConn $ do mapM_ setup @@ -178,6 +182,7 @@ main = do , TransactionLevelTest.migration , LongIdentifierTest.migration , SchemaTest.migration + , SchemaTest.migration ] PersistentTest.cleanDB ForeignKey.cleanDB diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs index f51492db8..c340b3720 100644 --- a/persistent-test/src/SchemaTest.hs +++ b/persistent-test/src/SchemaTest.hs @@ -23,8 +23,8 @@ cleanDB cleanDB = deleteWhere ([] :: [Filter (SchemaEntityGeneric backend)]) specsWith - :: Runner backend m - => RunDb backend m + :: Runner SqlBackend m + => RunDb SqlBackend m -> Spec specsWith runConn = describe "entity with non-null schema" $ it "inserts and selects work as expected" $ asIO $ runConn $ do @@ -33,5 +33,7 @@ specsWith runConn = describe "entity with non-null schema" $ SchemaEntity { schemaEntityFoo = 42 } - Just _ <- get x + Just schemaEntity <- get x + rawFoo <- rawSql "SELECT foo FROM foo.schema_entity" [] + liftIO $ rawFoo @?= [Single (42 :: Int)] return () From 5d0b4f0de370f96552b055d9b242d3ea58e7550d Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 14:53:12 -0500 Subject: [PATCH 22/58] include schema in qq parse --- persistent/Database/Persist/Quasi/Internal.hs | 14 ++++++-------- persistent/test/Database/Persist/QuasiSpec.hs | 10 ++++++++-- persistent/test/Database/Persist/THSpec.hs | 6 +++--- 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 9e418c4f3..a47ee9ff1 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -310,6 +310,7 @@ parseLines ps = do data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefSchemaName :: Maybe SchemaNameDB , parsedEntityDefIsSum :: Bool , parsedEntityDefEntityAttributes :: [Attr] , parsedEntityDefFieldAttributes :: [[Token]] @@ -329,6 +330,7 @@ toParsedEntityDef :: LinesWithComments -> ParsedEntityDef toParsedEntityDef lwc = ParsedEntityDef { parsedEntityDefComments = lwcComments lwc , parsedEntityDefEntityName = entNameHS + , parsedEntityDefSchemaName = schemaName , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entAttribs , parsedEntityDefFieldAttributes = attribs @@ -349,6 +351,9 @@ toParsedEntityDef lwc = ParsedEntityDef (attribs, extras) = parseEntityFields fieldLines + schemaName = + fmap SchemaNameDB $ listToMaybe $ mapMaybe (T.stripPrefix "schema=") entAttribs + isDocComment :: Token -> Maybe Text isDocComment tok = case tok of @@ -712,8 +717,7 @@ mkUnboundEntityDef ps parsedEntDef = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) - , -- TODO: start parsing the schema attribute and write it here. - entitySchema = Nothing + , entitySchema = parsedEntityDefSchemaName parsedEntDef } } where @@ -1392,12 +1396,6 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - , -- TODO: The existing foreign key syntax for - -- UnboundForeignDef is not sufficiently rich to - -- allow specifying the schema of the foreign - -- relation. We need to add the ability to parse - -- schema=foo directives inline for foreign keys - -- and insert those values here. foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 02356ee9f..1954ced30 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -258,7 +258,7 @@ Bicycle -- | this is a bike baz deriving Eq -- | This is a Car -Car +Car schema=transportation -- | the make of the Car make String -- | the model of the Car @@ -284,9 +284,14 @@ Car it "should parse the `entityAttrs` field" $ do entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` [] + entityAttrs (unboundEntityDef car) `shouldBe` ["schema=transportation"] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] + it "should parse the `entitySchema` field" $ do + entitySchema (unboundEntityDef bicycle) `shouldBe` Nothing + entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") + entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing + it "should parse the `unboundEntityFields` field" $ do let simplifyField field = (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) @@ -332,6 +337,7 @@ Notification [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" + , foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" , foreignFieldCascade = FieldCascade Nothing Nothing diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index cfba70c6b..19abd878a 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -85,7 +85,7 @@ Person json address Address deriving Show Eq -HasSimpleCascadeRef +HasSimpleCascadeRef schema=cascade person PersonId OnDeleteCascade deriving Show Eq @@ -346,7 +346,7 @@ spec = describe "THSpec" $ do , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } - , entityAttrs = [] + , entityAttrs = ["schema=cascade"] , entityFields = [ FieldDef { fieldHaskell = FieldNameHS "person" @@ -371,7 +371,7 @@ spec = describe "THSpec" $ do , entityExtra = mempty , entitySum = False , entityComments = Nothing - , entitySchema = Nothing + , entitySchema = Just $ SchemaNameDB "cascade" } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected From e48552bcc0e7c2d4ca08641ace798a0a53ee65fc Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 22:08:12 -0500 Subject: [PATCH 23/58] include schema name in foreign def --- persistent/Database/Persist/Quasi/Internal.hs | 33 +++++++++++++------ persistent/test/Database/Persist/QuasiSpec.hs | 20 +++++------ 2 files changed, 33 insertions(+), 20 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index a47ee9ff1..46eef2b00 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -59,7 +59,7 @@ import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, isJust, listToMaybe, mapMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -1382,11 +1382,11 @@ takeForeign ps entityName = takeRefTable takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" takeRefTable (refTableName:restLine) = - go restLine Nothing Nothing + go restLine Nothing Nothing Nothing where - go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (constraintNameText:rest) onDelete onUpdate - | not (T.null constraintNameText) && isLower (T.head constraintNameText) = + go :: [Text] -> Maybe SchemaNameDB -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (constraintNameText:rest) schemaName onDelete onUpdate + | isConstraintName = UnboundForeignDef { unboundForeignFields = either error id $ mkUnboundForeignFieldList foreignFields parentFields @@ -1418,6 +1418,10 @@ takeForeign ps entityName = takeRefTable } } where + isConstraintName = not (T.null constraintNameText) + && isLower (T.head constraintNameText) + && isNothing (parseSchemaName constraintNameText) + constraintName = ConstraintNameHS constraintNameText @@ -1439,21 +1443,30 @@ takeForeign ps entityName = takeRefTable , show plen, " parent fields" ] - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + go ((parseSchemaName -> Just schemaName) : rest) schemaName' onDelete onUpdate + | isJust schemaName' = error $ errorPrefix ++ "found more than one schema definition" + | otherwise = go rest (Just schemaName) onDelete onUpdate + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) schemaName onDelete' onUpdate = case onDelete' of Nothing -> - go rest (Just cascadingAction) onUpdate + go rest schemaName (Just cascadingAction) onUpdate Just _ -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) schemaName onDelete onUpdate' = case onUpdate' of Nothing -> - go rest onDelete (Just cascadingAction) + go rest schemaName onDelete (Just cascadingAction) Just _ -> error $ errorPrefix ++ "found more than one OnUpdate actions" - go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs + go xs _ _ _ = error $ errorPrefix ++ "expecting a lower case constraint name, schema name, or a cascading action xs=" ++ show xs + +parseSchemaName :: Text -> Maybe SchemaNameDB +parseSchemaName schemaNameText + | ["", schemaName] <- T.splitOn "schema=" schemaNameText = Just $ SchemaNameDB schemaName + | otherwise = Nothing toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 1954ced30..db6f1d0c6 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -251,14 +251,14 @@ spec = describe "Quasi" $ do describe "parse" $ do let subject = [st| -Bicycle -- | this is a bike +Bicycle schema=transportation -- | this is a bike brand String -- | the brand of the bike ExtraBike foo bar -- | this is a foo bar baz deriving Eq -- | This is a Car -Car schema=transportation +Car sql=auto schema=transportation -- | the make of the Car make String -- | the model of the Car @@ -279,16 +279,16 @@ Car schema=transportation it "should parse the `entityDB` field" $ do entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle" - entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car" + entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "auto" entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" it "should parse the `entityAttrs` field" $ do - entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` ["schema=transportation"] + entityAttrs (unboundEntityDef bicycle) `shouldBe` ["schema=transportation", "-- | this is a bike"] + entityAttrs (unboundEntityDef car) `shouldBe` ["sql=auto", "schema=transportation"] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] it "should parse the `entitySchema` field" $ do - entitySchema (unboundEntityDef bicycle) `shouldBe` Nothing + entitySchema (unboundEntityDef bicycle) `shouldBe` (Just $ SchemaNameDB "transportation") entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing @@ -330,17 +330,17 @@ Notification sentToFirst Text sentToSecond Text - Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond + Foreign User schema=some_schema OnDeleteCascade fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond |] unboundForeignDefs user `shouldBe` [] map unboundForeignDef (unboundForeignDefs notification) `shouldBe` [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" - , foreignRefSchemaDBName = Nothing + , foreignRefSchemaDBName = Just $ SchemaNameDB "some_schema" , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" - , foreignFieldCascade = FieldCascade Nothing Nothing + , foreignFieldCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Just Cascade} , foreignFields = [] -- the foreign fields are not set yet in an unbound @@ -587,7 +587,7 @@ Notification let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` - "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" + "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name, schema name, or a cascading action xs=[]" it "should error when foreign fields not provided" $ do let definitions = [st| From 6194a913d7f1bb44ee85807864a2044fe4d0baf4 Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 23:20:09 -0500 Subject: [PATCH 24/58] update quasi haddock --- persistent/Database/Persist/Quasi.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 451f92229..3b0cb40a5 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -186,13 +186,23 @@ User sql=big_user_table This will alter the generated SQL to be: @ -CREATE TABEL big_user_table ( +CREATE TABLE big_user_table ( id SERIAL PRIMARY KEY, name VARCHAR, age INT ); @ += Table Schema + +You can use a @schema=some_schema@ annotation to specify the table's schema name. +This can be placed before or after the entity's @sql=custom@ annotation, if it has one. + +@ +Foo schema=bar + baz Int +@ + = Customizing Types/Tables == JSON instances @@ -498,7 +508,7 @@ The above example is a "simple" foreign key. It refers directly to the Id column A pseudo formal syntax for @Foreign@ is: @ -Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +Foreign $(TargetEntity) $(schema name) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] columns := column0 [column1 column2 .. columnX] references := References $(target-columns) @@ -544,6 +554,12 @@ We can specify delete/cascade behavior directly after the target table. Now, if the email is deleted or updated, the user will be deleted or updated to match. +Schema names can be specified between the target table and the constraint name. + +@ + Foreign Email schema=some_schema OnDeleteCascade fk_user_email emailFirstPart emailSecondPart +@ + === Non-Primary Key References SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. From b04da5255dc04d732780174d2ec3aa3282e4221b Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 23:38:26 -0500 Subject: [PATCH 25/58] additional foreign schema test --- persistent/test/Database/Persist/TH/ForeignRefSpec.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index b4e694e57..dfdc230e5 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs @@ -85,7 +85,7 @@ ParentExplicit ChildExplicit name Text - Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name + Foreign ParentExplicit schema=kids OnDeleteCascade OnUpdateCascade fkparent name |] spec :: Spec @@ -102,6 +102,15 @@ spec = describe "ForeignRefSpec" $ do it "should compile" $ do True `shouldBe` True + describe "ForeignSchemaName" $ do + let + [childForeignDef] = + entityForeigns $ entityDef $ Proxy @ChildExplicit + it "should have a schema name defined" $ do + (foreignRefSchemaDBName childForeignDef) + `shouldBe` + (Just $ SchemaNameDB "kids") + describe "ForeignPrimarySource" $ do let fpsDef = From f3a0aa268ae586acace3d851d6106b35e19a2d08 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 17:20:15 -0400 Subject: [PATCH 26/58] fix tests and migration code --- persistent-sqlite/Database/Persist/Sqlite.hs | 17 +++++++++++++---- persistent-sqlite/test/SqliteInit.hs | 5 ++++- persistent-sqlite/test/main.hs | 2 -- 3 files changed, 17 insertions(+), 7 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 51bface46..87fc19a15 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -541,7 +541,7 @@ getCopyTable :: [EntityDef] -> EntityDef -> IO [(Bool, Text)] getCopyTable allDefs getter def = do - stmt <- getter $ T.concat [ "PRAGMA table_info(", entityIdentifier def, ")" ] + stmt <- getter $ T.concat [ "PRAGMA ", tableInfo, "(", escapeE table, ")" ] oldCols' <- with (stmtQuery stmt []) (\src -> runConduit $ src .| getCols) let oldCols = map FieldNameDB oldCols' let newCols = filter (not . safeToRemove def) $ map cName cols @@ -554,6 +554,9 @@ getCopyTable allDefs getter def = do , (False, dropTmp) ] where + tableInfo = case schema of + Nothing -> "table_info" + Just schema' -> escapeS schema' <> ".table_info" getCols = do x <- CL.head case x of @@ -563,13 +566,19 @@ getCopyTable allDefs getter def = do return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y table = getEntityDBName def + schema = getEntitySchema def tableIdentifier = entityIdentifier def - tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" - tableTmpIdentifier = escapeES tableTmp (getEntitySchema def) + -- Temporary tables cannot have qualified names, so we prepend + -- the name with the intended schema to provide namespacing. + tableTmp = + EntityNameDB $ T.intercalate "_" $ catMaybes [unSchemaNameDB <$> schema, Just $ unEntityNameDB table, Just "backup"] + tableTmpIdentifier = escapeE tableTmp (cols, uniqs, fdef) = sqliteMkColumns allDefs def cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs, fdef) - tmpSql = mkCreateTable True (setEntityDBName tableTmp def) (cols', uniqs, []) + -- Temporary tables cannot have qualified names, so we override + -- the schema to 'Nothing' here. + tmpSql = mkCreateTable True (setEntitySchema Nothing $ setEntityDBName tableTmp def) (cols', uniqs, []) dropTmp = "DROP TABLE " <> tableTmpIdentifier dropOld = "DROP TABLE " <> tableIdentifier copyToTemp common = T.concat diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index ccb787c07..191cd0f82 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module SqliteInit ( (@/=), (@==), (==@) @@ -103,7 +104,9 @@ runConn f = do let debugPrint = not travis && _debugOn let printDebug = if debugPrint then print . fromLogStr else void . return void $ flip runLoggingT (\_ _ _ s -> printDebug s) $ do - withSqlitePoolInfo sqlite_database 1 $ runSqlPool f + withSqlitePoolInfo sqlite_database 1 $ runSqlPool $ do + rawSql @(Single Int64) ("attach '" <> sqlite_foo_database_file <> "' as foo") [] + f db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 30e2eb105..3f67d8aa5 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -11,7 +11,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -155,7 +154,6 @@ main = do $ removeFile $ fromText sqlite_database_file handle (\(_ :: IOException) -> return ()) $ removeFile $ fromText sqlite_foo_database_file - runConn $ rawSql @(Single Int64) ("attach '" <> sqlite_foo_database_file <> "' as foo") [] runConn $ do mapM_ setup From d57084fa78b1bf0c755b941d2cafa1b28891165c Mon Sep 17 00:00:00 2001 From: ben j Date: Thu, 3 Oct 2024 16:12:36 -0500 Subject: [PATCH 27/58] defer foreign reference schema definitions to TH --- persistent/Database/Persist/Quasi.hs | 8 +---- persistent/Database/Persist/Quasi/Internal.hs | 36 +++++++------------ persistent/Database/Persist/TH.hs | 4 +++ persistent/test/Database/Persist/QuasiSpec.hs | 23 +++++------- .../Database/Persist/TH/ForeignRefSpec.hs | 23 ++++++------ persistent/test/Database/Persist/THSpec.hs | 16 ++++++--- 6 files changed, 49 insertions(+), 61 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 3b0cb40a5..e41292d6c 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -508,7 +508,7 @@ The above example is a "simple" foreign key. It refers directly to the Id column A pseudo formal syntax for @Foreign@ is: @ -Foreign $(TargetEntity) $(schema name) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] columns := column0 [column1 column2 .. columnX] references := References $(target-columns) @@ -554,12 +554,6 @@ We can specify delete/cascade behavior directly after the target table. Now, if the email is deleted or updated, the user will be deleted or updated to match. -Schema names can be specified between the target table and the constraint name. - -@ - Foreign Email schema=some_schema OnDeleteCascade fk_user_email emailFirstPart emailSecondPart -@ - === Non-Primary Key References SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 46eef2b00..330645202 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -59,7 +59,7 @@ import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe, isNothing, isJust, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -1382,11 +1382,11 @@ takeForeign ps entityName = takeRefTable takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" takeRefTable (refTableName:restLine) = - go restLine Nothing Nothing Nothing + go restLine Nothing Nothing where - go :: [Text] -> Maybe SchemaNameDB -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (constraintNameText:rest) schemaName onDelete onUpdate - | isConstraintName = + go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (constraintNameText:rest) onDelete onUpdate + | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { unboundForeignFields = either error id $ mkUnboundForeignFieldList foreignFields parentFields @@ -1396,8 +1396,9 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - foreignRefSchemaDBName = + , foreignRefSchemaDBName = Nothing + -- ^ This will be determined in the TH phase ('fixForeignRefSchemaDBName'). , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = @@ -1418,10 +1419,6 @@ takeForeign ps entityName = takeRefTable } } where - isConstraintName = not (T.null constraintNameText) - && isLower (T.head constraintNameText) - && isNothing (parseSchemaName constraintNameText) - constraintName = ConstraintNameHS constraintNameText @@ -1443,30 +1440,21 @@ takeForeign ps entityName = takeRefTable , show plen, " parent fields" ] - go ((parseSchemaName -> Just schemaName) : rest) schemaName' onDelete onUpdate - | isJust schemaName' = error $ errorPrefix ++ "found more than one schema definition" - | otherwise = go rest (Just schemaName) onDelete onUpdate - - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) schemaName onDelete' onUpdate = + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = case onDelete' of Nothing -> - go rest schemaName (Just cascadingAction) onUpdate + go rest (Just cascadingAction) onUpdate Just _ -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) schemaName onDelete onUpdate' = + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = case onUpdate' of Nothing -> - go rest schemaName onDelete (Just cascadingAction) + go rest onDelete (Just cascadingAction) Just _ -> error $ errorPrefix ++ "found more than one OnUpdate actions" - go xs _ _ _ = error $ errorPrefix ++ "expecting a lower case constraint name, schema name, or a cascading action xs=" ++ show xs - -parseSchemaName :: Text -> Maybe SchemaNameDB -parseSchemaName schemaNameText - | ["", schemaName] <- T.splitOn "schema=" schemaNameText = Just $ SchemaNameDB schemaName - | otherwise = Nothing + go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 0a2df94cc..009f0b94b 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -331,11 +331,15 @@ liftAndFixKeys mps emEntities entityMap unboundEnt = $(lift fixForeignNullable) , foreignRefTableDBName = $(lift fixForeignRefTableDBName) + , foreignRefSchemaDBName = + $(lift fixForeignRefSchemaDBName) } |] where fixForeignRefTableDBName = getEntityDBName (unboundEntityDef parentDef) + fixForeignRefSchemaDBName = + getEntitySchema (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of FieldListImpliedId ffns -> diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index db6f1d0c6..6d08fe27e 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -251,14 +251,14 @@ spec = describe "Quasi" $ do describe "parse" $ do let subject = [st| -Bicycle schema=transportation -- | this is a bike +Bicycle -- | this is a bike brand String -- | the brand of the bike ExtraBike foo bar -- | this is a foo bar baz deriving Eq -- | This is a Car -Car sql=auto schema=transportation +Car -- | the make of the Car make String -- | the model of the Car @@ -279,19 +279,14 @@ Car sql=auto schema=transportation it "should parse the `entityDB` field" $ do entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle" - entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "auto" + entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car" entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" it "should parse the `entityAttrs` field" $ do - entityAttrs (unboundEntityDef bicycle) `shouldBe` ["schema=transportation", "-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` ["sql=auto", "schema=transportation"] + entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] + entityAttrs (unboundEntityDef car) `shouldBe` [] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] - it "should parse the `entitySchema` field" $ do - entitySchema (unboundEntityDef bicycle) `shouldBe` (Just $ SchemaNameDB "transportation") - entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") - entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing - it "should parse the `unboundEntityFields` field" $ do let simplifyField field = (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) @@ -330,17 +325,17 @@ Notification sentToFirst Text sentToSecond Text - Foreign User schema=some_schema OnDeleteCascade fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond |] unboundForeignDefs user `shouldBe` [] map unboundForeignDef (unboundForeignDefs notification) `shouldBe` [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" - , foreignRefSchemaDBName = Just $ SchemaNameDB "some_schema" + , foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" - , foreignFieldCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Just Cascade} + , foreignFieldCascade = FieldCascade Nothing Nothing , foreignFields = [] -- the foreign fields are not set yet in an unbound @@ -587,7 +582,7 @@ Notification let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` - "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name, schema name, or a cascading action xs=[]" + "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" it "should error when foreign fields not provided" $ do let definitions = [st| diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index dfdc230e5..0e876076e 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs @@ -49,6 +49,7 @@ mkPersist sqlSettings [persistLowerCase| HasCustomName sql=custom_name name Text + Primary name ForeignTarget name Text @@ -79,13 +80,13 @@ ChildImplicit name Text parent ParentImplicitId OnDeleteCascade OnUpdateCascade -ParentExplicit +ParentExplicit schema=adult name Text Primary name ChildExplicit name Text - Foreign ParentExplicit schema=kids OnDeleteCascade OnUpdateCascade fkparent name + Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name |] spec :: Spec @@ -102,15 +103,6 @@ spec = describe "ForeignRefSpec" $ do it "should compile" $ do True `shouldBe` True - describe "ForeignSchemaName" $ do - let - [childForeignDef] = - entityForeigns $ entityDef $ Proxy @ChildExplicit - it "should have a schema name defined" $ do - (foreignRefSchemaDBName childForeignDef) - `shouldBe` - (Just $ SchemaNameDB "kids") - describe "ForeignPrimarySource" $ do let fpsDef = @@ -185,3 +177,12 @@ spec = describe "ForeignRefSpec" $ do , "got: " , show as ] + + describe "Foreign Schema Name" $ do + let + [childForeignDef] = + entityForeigns $ entityDef $ Proxy @ChildExplicit + it "should have the correct schema name" $ do + (foreignRefSchemaDBName childForeignDef) + `shouldBe` + (Just $ SchemaNameDB "adult") diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 19abd878a..1397f8dbe 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -71,21 +71,20 @@ import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpe import qualified Database.Persist.TH.SumSpec as SumSpec import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec - -- test to ensure we can have types ending in Id that don't trash the TH -- machinery type TextId = Text share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| -Person json +Person json schema=some_schema name Text age Int Maybe foo Foo address Address deriving Show Eq -HasSimpleCascadeRef schema=cascade +HasSimpleCascadeRef person PersonId OnDeleteCascade deriving Show Eq @@ -346,7 +345,7 @@ spec = describe "THSpec" $ do , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } - , entityAttrs = ["schema=cascade"] + , entityAttrs = [] , entityFields = [ FieldDef { fieldHaskell = FieldNameHS "person" @@ -371,7 +370,7 @@ spec = describe "THSpec" $ do , entityExtra = mempty , entitySum = False , entityComments = Nothing - , entitySchema = Just $ SchemaNameDB "cascade" + , entitySchema = Nothing } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected @@ -507,6 +506,13 @@ spec = describe "THSpec" $ do it "has a good safe to insert class instance" $ do let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName proxy `shouldBe` Proxy + describe "Entity Schema" $ do + let personDef = + entityDef (Proxy :: Proxy Person) + it "reads the entity schema" $ do + (entitySchema personDef) + `shouldBe` + (Just $ SchemaNameDB "some_schema") (&) :: a -> (a -> b) -> b x & f = f x From d098daacae6c9dc82ec1f61570d8a16cec0bcf86 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 17:58:12 -0400 Subject: [PATCH 28/58] add comment explaining limitation --- persistent-sqlite/Database/Persist/Sqlite.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 87fc19a15..f7d948352 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -659,8 +659,15 @@ sqlColumn noRef (Column name isNull typ def gen _cn _maxLen ref) = T.concat , mayGenerated gen , case ref of Nothing -> "" - Just ColumnReference {crTableName=table, crSchemaName=schema, crFieldCascade=cascadeOpts} -> - if noRef then "" else " REFERENCES " <> escapeES table schema + -- This foreign key constraint is only legitimate if it is a reference + -- within the same schema. + Just ColumnReference {crTableName=table, crFieldCascade=cascadeOpts} -> + if noRef + then "" + -- This foreign key constraint is only legitimate if it is a reference + -- within the same schema. It's a syntax error in SQLite to use a + -- dot-qualified name here, so we just escape the table name. + else " REFERENCES " <> escapeE table <> onDelete cascadeOpts <> onUpdate cascadeOpts ] where @@ -850,6 +857,7 @@ data ForeignKeyViolation = ForeignKeyViolation , foreignKeyRowId :: Int64 -- ^ The ROWID of the row with the violated foreign key constraint } deriving (Eq, Ord, Show) +-- TODO: add database qualifier here -- | Outputs all (if any) the violated foreign key constraints in the database. -- -- The main use is to validate that no foreign key constraints were From ed1642b032251da85d20503861f1f996f5ed0966 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 18:03:16 -0400 Subject: [PATCH 29/58] remove TODO --- persistent-sqlite/Database/Persist/Sqlite.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index f7d948352..bf84dbce9 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -857,7 +857,6 @@ data ForeignKeyViolation = ForeignKeyViolation , foreignKeyRowId :: Int64 -- ^ The ROWID of the row with the violated foreign key constraint } deriving (Eq, Ord, Show) --- TODO: add database qualifier here -- | Outputs all (if any) the violated foreign key constraints in the database. -- -- The main use is to validate that no foreign key constraints were From 708c0ed8d41f6f0704a9008b6e31923562d4eca0 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 18:29:53 -0400 Subject: [PATCH 30/58] consider the multi-db case --- persistent-sqlite/Database/Persist/Sqlite.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index bf84dbce9..660c6a3dd 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -881,8 +881,9 @@ checkForeignKeys = rawQuery query [] .| C.mapM parse query = T.unlines [ "SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")" - , "FROM pragma_foreign_key_check() AS origin" - , "INNER JOIN pragma_foreign_key_list(origin.\"table\") AS foreignkeys" + , "FROM pragma_database_list() as databases" + , "INNER JOIN pragma_foreign_key_check(null, databases.name) AS origin" + , "INNER JOIN pragma_foreign_key_list(origin.\"table\", databases.name) AS foreignkeys" , "ON origin.fkid = foreignkeys.id AND origin.parent = foreignkeys.\"table\"" , "GROUP BY origin.rowid" ] From 12eb34c0dc044e62669e283ae5b81a7bd0cf5570 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 18:33:25 -0400 Subject: [PATCH 31/58] reverse a spot where we can't inject dot-qualified names --- persistent-sqlite/Database/Persist/Sqlite.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 660c6a3dd..1295a8f05 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -681,7 +681,11 @@ sqlForeign fdef = T.concat $ , " FOREIGN KEY(" , T.intercalate "," $ map (escapeF . snd. fst) $ foreignFields fdef , ") REFERENCES " - , escapeES (foreignRefTableDBName fdef) (foreignRefSchemaDBName fdef) + , -- It's a syntax error in SQLite to use a dot-qualified table name. + -- In general, it's not possible for SQLite to maintain foreign key + -- constraints across databases (which Persistent calls "schemas"). + -- So we omit the schema here. + escapeE (foreignRefTableDBName fdef) , "(" , T.intercalate "," $ map (escapeF . snd . snd) $ foreignFields fdef , ")" From 649c395946a64b6e517c8040842d9c99daba278d Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 3 Oct 2024 18:35:38 -0400 Subject: [PATCH 32/58] make test stronger --- persistent-test/src/SchemaTest.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs index c340b3720..54fe32cff 100644 --- a/persistent-test/src/SchemaTest.hs +++ b/persistent-test/src/SchemaTest.hs @@ -36,4 +36,5 @@ specsWith runConn = describe "entity with non-null schema" $ Just schemaEntity <- get x rawFoo <- rawSql "SELECT foo FROM foo.schema_entity" [] liftIO $ rawFoo @?= [Single (42 :: Int)] + liftIO $ schemaEntityFoo schemaEntity @== 42 return () From 6be1d6d12f5f7c61a732a88638de956362010fd6 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Fri, 4 Oct 2024 15:20:49 -0400 Subject: [PATCH 33/58] iterate tests and implementation --- .../Database/Persist/Postgresql.hs | 22 ++++++++++--------- persistent-test/src/SchemaTest.hs | 12 +++++----- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 75b322faa..490ee95be 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -533,7 +533,7 @@ upsertSql' ent uniqs updateVal = wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs singleClause :: FieldNameDB -> Text - singleClause field = escapeE (getEntityDBName ent) <> "." <> (escapeF field) <> " =?" + singleClause field = entityIdentifier ent <> "." <> (escapeF field) <> " =?" -- | SQL for inserting multiple rows at once and returning their primary keys. insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult @@ -632,9 +632,11 @@ doesTableExist getter (EntityNameDB name) mSchema = do stmt <- getter sql with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) where - schema = maybe "public" escapeS mSchema sql = "SELECT COUNT(*) FROM pg_catalog.pg_tables " <> "WHERE tablename=? AND schemaname=?" + -- Escaping the schema name would be a mistake here because the "schemaname" + -- column contains *strings*, not *names*. + schema = maybe "public" unSchemaNameDB mSchema vals = [PersistText name, PersistText schema] start = await >>= maybe (error "No results when checking doesTableExist") start' @@ -742,9 +744,6 @@ addTable cols entity = keepField c = Just (cName c) /= fmap fieldDB (getEntityIdField entity) && not (safeToRemove entity (cName c)) - - name = - getEntityDBName entity schema = escapeS <$> getEntitySchema entity idtxt = @@ -816,8 +815,8 @@ getColumns getter def cols = do , ",character_maximum_length " , "FROM information_schema.columns " , "WHERE table_catalog=current_database() " - , "AND table_schema=current_schema() " , "AND table_name=? " + , "AND table_schema=? " ] -- DOMAINS Postgres supports the concept of domains, which are data types @@ -831,6 +830,7 @@ getColumns getter def cols = do stmt <- getter sqlv let vals = [ PersistText $ unEntityNameDB $ getEntityDBName def + , PersistText $ maybe "public" unSchemaNameDB $ getEntitySchema def ] columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) let sqlc = T.concat @@ -845,6 +845,8 @@ getColumns getter def cols = do , "AND c.table_schema=k.table_schema " , "AND c.table_name=? " , "AND c.table_name=k.table_name " + , "AND c.table_schema=? " + , "AND c.table_schema=k.table_schema " , "AND c.constraint_name=k.constraint_name " , "AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " , "ORDER BY c.constraint_name, c.column_name" @@ -1063,7 +1065,7 @@ getColumn getter with (stmtQuery stmt [ PersistText $ unEntityNameDB tableName' - , PersistText $ fromMaybe "public" $ unSchemaNameDB <$> schemaName' + , PersistText $ maybe "public" unSchemaNameDB schemaName' , PersistText $ unFieldNameDB cname , PersistText $ unConstraintNameDB refName' ] @@ -1655,7 +1657,7 @@ mockMigration mig = do , connCommit = undefined , connRollback = undefined , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . getEntityDBName + , connEscapeTableName = entityIdentifier , connEscapeRawName = escape , connNoLimit = undefined , connRDBMS = undefined @@ -1856,7 +1858,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters uniqDef = [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field entityFieldNames = map fieldDbToText (getEntityFields entityDef') - nameOfTable = escapeE . getEntityDBName $ entityDef' + nameOfTable = entityIdentifier entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = @@ -1918,7 +1920,7 @@ putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escapeE . getEntityDBName $ ent + table = entityIdentifier ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs index 54fe32cff..1d2b066d1 100644 --- a/persistent-test/src/SchemaTest.hs +++ b/persistent-test/src/SchemaTest.hs @@ -9,8 +9,8 @@ import Init share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| SchemaEntity schema=foo - foo Int - Primary foo + bar Int + Primary bar |] cleanDB @@ -31,10 +31,10 @@ specsWith runConn = describe "entity with non-null schema" $ -- Ensure we can write to the database x <- insert $ SchemaEntity - { schemaEntityFoo = 42 + { schemaEntityBar = 42 } Just schemaEntity <- get x - rawFoo <- rawSql "SELECT foo FROM foo.schema_entity" [] - liftIO $ rawFoo @?= [Single (42 :: Int)] - liftIO $ schemaEntityFoo schemaEntity @== 42 + rawBar <- rawSql "SELECT bar FROM foo.schema_entity" [] + liftIO $ rawBar @?= [Single (42 :: Int)] + liftIO $ schemaEntityBar schemaEntity @== 42 return () From d0929f07b7cb71566fee7c8920540b9747f4057e Mon Sep 17 00:00:00 2001 From: ben j Date: Tue, 15 Oct 2024 11:02:34 -0500 Subject: [PATCH 34/58] wip --- persistent-mysql/Database/Persist/MySQL.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 249b739e7..77d01eec4 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -761,6 +761,7 @@ getColumn connectInfo getter tname [ PersistText cname -- Foreign key (if any) stmt <- lift . getter $ T.concat [ "SELECT KCU.REFERENCED_TABLE_NAME, " + , "KCU.TABLE_SCHEMA, " , "KCU.CONSTRAINT_NAME, " , "KCU.ORDINAL_POSITION, " , "DELETE_RULE, " @@ -795,14 +796,18 @@ getColumn connectInfo getter tname [ PersistText cname cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) pure $ case cntrs of - [] -> - Nothing - [[PersistText tab, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> + [] -> Nothing + [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> if pos == 1 - then Just $ ColumnReference (EntityNameDB tab) (ConstraintNameDB ref) FieldCascade - { fcOnUpdate = parseCascadeAction onUpd - , fcOnDelete = parseCascadeAction onDel - } + then Just $ + ColumnReference + (EntityNameDB tab) + (if T.null schema then Nothing else Just $ SchemaNameDB schema) + (ConstraintNameDB ref) + FieldCascade + { fcOnUpdate = parseCascadeAction onUpd + , fcOnDelete = parseCascadeAction onDel + } else Nothing xs -> error $ mconcat [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: " From acef90fd4c25806c2cd9e188c2fc884ef31e1417 Mon Sep 17 00:00:00 2001 From: ben j Date: Tue, 19 Nov 2024 22:00:46 -0600 Subject: [PATCH 35/58] wip --- persistent-mysql/Database/Persist/MySQL.hs | 131 ++++++++++++--------- 1 file changed, 75 insertions(+), 56 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 77d01eec4..6a1e26785 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -54,6 +54,7 @@ import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Either (partitionEithers) @@ -151,7 +152,7 @@ openMySQLConn ci logFunc = do , connCommit = const $ MySQL.commit conn , connRollback = const $ MySQL.rollback conn , connEscapeFieldName = T.pack . escapeF - , connEscapeTableName = T.pack . escapeE . getEntityDBName + , connEscapeTableName = \ent -> escapeET (getEntityDBName ent) (getEntitySchema ent) , connEscapeRawName = T.pack . escapeDBName . T.unpack , connNoLimit = "LIMIT 18446744073709551615" -- This noLimit is suggested by MySQL's own docs, see @@ -192,7 +193,7 @@ insertSql' ent vals = (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT) sql = T.concat [ "INSERT INTO " - , escapeET $ getEntityDBName ent + , escapeET (getEntityDBName ent) (getEntitySchema ent) , "(" , T.intercalate "," fieldNames , ") VALUES(" @@ -359,6 +360,7 @@ migrate' :: MySQL.ConnectInfo -> IO (Either [Text] CautiousMigration) migrate' connectInfo allDefs getter val = do let name = getEntityDBName val + let schema = getEntitySchema val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val old <- getColumns connectInfo getter val newcols let udspair = map udToPair udefs @@ -368,7 +370,7 @@ migrate' connectInfo allDefs getter val = do let uniques = do (uname, ucols) <- udspair pure - $ AlterTable name + $ AlterTable name schema $ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols @@ -376,11 +378,12 @@ migrate' connectInfo allDefs getter val = do Column { cName=cname, cReference=Just cRef } <- newcols let refConstraintName = crConstraintName cRef let refTblName = crTableName cRef + let refSchmName = crSchemaName cRef let refTarget = - addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef) + addReference allDefs refConstraintName refTblName refSchmName cname (crFieldCascade cRef) guard $ Just cname /= fmap fieldDB (getEntityIdField val) - return $ AlterColumn name refTarget + return $ AlterColumn name schema refTarget let foreignsAlt = @@ -393,8 +396,10 @@ migrate' connectInfo allDefs getter val = do in AlterColumn name + schema (AddReference (foreignRefTableDBName fdef) + (foreignRefSchemaDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields @@ -432,9 +437,9 @@ migrate' connectInfo allDefs getter val = do $ partitionEithers $ old' acs' = - map (AlterColumn name) acs + map (AlterColumn name schema) acs ats' = - map (AlterTable name) ats + map (AlterTable name schema) ats return $ Right $ map showAlterDb @@ -455,7 +460,7 @@ addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " - , escapeE name + , escapeE name schema , "(" , idtxt , if null nonIdCols then [] else "," @@ -467,6 +472,8 @@ addTable cols entity = AddTable $ concat filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity) ) cols name = getEntityDBName entity + schema = + getEntitySchema entity idtxt = case getEntityId entity of EntityIdNaturalKey pdef -> @@ -549,12 +556,14 @@ addReference -- ^ Foreign key name -> EntityNameDB -- ^ Referenced table name + -> (Maybe SchemaNameDB) + -- ^ Referenced schema name -> FieldNameDB -- ^ Column name -> FieldCascade -> AlterColumn -addReference allDefs fkeyname reftable cname fc = - AddReference reftable fkeyname [cname] referencedColumns fc +addReference allDefs fkeyname reftable refschema cname fc = + AddReference reftable refschema fkeyname [cname] referencedColumns fc where errorMessage = error @@ -562,7 +571,7 @@ addReference allDefs fkeyname reftable cname fc = ++ " (allDefs = " ++ show allDefs ++ ")" referencedColumns = fromMaybe errorMessage $ do - entDef <- find ((== reftable) . getEntityDBName) allDefs + entDef <- find (\e -> getEntityDBName e == reftable && getEntitySchema e == refschema) allDefs return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef data AlterColumn = Change Column @@ -576,6 +585,7 @@ data AlterColumn = Change Column -- | See the definition of the 'showAlter' function to see how these fields are used. | AddReference EntityNameDB -- Referenced table + (Maybe SchemaNameDB) -- Referenced table schema ConstraintNameDB -- Foreign key name [FieldNameDB] -- Referencing columns [FieldNameDB] -- Referenced columns @@ -588,8 +598,8 @@ data AlterTable = AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType, deriving Show data AlterDB = AddTable String - | AlterColumn EntityNameDB AlterColumn - | AlterTable EntityNameDB AlterTable + | AlterColumn EntityNameDB (Maybe SchemaNameDB) AlterColumn + | AlterTable EntityNameDB (Maybe SchemaNameDB) AlterTable deriving Show @@ -802,6 +812,7 @@ getColumn connectInfo getter tname [ PersistText cname then Just $ ColumnReference (EntityNameDB tab) + -- breaks MigrationTest.hs:56 (if T.null schema then Nothing else Just $ SchemaNameDB schema) (ConstraintNameDB ref) FieldCascade @@ -933,7 +944,8 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName Just cr -> let tname = crTableName cr cname = crConstraintName cr - cnstr = [addReference allDefs cname tname name (crFieldCascade cr)] + sname = crSchemaName cr + cnstr = [addReference allDefs cname tname sname name (crFieldCascade cr)] in (Add' col : cnstr, cols) Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ -> @@ -946,12 +958,12 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName [] refAdd = case (ref == ref', ref) of - (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc }) + (False, Just ColumnReference {crTableName=tname, crSchemaName=sname, crConstraintName=cname, crFieldCascade = cfc }) | tname /= getEntityDBName edef , Just idField <- getEntityIdField edef , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField) -> - [addReference allDefs cname tname name cfc] + [addReference allDefs cname tname sname name cfc] _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] @@ -1015,7 +1027,7 @@ showColumn showReferences (Column n nu t def gen _defConstraintName maxLen ref) Just cRef | showReferences -> mconcat [ " REFERENCES " - , escapeE (crTableName cRef) + , escapeE (crTableName cRef) (crSchemaName cRef) , " " , T.unpack (renderFieldCascade (crFieldCascade cRef)) ] @@ -1050,19 +1062,19 @@ showSqlType (SqlOther t) _ _ = T.unpack t -- | Render an action that must be done on the database. showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, pack s) -showAlterDb (AlterColumn t ac) = - (isUnsafe ac, pack $ showAlter t ac) +showAlterDb (AlterColumn t s ac) = + (isUnsafe ac, pack $ showAlter t s ac) where isUnsafe Drop{} = True isUnsafe _ = False -showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) +showAlterDb (AlterTable t s at) = (False, pack $ showAlterTable t s at) -- | Render an action that must be done on a table. -showAlterTable :: EntityNameDB -> AlterTable -> String -showAlterTable table (AddUniqueConstraint cname cols) = concat +showAlterTable :: EntityNameDB -> Maybe SchemaNameDB -> AlterTable -> String +showAlterTable table schema (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ADD CONSTRAINT " , escapeC cname , " UNIQUE(" @@ -1074,60 +1086,60 @@ showAlterTable table (AddUniqueConstraint cname cols) = concat escapeDBName' (name, (FTTypeCon _ "String" ), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")" escapeDBName' (name, (FTTypeCon _ "ByteString"), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")" escapeDBName' (name, _ , _) = escapeF name -showAlterTable table (DropUniqueConstraint cname) = concat +showAlterTable table schema (DropUniqueConstraint cname) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " DROP INDEX " , escapeC cname ] -- | Render an action that must be done on a column. -showAlter :: EntityNameDB -> AlterColumn -> String -showAlter table (Change (Column n nu t def gen defConstraintName maxLen _ref)) = +showAlter :: EntityNameDB -> Maybe SchemaNameDB -> AlterColumn -> String +showAlter table schema (Change (Column n nu t def gen defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " CHANGE " , escapeF n , " " , showAlterColumn (Column n nu t def gen defConstraintName maxLen Nothing) ] -showAlter table (Add' col) = +showAlter table schema (Add' col) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ADD COLUMN " , showAlterColumn col ] -showAlter table (Drop c) = +showAlter table schema (Drop c) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " DROP COLUMN " , escapeF (cName c) ] -showAlter table (Default c s) = +showAlter table schema (Default c s) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ALTER COLUMN " , escapeF (cName c) , " SET DEFAULT " , s ] -showAlter table (NoDefault c) = +showAlter table schema (NoDefault c) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ALTER COLUMN " , escapeF (cName c) , " DROP DEFAULT" ] -showAlter table (Gen col typ len expr) = +showAlter table schema (Gen col typ len expr) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " MODIFY COLUMN " , escapeF (cName col) , " " @@ -1136,19 +1148,19 @@ showAlter table (Gen col typ len expr) = , expr , ") STORED" ] -showAlter table (NoGen col typ len) = +showAlter table schema (NoGen col typ len) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " MODIFY COLUMN " , escapeF (cName col) , " " , showSqlType typ len True ] -showAlter table (Update' c s) = +showAlter table schema (Update' c s) = concat [ "UPDATE " - , escapeE table + , escapeE table schema , " SET " , escapeF (cName c) , "=" @@ -1157,23 +1169,23 @@ showAlter table (Update' c s) = , escapeF (cName c) , " IS NULL" ] -showAlter table (AddReference reftable fkeyname t2 id2 fc) = concat +showAlter table schema (AddReference reftable refschema fkeyname t2 id2 fc) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ADD CONSTRAINT " , escapeC fkeyname , " FOREIGN KEY(" , intercalate "," $ map escapeF t2 , ") REFERENCES " - , escapeE reftable + , escapeE reftable refschema , "(" , intercalate "," $ map escapeF id2 , ") " , T.unpack $ renderFieldCascade fc ] -showAlter table (DropReference cname) = concat +showAlter table schema (DropReference cname) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " DROP FOREIGN KEY " , escapeC cname ] @@ -1183,14 +1195,18 @@ showAlter table (DropReference cname) = concat escapeC :: ConstraintNameDB -> String escapeC = escapeWith (escapeDBName . T.unpack) -escapeE :: EntityNameDB -> String -escapeE = escapeWith (escapeDBName . T.unpack) +escapeE :: EntityNameDB -> Maybe SchemaNameDB -> String +escapeE entity Nothing = escapeWith (escapeDBName . T.unpack) entity +escapeE entity (Just schema) = escapeNS schema <> "." <> escapeNS entity + where + escapeNS :: DatabaseName a => a -> String + escapeNS = escapeWith (escapeDBName . T.unpack) escapeF :: FieldNameDB -> String escapeF = escapeWith (escapeDBName . T.unpack) -escapeET :: EntityNameDB -> Text -escapeET = escapeWith (T.pack . escapeDBName . T.unpack) +escapeET :: EntityNameDB -> Maybe SchemaNameDB -> Text +escapeET entity schema = T.pack $ escapeE entity schema escapeFT :: FieldNameDB -> Text escapeFT = escapeWith (T.pack . escapeDBName . T.unpack) @@ -1276,18 +1292,19 @@ mockMigrate :: MySQL.ConnectInfo -> IO (Either [Text] [(Bool, Text)]) mockMigrate _connectInfo allDefs _getter val = do let name = getEntityDBName val + let sname = getEntitySchema val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val let udspair = map udToPair udefs case () of -- Nothing found, create everything () -> do let uniques = flip concatMap udspair $ \(uname, ucols) -> - [ AlterTable name $ + [ AlterTable name sname $ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols - return $ AlterColumn name (addReference allDefs refConstr refTable cname cfc) + Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crSchemaName = refSchema, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols + return $ AlterColumn name sname (addReference allDefs refConstr refTable refSchema cname cfc) let foreignsAlt = map @@ -1296,8 +1313,10 @@ mockMigrate _connectInfo allDefs _getter val = do in AlterColumn name + sname (AddReference (foreignRefTableDBName fdef) + (foreignRefSchemaDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields @@ -1538,7 +1557,7 @@ mkBulkInsertQuery records fieldValues updates = [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef') - tableName = T.pack . escapeE . getEntityDBName $ entityDef' + tableName = escapeET (getEntityDBName entityDef') (getEntitySchema entityDef') copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records @@ -1587,7 +1606,7 @@ putManySql' (filter isFieldNotGenerated -> fields) ent n = q fieldDbToText = (T.pack . escapeF) . fieldDB mkAssignment f = T.concat [f, "=VALUES(", f, ")"] - table = (T.pack . escapeE) . getEntityDBName $ ent + table = escapeET (getEntityDBName ent) (getEntitySchema ent) columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields From 8a392d759c1541069811444d2e989fe7445eaaab Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Fri, 27 Dec 2024 12:17:21 -0500 Subject: [PATCH 36/58] add test case, update mysql tests --- persistent-mysql/README.md | 7 +++++-- persistent-mysql/test/main.hs | 3 +++ persistent-test/src/SchemaTest.hs | 22 ++++++++++++++++++++-- 3 files changed, 28 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/README.md b/persistent-mysql/README.md index fc773e50e..b43c31edc 100644 --- a/persistent-mysql/README.md +++ b/persistent-mysql/README.md @@ -7,11 +7,14 @@ A backend for the `persistent` database library for the MySQL database server. ## Development To run tests on this library, you will need to have a MySQL database server set up and running on your computer. -The test suite expects to see a database named `test` with a username `test` and password `test`. You can set this up with roughly as follows: +The test suite expects to see databases named `test` and `foo`, and a user with username `test` and password `test`. You can set this up with roughly as follows: ``` mysql -u root # MySQL root username and password may vary CREATE DATABASE test; +CREATE DATABASE foo; CREATE USER 'test'@'localhost' IDENTIFIED BY 'test'; GRANT ALL on test.* TO 'test'@'localhost'; -``` \ No newline at end of file +GRANT ALL on foo.* TO 'test'@'localhost'; +USE test; +``` diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 4eeed768e..404770a37 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -48,6 +48,7 @@ import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest import qualified PersistUniqueTest import qualified PersistentTest +import qualified SchemaTest import qualified TypeLitFieldDefsTest -- FIXME: Not used... should it be? -- import qualified PrimaryTest @@ -149,6 +150,7 @@ main = do , TransactionLevelTest.migration -- , LongIdentifierTest.migration , ForeignKey.compositeMigrate + , SchemaTest.migration ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -228,6 +230,7 @@ main = do LongIdentifierTest.specsWith db GeneratedColumnTestSQL.specsWith db JSONTest.specs + SchemaTest.specsWith db roundFn :: RealFrac a => a -> Integer roundFn = round diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs index 1d2b066d1..0d7c7ee8b 100644 --- a/persistent-test/src/SchemaTest.hs +++ b/persistent-test/src/SchemaTest.hs @@ -11,6 +11,10 @@ share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [pers SchemaEntity schema=foo bar Int Primary bar + +DefaultSchemaEntity sql=schema_entity + bar Int + Primary bar |] cleanDB @@ -20,13 +24,15 @@ cleanDB , PersistStoreWrite (BaseBackend backend) ) => ReaderT backend m () -cleanDB = deleteWhere ([] :: [Filter (SchemaEntityGeneric backend)]) +cleanDB = do + deleteWhere ([] :: [Filter (SchemaEntityGeneric backend)]) + deleteWhere ([] :: [Filter (DefaultSchemaEntityGeneric backend)]) specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec -specsWith runConn = describe "entity with non-null schema" $ +specsWith runConn = describe "entity with non-null schema" $ do it "inserts and selects work as expected" $ asIO $ runConn $ do -- Ensure we can write to the database x <- insert $ @@ -38,3 +44,15 @@ specsWith runConn = describe "entity with non-null schema" $ liftIO $ rawBar @?= [Single (42 :: Int)] liftIO $ schemaEntityBar schemaEntity @== 42 return () + it "is not ambiguous when both tables exist" $ asIO $ runConn $ do + _ <- insert $ + SchemaEntity + { schemaEntityBar = 42 + } + _ <- insert $ + DefaultSchemaEntity + { defaultSchemaEntityBar = 43 + } + rawBar <- rawSql "SELECT bar FROM schema_entity" [] + liftIO $ rawBar @?= [Single (43 :: Int)] + return () From 2c70da8b925ce3048606406ba7ffedfdd3918a32 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Fri, 27 Dec 2024 13:13:57 -0500 Subject: [PATCH 37/58] fix migration test --- persistent-mysql/Database/Persist/MySQL.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 6a1e26785..90808a6a3 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -775,7 +775,8 @@ getColumn connectInfo getter tname [ PersistText cname , "KCU.CONSTRAINT_NAME, " , "KCU.ORDINAL_POSITION, " , "DELETE_RULE, " - , "UPDATE_RULE " + , "UPDATE_RULE, " + , "DATABASE() " , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU " , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC " , " USING (CONSTRAINT_SCHEMA, CONSTRAINT_NAME) " @@ -807,13 +808,12 @@ getColumn connectInfo getter tname [ PersistText cname cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) pure $ case cntrs of [] -> Nothing - [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> + [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd, PersistText defaultSchema]] -> if pos == 1 then Just $ ColumnReference (EntityNameDB tab) - -- breaks MigrationTest.hs:56 - (if T.null schema then Nothing else Just $ SchemaNameDB schema) + (if T.null schema || schema == defaultSchema then Nothing else Just $ SchemaNameDB schema) (ConstraintNameDB ref) FieldCascade { fcOnUpdate = parseCascadeAction onUpd From a7dde4e5f26aa6bd849c3ce0b4fe188fda61ea0c Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 16:58:48 -0500 Subject: [PATCH 38/58] add schema to getColumn --- persistent-mysql/Database/Persist/MySQL.hs | 42 ++++++++++++---------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 90808a6a3..2bde10f67 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -660,7 +660,7 @@ getColumns connectInfo getter def cols = do where ref rs c = case cReference c of Nothing -> rs (Just r) -> (unFieldNameDB $ cName c, r) : rs - vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo + vals = [ PersistText $ fromMaybe (pack $ MySQL.connectDatabase connectInfo) $ fmap unSchemaNameDB $ getEntitySchema def , PersistText $ unEntityNameDB $ getEntityDBName def -- , PersistText $ unDBName $ fieldDB $ getEntityId def ] @@ -669,7 +669,7 @@ getColumns connectInfo getter def cols = do where getIt row = fmap (either Left (Right . Left)) . liftIO . - getColumn connectInfo getter (getEntityDBName def) row $ ref + getColumn connectInfo getter (getEntityDBName def) (getEntitySchema def) row $ ref where ref = case row of (PersistText cname : _) -> (Map.lookup cname refMap) _ -> Nothing @@ -689,19 +689,20 @@ getColumn => MySQL.ConnectInfo -> (Text -> IO Statement) -> EntityNameDB + -> Maybe SchemaNameDB -> [PersistValue] -> Maybe ColumnReference -> IO (Either Text Column) -getColumn connectInfo getter tname [ PersistText cname - , PersistText null_ - , PersistText dataType - , PersistText colType - , colMaxLen - , colPrecision - , colScale - , default' - , generated - ] cRef = +getColumn connectInfo getter tname tschema [ PersistText cname + , PersistText null_ + , PersistText dataType + , PersistText colType + , colMaxLen + , colPrecision + , colScale + , default' + , generated + ] cRef = fmap (either (Left . pack) Right) $ runExceptT $ do -- Default value @@ -775,8 +776,7 @@ getColumn connectInfo getter tname [ PersistText cname , "KCU.CONSTRAINT_NAME, " , "KCU.ORDINAL_POSITION, " , "DELETE_RULE, " - , "UPDATE_RULE, " - , "DATABASE() " + , "UPDATE_RULE " , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU " , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC " , " USING (CONSTRAINT_SCHEMA, CONSTRAINT_NAME) " @@ -789,7 +789,7 @@ getColumn connectInfo getter tname [ PersistText cname , "KCU.COLUMN_NAME" ] let vars = - [ PersistText $ pack $ MySQL.connectDatabase connectInfo + [ PersistText $ fromMaybe (pack $ MySQL.connectDatabase connectInfo) $ fmap unSchemaNameDB tschema , PersistText $ unEntityNameDB tname , PersistText cname , PersistText $ pack $ MySQL.connectDatabase connectInfo @@ -808,12 +808,16 @@ getColumn connectInfo getter tname [ PersistText cname cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) pure $ case cntrs of [] -> Nothing - [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd, PersistText defaultSchema]] -> + [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> if pos == 1 then Just $ - ColumnReference + let colSchema = + if T.null schema || schema == (pack $ MySQL.connectDatabase connectInfo) + then Nothing + else Just $ SchemaNameDB schema + in ColumnReference (EntityNameDB tab) - (if T.null schema || schema == defaultSchema then Nothing else Just $ SchemaNameDB schema) + colSchema (ConstraintNameDB ref) FieldCascade { fcOnUpdate = parseCascadeAction onUpd @@ -829,7 +833,7 @@ getColumn connectInfo getter tname [ PersistText cname , show xs ] -getColumn _ _ _ x _ = +getColumn _ _ _ _ x _ = return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x -- | Extra column information from MySQL schema From c1570dad42bd6bef6a0b96f9594f6467776cff77 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 16:59:15 -0500 Subject: [PATCH 39/58] remove redundant import --- persistent-mysql/Database/Persist/MySQL.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 2bde10f67..59cfe24d3 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -54,7 +54,6 @@ import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL -import Data.Coerce (coerce) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Either (partitionEithers) From c0307bbbbd7e0d2eb9d2c983007e1e329b75b36e Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 17:44:52 -0500 Subject: [PATCH 40/58] stop creating schema in postgres --- persistent-postgresql/Database/Persist/Postgresql.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 490ee95be..d1039f8f7 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -719,12 +719,6 @@ mkForeignAlt entity fdef = pure $ AlterColumn tableName_ schemaName_ addReferenc addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ T.concat $ - case schema of - Nothing -> stmt - -- Lower case e: see Database.Persist.Sql.Migration - Just s -> "CREATe SCHEMA IF NOT EXISTS " <> s <> ";\n" : stmt - where - stmt = -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! , entityIdentifier entity @@ -734,6 +728,7 @@ addTable cols entity = , T.intercalate "," $ map showColumn nonIdCols , ")" ] + where nonIdCols = case entityPrimary entity of Just _ -> From 4ea66ead2bdea7386826b8bcf3e58d601e4964ef Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 17:54:00 -0500 Subject: [PATCH 41/58] bump library version and document new api --- persistent/ChangeLog.md | 6 ++++++ persistent/Database/Persist/Types/Base.hs | 3 +++ persistent/persistent.cabal | 2 +- 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 842f2d552..0bcf5db23 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent +## 2.14.7 + +* [#1561](https://github.com/yesodweb/persistent/pull/1561) + * Add schema support to Persistent using a new `schema=` annotation for + Persistent models. + ## 2.14.6.3 * [#1544](https://github.com/yesodweb/persistent/pull/1544) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index e802b1fac..c6a5d8d4f 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -555,6 +555,9 @@ data ForeignDef = ForeignDef { foreignRefTableHaskell :: !EntityNameHS , foreignRefTableDBName :: !EntityNameDB , foreignRefSchemaDBName :: !(Maybe SchemaNameDB) + -- ^ Determines which schema the target table belongs to. + -- + -- @since 2.14.7 , foreignConstraintNameHaskell :: !ConstraintNameHS , foreignConstraintNameDBName :: !ConstraintNameDB , foreignFieldCascade :: !FieldCascade diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 1fb56f170..15753366e 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.6.3 +version: 2.14.7 license: MIT license-file: LICENSE author: Michael Snoyman From cfafec6aeaa8aba9332011c56bc486289fa69049 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:02:31 -0500 Subject: [PATCH 42/58] bump persistent-mysql versions and add haddocks --- persistent-mysql/Database/Persist/MySQL.hs | 29 +++++++++++++++++++--- persistent-mysql/persistent-mysql.cabal | 8 +++--- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 59cfe24d3..db7e7a519 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -557,6 +557,8 @@ addReference -- ^ Referenced table name -> (Maybe SchemaNameDB) -- ^ Referenced schema name + -- + -- @since 2.13.2 -> FieldNameDB -- ^ Column name -> FieldCascade @@ -689,6 +691,7 @@ getColumn -> (Text -> IO Statement) -> EntityNameDB -> Maybe SchemaNameDB + -- ^ @since 2.13.2 -> [PersistValue] -> Maybe ColumnReference -> IO (Either Text Column) @@ -1074,7 +1077,12 @@ showAlterDb (AlterTable t s at) = (False, pack $ showAlterTable t s at) -- | Render an action that must be done on a table. -showAlterTable :: EntityNameDB -> Maybe SchemaNameDB -> AlterTable -> String +showAlterTable + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.2 + -> AlterTable + -> String showAlterTable table schema (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " , escapeE table schema @@ -1098,7 +1106,12 @@ showAlterTable table schema (DropUniqueConstraint cname) = concat -- | Render an action that must be done on a column. -showAlter :: EntityNameDB -> Maybe SchemaNameDB -> AlterColumn -> String +showAlter + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.2 + -> AlterColumn + -> String showAlter table schema (Change (Column n nu t def gen defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " @@ -1198,7 +1211,11 @@ showAlter table schema (DropReference cname) = concat escapeC :: ConstraintNameDB -> String escapeC = escapeWith (escapeDBName . T.unpack) -escapeE :: EntityNameDB -> Maybe SchemaNameDB -> String +escapeE + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.2 + -> String escapeE entity Nothing = escapeWith (escapeDBName . T.unpack) entity escapeE entity (Just schema) = escapeNS schema <> "." <> escapeNS entity where @@ -1208,7 +1225,11 @@ escapeE entity (Just schema) = escapeNS schema <> "." <> escapeNS entity escapeF :: FieldNameDB -> String escapeF = escapeWith (escapeDBName . T.unpack) -escapeET :: EntityNameDB -> Maybe SchemaNameDB -> Text +escapeET + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.2 + -> Text escapeET entity schema = T.pack $ escapeE entity schema escapeFT :: FieldNameDB -> Text diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index 9a823c177..e5dc16669 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 2.13.1.5 +version: 2.13.2 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -28,7 +28,7 @@ extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 - , persistent >= 2.13.3 && < 3 + , persistent >= 2.14.7 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10.8 @@ -54,7 +54,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: + other-modules: MyInit InsertDuplicateUpdate CustomConstraintTest @@ -62,7 +62,7 @@ test-suite test JSONTest ghc-options: -Wall - build-depends: + build-depends: base >= 4.9 && < 5 , aeson , bytestring From 1b068ae0703908e1d971507d348da19399220292 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:09:45 -0500 Subject: [PATCH 43/58] bump versions in postgresql project --- .../Database/Persist/Postgresql.hs | 24 ++++++++++++++++--- .../persistent-postgresql.cabal | 4 ++-- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index d1039f8f7..8e10b9ef0 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -627,6 +627,7 @@ withStmt' conn query vals = doesTableExist :: (Text -> IO Statement) -> EntityNameDB -> (Maybe SchemaNameDB) + -- ^ @since 2.13.7 -> IO Bool doesTableExist getter (EntityNameDB name) mSchema = do stmt <- getter sql @@ -933,6 +934,7 @@ getColumn :: (Text -> IO Statement) -> EntityNameDB -> Maybe SchemaNameDB + -- ^ @since 2.13.7 -> [PersistValue] -> Maybe (EntityNameDB, ConstraintNameDB) -> IO (Either Text Column) @@ -991,7 +993,7 @@ getColumn getter -- in Postgres is "public", but Postgres doesn't know whether a table with -- schema "public" was explicitly given that schema by the Persistent -- app developer. - cReference = fmap (\(a,b,c,d,e) -> ColumnReference a (Just b) c (mkCascade d e)) ref + cReference = fmap (\(a,schemaName,c,d,e) -> ColumnReference a (Just schemaName) c (mkCascade d e)) ref } where @@ -1300,7 +1302,12 @@ showAlterDb (AlterColumn t s ac) = isUnsafe _ = False showAlterDb (AlterTable t s at) = (False, showAlterTable t s at) -showAlterTable :: EntityNameDB -> Maybe SchemaNameDB -> AlterTable -> Text +showAlterTable + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.7 + -> AlterTable + -> Text showAlterTable table schema (AddUniqueConstraint cname cols) = T.concat [ "ALTER TABLE " , escapeES table schema @@ -1317,7 +1324,12 @@ showAlterTable table schema (DropConstraint cname) = T.concat , escapeC cname ] -showAlter :: EntityNameDB -> Maybe SchemaNameDB -> AlterColumn -> Text +showAlter + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.7 + -> AlterColumn + -> Text showAlter table schema (ChangeType c t extra) = T.concat [ "ALTER TABLE " @@ -1435,9 +1447,15 @@ escape s = go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs +-- | Escapes the SQL identifier of an entity. +-- +-- @since 2.13.7 entityIdentifier :: EntityDef -> Text entityIdentifier ed = escapeES (getEntityDBName ed) (getEntitySchema ed) +-- | Escapes a table name, optionally namespaced by a schema. +-- +-- @since 2.13.7 escapeES :: EntityNameDB -> Maybe SchemaNameDB -> Text escapeES entityName schemaName = case schemaName of Nothing -> escapeE entityName diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index c2be91b47..6def2d0da 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.6.2 +version: 2.13.7 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 - , persistent >= 2.13.3 && < 3 + , persistent >= 2.14.7 && < 3 , aeson >= 1.0 , attoparsec , blaze-builder From 3bd72fd3ce028b298915f12d106c697d92b3b724 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:13:05 -0500 Subject: [PATCH 44/58] bump version of sqlite package --- persistent-sqlite/Database/Persist/Sqlite.hs | 9 +++++++++ persistent-sqlite/persistent-sqlite.cabal | 6 +++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 1295a8f05..a09bd358f 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -719,9 +719,15 @@ escapeC = escapeWith escape escapeE :: EntityNameDB -> Text escapeE = escapeWith escape +-- | Escapes a schema name. +-- +-- @since 2.13.4 escapeS :: SchemaNameDB -> Text escapeS = escapeWith escape +-- | Escapes a table name, optionally namespaced by a schema. +-- +-- @since 2.13.4 escapeES :: EntityNameDB -> Maybe SchemaNameDB -> Text escapeES entity Nothing = escapeE entity escapeES entity (Just schema) = escapeS schema <> "." <> escapeE entity @@ -737,6 +743,9 @@ escape s = go '"' = "\"\"" go c = T.singleton c +-- | Escapes the identifier for an entity. +-- +-- @since 2.13.4 entityIdentifier :: EntityDef -> Text entityIdentifier entity = escapeES (getEntityDBName entity) (getEntitySchema entity) diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index 77d35d6c1..43b8f6ed8 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.13.3.0 +version: 2.13.4 license: MIT license-file: LICENSE author: Michael Snoyman @@ -44,7 +44,7 @@ flag use-stat4 library build-depends: base >= 4.9 && < 5 - , persistent >= 2.13.3 && < 3 + , persistent >= 2.14.7 && < 3 , aeson >= 1.0 , bytestring >= 0.10 , conduit >= 1.2.12 @@ -114,7 +114,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: + other-modules: SqliteInit Database.Persist.Sqlite.CompositeSpec ghc-options: -Wall From 8b6b75243bee181abb44ae114933fea714e75e9e Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:14:04 -0500 Subject: [PATCH 45/58] bump persistent-test version --- persistent-test/persistent-test.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 0a1b798f6..79176c495 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -1,5 +1,5 @@ name: persistent-test -version: 2.13.1.3 +version: 2.13.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -15,7 +15,7 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md library - exposed-modules: + exposed-modules: CompositeTest CustomPersistField CustomPersistFieldTest @@ -61,7 +61,7 @@ library hs-source-dirs: src - build-depends: + build-depends: base >= 4.9 && < 5 , aeson >= 1.0 , blaze-html >= 0.9 @@ -77,7 +77,7 @@ library , monad-logger >= 0.3.25 , mtl , path-pieces >= 0.2 - , persistent >= 2.14 && < 2.15 + , persistent >= 2.14.7 && < 2.15 , QuickCheck >= 2.9 , quickcheck-instances >= 0.3 , random >= 1.1 From 7f990daf6787f97fe64e3b7b301027e993b34d73 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:18:47 -0500 Subject: [PATCH 46/58] add more haddock comments --- persistent/Database/Persist/EntityDef.hs | 7 +++++++ persistent/Database/Persist/Names.hs | 4 ++++ persistent/Database/Persist/Quasi/Internal.hs | 1 + persistent/Database/Persist/Types/Base.hs | 4 +++- 4 files changed, 15 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index 92929a6b4..dcc2f2bd5 100644 --- a/persistent/Database/Persist/EntityDef.hs +++ b/persistent/Database/Persist/EntityDef.hs @@ -91,6 +91,10 @@ getEntityDBName = entityDB getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra +-- | Get the (optional) schema for an entity. Specified with the syntax +-- `schema=foo` on the Persistent model. +-- +-- @since 2.14.7 getEntitySchema :: EntityDef -> Maybe SchemaNameDB getEntitySchema = entitySchema @@ -200,6 +204,9 @@ getEntityKeyFields = entityKeyFields setEntityFields :: [FieldDef] -> EntityDef -> EntityDef setEntityFields fd ed = ed { entityFields = fd } +-- | Update the entity schema. +-- +-- @since 2.14.7 setEntitySchema :: Maybe SchemaNameDB -> EntityDef -> EntityDef setEntitySchema sn ed = ed { entitySchema = sn } diff --git a/persistent/Database/Persist/Names.hs b/persistent/Database/Persist/Names.hs index dc8b07bb0..bb12d2f1d 100644 --- a/persistent/Database/Persist/Names.hs +++ b/persistent/Database/Persist/Names.hs @@ -71,6 +71,10 @@ instance DatabaseName ConstraintNameDB where newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) +-- | The name of a database schema. Different backends vary in their +-- interpretation of this concept. +-- +-- @since 2.14.7 newtype SchemaNameDB = SchemaNameDB { unSchemaNameDB :: Text } deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 330645202..0ab0039fd 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -311,6 +311,7 @@ data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] , parsedEntityDefEntityName :: EntityNameHS , parsedEntityDefSchemaName :: Maybe SchemaNameDB + -- ^ @since 2.14.7 , parsedEntityDefIsSum :: Bool , parsedEntityDefEntityAttributes :: [Attr] , parsedEntityDefFieldAttributes :: [[Token]] diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index c6a5d8d4f..5aae1f589 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -153,10 +153,12 @@ data EntityDef = EntityDef -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. + -- + -- @since 2.10.0 , entitySchema :: !(Maybe SchemaNameDB) -- ^ The schema the entity belongs to. -- - -- @since 2.10.0 + -- @since 2.14.7 } deriving (Show, Eq, Read, Ord, Lift) From 65969ce8287bf194143de29156628c137f0e89a2 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:27:27 -0500 Subject: [PATCH 47/58] undo redundant change --- persistent-redis/Database/Persist/Redis/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-redis/Database/Persist/Redis/Internal.hs b/persistent-redis/Database/Persist/Redis/Internal.hs index 82876b66a..8f4ab66d4 100644 --- a/persistent-redis/Database/Persist/Redis/Internal.hs +++ b/persistent-redis/Database/Persist/Redis/Internal.hs @@ -23,10 +23,10 @@ toLabel :: FieldDef -> B.ByteString toLabel = U.fromString . unpack . unFieldNameDB . fieldDB toEntityString :: PersistEntity val => val -> Text -toEntityString = unEntityNameDB . getEntityDBName . entityDef . Just +toEntityString = unEntityNameDB . entityDB . entityDef . Just toEntityName :: EntityDef -> B.ByteString -toEntityName = U.fromString . unpack . unEntityNameDB . getEntityDBName +toEntityName = U.fromString . unpack . unEntityNameDB . entityDB mkEntity :: (MonadFail m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val) mkEntity key fields = do From a6598f31425e3a64bc1d97af22194a8d8bb37b52 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:27:52 -0500 Subject: [PATCH 48/58] update changelogs --- persistent-mysql/ChangeLog.md | 5 +++++ persistent-postgresql/ChangeLog.md | 4 +++- persistent-sqlite/ChangeLog.md | 5 +++++ persistent-test/ChangeLog.md | 5 ++++- 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 45e7e6d20..4c8feedfe 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-mysql +## 2.13.2 + +* [#1561](https://github.com/yesodweb/persistent/pull/1561) + * Add schema support to Persistent + ## 2.13.1.5 * [#1526](https://github.com/yesodweb/persistent/pull/1526) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 14cc261c3..d72dd88cf 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,9 +1,11 @@ # Changelog for persistent-postgresql -## Unreleased +## 2.13.7 * [#1547](https://github.com/yesodweb/persistent/pull/1547) * Bump `libpq` bounds +* [#1561](https://github.com/yesodweb/persistent/pull/1561) + * Add schema support to Persistent ## 2.13.6.2 diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index 32b230099..fd7483f4a 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-sqlite +## 2.13.4 + +* [#1561](https://github.com/yesodweb/persistent/pull/1561) + * Add schema support to Persistent. + ## 2.13.3.0 * [#1524](https://github.com/yesodweb/persistent/pull/1524) diff --git a/persistent-test/ChangeLog.md b/persistent-test/ChangeLog.md index 9549660bc..3bd33376f 100644 --- a/persistent-test/ChangeLog.md +++ b/persistent-test/ChangeLog.md @@ -1,4 +1,7 @@ -## Unreleased changes +## 2.13.2 + +* [#1561](https://github.com/yesodweb/persistent/pull/1561) + * Add schema support to Persistent. ## 2.13.1.3 From e8c00d5038ccc9e76462dab64430738cd01900fa Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:34:49 -0500 Subject: [PATCH 49/58] add more doc comments --- persistent/Database/Persist/Sql/Types.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index f2fe2e18d..b221022bb 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -36,10 +36,13 @@ data Column = Column -- @since 2.11.0.0 data ColumnReference = ColumnReference { crTableName :: !EntityNameDB - -- ^ The table name that the + -- ^ The foreign table's name. -- -- @since 2.11.0.0 , crSchemaName :: !(Maybe SchemaNameDB) + -- ^ The name of the schema that the foreign table belongs to. + -- + -- @since 2.14.7 , crConstraintName :: !ConstraintNameDB -- ^ The name of the foreign key constraint. -- From 755b9d2e7b946b893395f19fcc7626e35dab61b0 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:41:35 -0500 Subject: [PATCH 50/58] run stylish-haskell --- persistent-mysql/Database/Persist/MySQL.hs | 1 - persistent-mysql/test/main.hs | 2 +- persistent-postgresql/test/main.hs | 2 +- persistent-qq/test/Spec.hs | 8 ++--- persistent-sqlite/test/SqliteInit.hs | 38 +++++++++++++++++----- persistent-sqlite/test/main.hs | 2 +- persistent/Database/Persist/TH.hs | 2 +- 7 files changed, 37 insertions(+), 18 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index db7e7a519..31209ac9e 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -64,7 +64,6 @@ import Data.List (find, groupBy, intercalate, sort) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import qualified Data.Map as Map import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool) diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 404770a37..3fd0a5042 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -46,8 +46,8 @@ import qualified MigrationOnlyTest import qualified MigrationTest import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest -import qualified PersistUniqueTest import qualified PersistentTest +import qualified PersistUniqueTest import qualified SchemaTest import qualified TypeLitFieldDefsTest -- FIXME: Not used... should it be? diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 890a0871a..b13fde001 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -48,8 +48,8 @@ import qualified MigrationReferenceSpec import qualified MigrationTest import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest -import qualified PersistUniqueTest import qualified PersistentTest +import qualified PersistUniqueTest import qualified PgIntervalTest import qualified PrimaryTest import qualified RawSqlTest diff --git a/persistent-qq/test/Spec.hs b/persistent-qq/test/Spec.hs index b075d0194..b2a876085 100644 --- a/persistent-qq/test/Spec.hs +++ b/persistent-qq/test/Spec.hs @@ -4,23 +4,23 @@ import Control.Monad (when) import Control.Monad.Logger (LoggingT, runLoggingT) -import Control.Monad.Trans.Resource import Control.Monad.Reader +import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as B -import Data.List.NonEmpty (NonEmpty(..)) import Data.List (sort) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import System.Log.FastLogger (fromLogStr) import Test.Hspec import Test.HUnit ((@?=)) +import qualified CodeGenTest import Database.Persist.Class.PersistEntity import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ import Database.Persist.Sqlite -import PersistTestPetType import PersistentTestModels -import qualified CodeGenTest +import PersistTestPetType main :: IO () main = hspec spec diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 191cd0f82..323ad09a4 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -45,22 +45,42 @@ module SqliteInit ( ) where import Init - ( TestFn(..), truncateTimeOfDay, truncateUTCTime - , truncateToMicro, arbText, liftA2, GenerateKey(..) - , (@/=), (@==), (==@), MonadFail - , assertNotEqual, assertNotEmpty, assertEmpty, asIO - , isTravis, RunDb - ) + ( GenerateKey(..) + , MonadFail + , RunDb + , TestFn(..) + , arbText + , asIO + , assertEmpty + , assertNotEmpty + , assertNotEqual + , isTravis + , liftA2 + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , (==@) + , (@/=) + , (@==) + ) -- re-exports import Control.Exception (SomeException) -import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Trans.Reader -import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Database.Persist.TH + ( MkPersistSettings(..) + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , share + , sqlSettings + ) import Test.Hspec -- testing -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Control.Monad (unless, (>=>)) import Control.Monad.IO.Unlift (MonadUnliftIO) diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 3f67d8aa5..d1baa01bb 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -37,8 +37,8 @@ import qualified MigrationColumnLengthTest import qualified MigrationOnlyTest import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest -import qualified PersistUniqueTest import qualified PersistentTest +import qualified PersistUniqueTest import qualified PrimaryTest import qualified RawSqlTest import qualified ReadWriteTest diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 009f0b94b..36440d246 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -338,7 +338,7 @@ liftAndFixKeys mps emEntities entityMap unboundEnt = where fixForeignRefTableDBName = getEntityDBName (unboundEntityDef parentDef) - fixForeignRefSchemaDBName = + fixForeignRefSchemaDBName = getEntitySchema (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of From 98b49bc9d40a41e9d0afeeda64057a22f8edef4b Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 18:44:20 -0500 Subject: [PATCH 51/58] bump persistent-qq version --- persistent-qq/ChangeLog.md | 4 ++++ persistent-qq/persistent-qq.cabal | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/persistent-qq/ChangeLog.md b/persistent-qq/ChangeLog.md index 3c35ddddd..e1275179e 100644 --- a/persistent-qq/ChangeLog.md +++ b/persistent-qq/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-qq +## 2.12.1 + +* Add tests for the new `schema=` annotation. [#1561](https://github.com/yesodweb/persistent/pull/1561) + ## 2.12.0.6 * Fix test compilation by importing `Control.Monad` explicitly [#1487](https://github.com/yesodweb/persistent/pull/1487) diff --git a/persistent-qq/persistent-qq.cabal b/persistent-qq/persistent-qq.cabal index 14b3e03f8..4439b41c0 100644 --- a/persistent-qq/persistent-qq.cabal +++ b/persistent-qq/persistent-qq.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: persistent-qq -version: 2.12.0.6 +version: 2.12.1 synopsis: Provides a quasi-quoter for raw SQL for persistent description: Please see README and API docs at . category: Database, Yesod @@ -31,7 +31,7 @@ library base >=4.9 && <5 , haskell-src-meta , mtl - , persistent >=2.12 + , persistent >=2.14.7 , template-haskell , text default-language: Haskell2010 From 7bf74fcb53a24e0f1288d895c528ccde7cea03ff Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 19:04:49 -0500 Subject: [PATCH 52/58] account for null referenced schema name possibility --- persistent-mysql/Database/Persist/MySQL.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 31209ac9e..6bacf7398 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -809,13 +809,16 @@ getColumn connectInfo getter tname tschema [ PersistText cname cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) pure $ case cntrs of [] -> Nothing - [[PersistText tab, PersistText schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> + [[PersistText tab, schema, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> if pos == 1 then Just $ let colSchema = - if T.null schema || schema == (pack $ MySQL.connectDatabase connectInfo) - then Nothing - else Just $ SchemaNameDB schema + case schema of + PersistNull -> Nothing + PersistText schemaName -> + if T.null schemaName || schemaName == (pack $ MySQL.connectDatabase connectInfo) + then Nothing + else Just $ SchemaNameDB schemaName in ColumnReference (EntityNameDB tab) colSchema From 916cc4a24ffe85551ab08817623f973783094d5c Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 19:22:12 -0500 Subject: [PATCH 53/58] document a tricky use of a table-valued pragma --- persistent-sqlite/Database/Persist/Sqlite.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index a09bd358f..9d808c35b 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -895,7 +895,11 @@ checkForeignKeys = rawQuery query [] .| C.mapM parse query = T.unlines [ "SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")" , "FROM pragma_database_list() as databases" - , "INNER JOIN pragma_foreign_key_check(null, databases.name) AS origin" + , -- Passing null as the first argument indicates that we are considering + -- *all* tables in a particular schema. The second argument determines + -- the schema to check. So this inner join iterates over every + -- active schema to find all the foreign key constraint violations. + "INNER JOIN pragma_foreign_key_check(null, databases.name) AS origin" , "INNER JOIN pragma_foreign_key_list(origin.\"table\", databases.name) AS foreignkeys" , "ON origin.fkid = foreignkeys.id AND origin.parent = foreignkeys.\"table\"" , "GROUP BY origin.rowid" From 035075a19ab37212d72b1741752f582f17c2fdf5 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 19:27:10 -0500 Subject: [PATCH 54/58] update postgres readme --- persistent-postgresql/README.md | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/persistent-postgresql/README.md b/persistent-postgresql/README.md index 219bb184a..872249290 100644 --- a/persistent-postgresql/README.md +++ b/persistent-postgresql/README.md @@ -7,16 +7,18 @@ A backend for the `persistent` database library for the PostgreSQL database serv ## Development To run tests on this library, you will need to have a PostgreSQL database server set up and running on your computer. -The tests will expect to connect to a database named `test` using the `postgres` user and no password. -This can be done either via the Postgresql command line or using the `createdb` tool: +The tests will expect to connect to a database named `test` using the `postgres` user and no password, as well as a schema `foo`. +This can be done via the Postgresql command line. ``` $ psql -d postgres postgres=# CREATE DATABASE test; CREATE DATABASE - --- or, -$ createdb test +postgres=# \c test +psql () +You are now connected to database "test" as user "postgres". +test=# CREATE SCHEMA FOO; +CREATE SCHEMA ``` The tests do not pass a test and expect to connect with the `postgres` user. From a4e8af3086f5645751cda2ebb6786fceea604fd6 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 19:45:18 -0500 Subject: [PATCH 55/58] fix persistent-qq tests --- persistent-qq/test/PersistentTestModels.hs | 10 +++++++++- persistent-qq/test/Spec.hs | 8 ++++++-- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs index acdf94f36..f88601dae 100644 --- a/persistent-qq/test/PersistentTestModels.hs +++ b/persistent-qq/test/PersistentTestModels.hs @@ -110,8 +110,16 @@ share ~no Int def Int + -- copied from 'Person' + AnimalPerson json schema=animals + name Text + age Int "some ignored -- \" attribute" + color Text Maybe -- this is a comment sql=foobarbaz + AnimalPersonNameKey name -- this is a comment sql=foobarbaz + deriving Show Eq + PetAnimal schema=animals - ownerId PersonId + ownerId AnimalPersonId name Text |] diff --git a/persistent-qq/test/Spec.hs b/persistent-qq/test/Spec.hs index b2a876085..8bd32e483 100644 --- a/persistent-qq/test/Spec.hs +++ b/persistent-qq/test/Spec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} import Control.Monad (when) @@ -7,10 +8,12 @@ import Control.Monad.Logger (LoggingT, runLoggingT) import Control.Monad.Reader import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) import Data.List (sort) import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import System.Log.FastLogger (fromLogStr) +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.HUnit ((@?=)) @@ -37,6 +40,7 @@ runConn f = do db :: SqlPersistT (LoggingT (ResourceT IO)) a -> IO a db actions = do runResourceT $ runConn $ do + rawSql @(Single Int64) ("attach 'animals.db' as animals") [] _ <- runMigrationSilent testMigrate actions <* transactionUndo @@ -116,7 +120,7 @@ spec = describe "persistent-qq" $ do liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey p1k) (RFO p1)] it "sqlQQ/entity in schema" $ db $ do - let person = Person "Zacarias" 93 Nothing + let person = AnimalPerson "Zacarias" 93 Nothing personKey <- insert person let pet = PetAnimal personKey "Fluffy" petKey <- insert pet @@ -124,7 +128,7 @@ spec = describe "persistent-qq" $ do :: (RawSql a, Functor m, MonadIO m) => ReaderT SqlBackend m [a] runQueryQuoted = [sqlQQ| SELECT ?? FROM ^{PetAnimal} |] - runQueryRaw = [sqlQQ| SELECT ?? FROM animals.pet_animal |] + runQueryRaw = [sqlQQ| SELECT ?? FROM animals.PetAnimal |] retQuoted <- runQueryQuoted retRaw <- runQueryRaw liftIO $ retQuoted @?= [Entity petKey pet] From e7efb531ff7e67d198552b9139c524f94da78a94 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 20:07:41 -0500 Subject: [PATCH 56/58] use lowercase schema name --- persistent-postgresql/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-postgresql/README.md b/persistent-postgresql/README.md index 872249290..e5f932878 100644 --- a/persistent-postgresql/README.md +++ b/persistent-postgresql/README.md @@ -17,7 +17,7 @@ CREATE DATABASE postgres=# \c test psql () You are now connected to database "test" as user "postgres". -test=# CREATE SCHEMA FOO; +test=# CREATE SCHEMA foo; CREATE SCHEMA ``` From 9b1aae00987ccc75736fe3fb3e08413b248cfca9 Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Mon, 30 Dec 2024 20:11:45 -0500 Subject: [PATCH 57/58] add schema to checkForeignKeys query --- persistent-sqlite/Database/Persist/Sqlite.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 9d808c35b..2b385c514 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -866,6 +866,10 @@ instance FromJSON SqliteConnectionInfo where -- @since 2.11.1 data ForeignKeyViolation = ForeignKeyViolation { foreignKeyTable :: Text -- ^ The table of the violated constraint + , foreignKeySchema :: Maybe Text + -- ^ The schema of the violated constraint + -- + -- @since 2.13.4 , foreignKeyColumn :: Text -- ^ The column of the violated constraint , foreignKeyRowId :: Int64 -- ^ The ROWID of the row with the violated foreign key constraint } deriving (Eq, Ord, Show) @@ -883,9 +887,10 @@ checkForeignKeys checkForeignKeys = rawQuery query [] .| C.mapM parse where parse l = case l of - [ PersistInt64 rowid , PersistText table , PersistText column ] -> + [ PersistInt64 rowid , PersistText table , PersistText schema , PersistText column ] -> return ForeignKeyViolation { foreignKeyTable = table + , foreignKeySchema = if schema == "main" then Nothing else Just schema , foreignKeyColumn = column , foreignKeyRowId = rowid } @@ -893,7 +898,7 @@ checkForeignKeys = rawQuery query [] .| C.mapM parse [ "Unexpected result from foreign key check:\n", T.pack (show l) ] query = T.unlines - [ "SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")" + [ "SELECT origin.rowid, origin.\"table\", databases.name, group_concat(foreignkeys.\"from\")" , "FROM pragma_database_list() as databases" , -- Passing null as the first argument indicates that we are considering -- *all* tables in a particular schema. The second argument determines From 896edc25df3e58ad125f862573dfd5807622674b Mon Sep 17 00:00:00 2001 From: Curran McConnell Date: Thu, 2 Jan 2025 11:03:23 -0500 Subject: [PATCH 58/58] throw error if there is a cross-schema reference --- persistent-sqlite/Database/Persist/Sqlite.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 2b385c514..d45649896 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -614,7 +614,7 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) = footer = [ T.concat $ map sqlUnique uniqs - , T.concat $ map sqlForeign fdefs + , T.concat $ map (sqlForeign $ getEntitySchema entity) fdefs , ")" ] @@ -674,23 +674,27 @@ sqlColumn noRef (Column name isNull typ def gen _cn _maxLen ref) = T.concat onDelete opts = maybe "" (T.append " ON DELETE " . renderCascadeAction) (fcOnDelete opts) onUpdate opts = maybe "" (T.append " ON UPDATE " . renderCascadeAction) (fcOnUpdate opts) -sqlForeign :: ForeignDef -> Text -sqlForeign fdef = T.concat $ +sqlForeign :: Maybe SchemaNameDB -> ForeignDef -> Text +sqlForeign entitySchema fdef = T.concat $ [ ", CONSTRAINT " , escapeC $ foreignConstraintNameDBName fdef , " FOREIGN KEY(" , T.intercalate "," $ map (escapeF . snd. fst) $ foreignFields fdef , ") REFERENCES " - , -- It's a syntax error in SQLite to use a dot-qualified table name. - -- In general, it's not possible for SQLite to maintain foreign key + , -- It's not possible for SQLite to maintain foreign key -- constraints across databases (which Persistent calls "schemas"). - -- So we omit the schema here. - escapeE (foreignRefTableDBName fdef) + -- In fact, it's a syntax error to use a schema qualifier in this + -- part of the SQL expression. So we omit the schema here, and throw + -- an error if this is a cross-schema reference. + if isCrossSchemaReference + then error "Sqlite.sqlForeign: this backend cannot accept foreign key references across different schemas" + else escapeE (foreignRefTableDBName fdef) , "(" , T.intercalate "," $ map (escapeF . snd . snd) $ foreignFields fdef , ")" ] ++ onDelete ++ onUpdate where + isCrossSchemaReference = foreignRefSchemaDBName fdef /= entitySchema onDelete = fmap (T.append " ON DELETE ") $ showAction