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-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 249b739e7..6bacf7398 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) @@ -151,7 +150,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 +191,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 +358,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 +368,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 +376,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 +394,10 @@ migrate' connectInfo allDefs getter val = do in AlterColumn name + schema (AddReference (foreignRefTableDBName fdef) + (foreignRefSchemaDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields @@ -432,9 +435,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 +458,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 +470,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 +554,16 @@ addReference -- ^ Foreign key name -> EntityNameDB -- ^ Referenced table name + -> (Maybe SchemaNameDB) + -- ^ Referenced schema name + -- + -- @since 2.13.2 -> 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 @@ -650,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 ] @@ -659,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 @@ -679,19 +689,21 @@ getColumn => MySQL.ConnectInfo -> (Text -> IO Statement) -> EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.2 -> [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 @@ -761,6 +773,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, " @@ -777,7 +790,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 @@ -795,14 +808,25 @@ 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, 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 $ + let colSchema = + 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 + (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: " @@ -813,7 +837,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 @@ -928,7 +952,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' : _ -> @@ -941,12 +966,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' = [] @@ -1010,7 +1035,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)) ] @@ -1045,19 +1070,24 @@ 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 + -- ^ @since 2.13.2 + -> AlterTable + -> String +showAlterTable table schema (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " - , escapeE table + , escapeE table schema , " ADD CONSTRAINT " , escapeC cname , " UNIQUE(" @@ -1069,60 +1099,65 @@ 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 + -- ^ @since 2.13.2 + -> 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) , " " @@ -1131,19 +1166,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) , "=" @@ -1152,23 +1187,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 ] @@ -1178,14 +1213,26 @@ 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 + -- ^ @since 2.13.2 + -> 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 + -- ^ @since 2.13.2 + -> Text +escapeET entity schema = T.pack $ escapeE entity schema escapeFT :: FieldNameDB -> Text escapeFT = escapeWith (T.pack . escapeDBName . T.unpack) @@ -1271,18 +1318,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 @@ -1291,8 +1339,10 @@ mockMigrate _connectInfo allDefs _getter val = do in AlterColumn name + sname (AddReference (foreignRefTableDBName fdef) + (foreignRefSchemaDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields @@ -1533,7 +1583,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 @@ -1582,7 +1632,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 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/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 diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 4eeed768e..3fd0a5042 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -46,8 +46,9 @@ 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? -- 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-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-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index a34aafda6..8e10b9ef0 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 (" @@ -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 @@ -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 (" @@ -626,14 +626,19 @@ withStmt' conn query vals = doesTableExist :: (Text -> IO Statement) -> EntityNameDB + -> (Maybe SchemaNameDB) + -- ^ @since 2.13.7 -> 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] + 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' start' [PersistInt64 0] = finish False @@ -651,12 +656,13 @@ 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 where name = getEntityDBName entity + schema = getEntitySchema entity (newcols', udefs, fdefs) = postgresMkColumns allDefs entity migrationText exists' old'' | not exists' = @@ -664,8 +670,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 +685,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 +698,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) + (foreignRefSchemaDBName fdef) constraintName childfields escapedParentFields @@ -711,10 +719,10 @@ mkForeignAlt entity fdef = pure $ AlterColumn tableName_ addReference addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = - AddTable $ T.concat + 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 "," @@ -732,9 +740,8 @@ 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 = case getEntityId entity of EntityIdNaturalKey pdef -> @@ -773,7 +780,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 +790,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. @@ -804,8 +811,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 @@ -819,6 +826,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 @@ -833,6 +841,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" @@ -865,7 +875,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 @@ -923,18 +933,23 @@ getAlters defs def (c1, u1) (c2, u2) = getColumn :: (Text -> IO Statement) -> EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.7 -> [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 -> @@ -974,7 +989,11 @@ 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 + , -- 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,schemaName,c,d,e) -> ColumnReference a (Just schemaName) c (mkCascade d e)) ref } where @@ -1012,10 +1031,15 @@ getColumn getter tableName' [ PersistText columnName Nothing -> loop' ps Just t' -> t' + getRef + :: FieldNameDB + -> (a, ConstraintNameDB) + -> IO (Maybe (EntityNameDB, SchemaNameDB, ConstraintNameDB, Text, Text)) getRef cname (_, refName') = do let sql = T.concat [ "SELECT DISTINCT " , "ccu.table_name, " + , "ccu.table_schema, " , "tc.constraint_name, " , "rc.update_rule, " , "rc.delete_rule " @@ -1029,6 +1053,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=?" ] @@ -1037,6 +1062,7 @@ getColumn getter tableName' [ PersistText columnName with (stmtQuery stmt [ PersistText $ unEntityNameDB tableName' + , PersistText $ maybe "public" unSchemaNameDB schemaName' , PersistText $ unFieldNameDB cname , PersistText $ unConstraintNameDB refName' ] @@ -1045,8 +1071,8 @@ 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 (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: " @@ -1098,7 +1124,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 @@ -1140,6 +1166,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 +1244,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 +1295,100 @@ 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) - -showAlterTable :: EntityNameDB -> AlterTable -> Text -showAlterTable table (AddUniqueConstraint cname cols) = T.concat +showAlterDb (AlterTable t s at) = (False, showAlterTable t s at) + +showAlterTable + :: EntityNameDB + -> Maybe SchemaNameDB + -- ^ @since 2.13.7 + -> 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 + -- ^ @since 2.13.7 + -> 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 +1397,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 +1436,8 @@ escapeE = escapeWith escape escapeF :: FieldNameDB -> Text escapeF = escapeWith escape +escapeS :: SchemaNameDB -> Text +escapeS = escapeWith escape escape :: Text -> Text escape s = @@ -1406,6 +1447,20 @@ 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 + 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 +1618,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 +1638,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 } -> @@ -1614,7 +1670,7 @@ mockMigration mig = do , connCommit = undefined , connRollback = undefined , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . getEntityDBName + , connEscapeTableName = entityIdentifier , connEscapeRawName = escape , connNoLimit = undefined , connRDBMS = undefined @@ -1815,7 +1871,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 = @@ -1877,7 +1933,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 @@ -2065,4 +2121,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-postgresql/README.md b/persistent-postgresql/README.md index 219bb184a..e5f932878 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. 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 diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 10a726623..b13fde001 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -48,14 +48,15 @@ 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 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-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 diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs index 5b256cdfc..f88601dae 100644 --- a/persistent-qq/test/PersistentTestModels.hs +++ b/persistent-qq/test/PersistentTestModels.hs @@ -110,11 +110,25 @@ 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 AnimalPersonId + 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 +192,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..8bd32e483 100644 --- a/persistent-qq/test/Spec.hs +++ b/persistent-qq/test/Spec.hs @@ -1,26 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} 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.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 ((@?=)) +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 @@ -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 @@ -115,6 +119,21 @@ 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 = AnimalPerson "Zacarias" 93 Nothing + personKey <- insert person + let pet = PetAnimal personKey "Fluffy" + petKey <- insert pet + let runQueryQuoted, runQueryRaw + :: (RawSql a, Functor m, MonadIO m) + => ReaderT SqlBackend m [a] + runQueryQuoted = [sqlQQ| SELECT ?? FROM ^{PetAnimal} |] + runQueryRaw = [sqlQQ| SELECT ?? FROM animals.PetAnimal |] + 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) => val -> ReaderT backend m (Key val, val) 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-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 9deddbd28..d45649896 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" @@ -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 @@ -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" @@ -539,7 +541,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 ", 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 @@ -552,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 @@ -561,30 +566,38 @@ getCopyTable allDefs getter def = do return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y table = getEntityDBName def - tableTmp = EntityNameDB $ unEntityNameDB table <> "_backup" + schema = getEntitySchema def + tableIdentifier = entityIdentifier 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, []) - dropTmp = "DROP TABLE " <> escapeE tableTmp - dropOld = "DROP TABLE " <> escapeE table + -- 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 [ "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,13 +608,13 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) = [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE " - , escapeE $ getEntityDBName entity + , entityIdentifier entity , "(" ] footer = [ T.concat $ map sqlUnique uniqs - , T.concat $ map sqlForeign fdefs + , T.concat $ map (sqlForeign $ getEntitySchema entity) fdefs , ")" ] @@ -646,27 +659,42 @@ sqlColumn noRef (Column name isNull typ def gen _cn _maxLen ref) = T.concat , mayGenerated gen , case ref of Nothing -> "" + -- 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 "" else " REFERENCES " <> escapeE table + 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 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 " - , escapeE $ foreignRefTableDBName fdef + , -- It's not possible for SQLite to maintain foreign key + -- constraints across databases (which Persistent calls "schemas"). + -- 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 @@ -695,6 +723,19 @@ 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 + escapeF :: FieldNameDB -> Text escapeF = escapeWith escape @@ -706,6 +747,12 @@ 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) + putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns (toList fields) ent n where @@ -724,14 +771,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 @@ -824,6 +870,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) @@ -841,9 +891,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 } @@ -851,9 +902,14 @@ 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\")" - , "FROM pragma_foreign_key_check() AS origin" - , "INNER JOIN pragma_foreign_key_list(origin.\"table\") AS foreignkeys" + [ "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 + -- 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" ] 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 diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 2c54ec8bd..323ad09a4 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module SqliteInit ( (@/=), (@==), (==@) @@ -16,6 +17,7 @@ module SqliteInit ( , db , sqlite_database , sqlite_database_file + , sqlite_foo_database_file , BackendKey(..) , GenerateKey(..) @@ -43,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) @@ -90,6 +112,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 @@ -99,9 +124,10 @@ 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 runResourceT $ runConn $ actions >> transactionUndo - diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 96234efcd..d1baa01bb 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -37,13 +37,14 @@ 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 import qualified Recursive import qualified RenameTest +import qualified SchemaTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified TypeLitFieldDefsTest @@ -151,6 +152,8 @@ main :: IO () main = do handle (\(_ :: IOException) -> return ()) $ removeFile $ fromText sqlite_database_file + handle (\(_ :: IOException) -> return ()) + $ removeFile $ fromText sqlite_foo_database_file runConn $ do mapM_ setup @@ -176,6 +179,8 @@ main = do , MigrationColumnLengthTest.migration , TransactionLevelTest.migration , LongIdentifierTest.migration + , SchemaTest.migration + , SchemaTest.migration ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -244,6 +249,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 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 diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 72e900b80..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 @@ -57,10 +57,11 @@ library UniqueTest UpsertTest LongIdentifierTest + SchemaTest hs-source-dirs: src - build-depends: + build-depends: base >= 4.9 && < 5 , aeson >= 1.0 , blaze-html >= 0.9 @@ -76,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 diff --git a/persistent-test/src/SchemaTest.hs b/persistent-test/src/SchemaTest.hs new file mode 100644 index 000000000..0d7c7ee8b --- /dev/null +++ b/persistent-test/src/SchemaTest.hs @@ -0,0 +1,58 @@ +{-# 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 + bar Int + Primary bar + +DefaultSchemaEntity sql=schema_entity + bar Int + Primary bar +|] + +cleanDB + :: + ( PersistQueryWrite backend + , MonadIO m + , PersistStoreWrite (BaseBackend backend) + ) + => ReaderT backend m () +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" $ do + it "inserts and selects work as expected" $ asIO $ runConn $ do + -- Ensure we can write to the database + x <- insert $ + SchemaEntity + { schemaEntityBar = 42 + } + Just schemaEntity <- get x + rawBar <- rawSql "SELECT bar FROM foo.schema_entity" [] + 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 () 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/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs index 4e2fe93fc..dcc2f2bd5 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,13 @@ 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 + -- | -- -- @since 2.13.0.0 @@ -195,6 +204,12 @@ 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 } + -- | 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 5616e627c..bb12d2f1d 100644 --- a/persistent/Database/Persist/Names.hs +++ b/persistent/Database/Persist/Names.hs @@ -70,3 +70,13 @@ instance DatabaseName ConstraintNameDB where -- @since 2.12.0.0 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) + +instance DatabaseName SchemaNameDB where + escapeWith f (SchemaNameDB n) = f n diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 451f92229..e41292d6c 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 diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index aad9ec76f..0ab0039fd 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -310,6 +310,8 @@ parseLines ps = do data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefSchemaName :: Maybe SchemaNameDB + -- ^ @since 2.14.7 , parsedEntityDefIsSum :: Bool , parsedEntityDefEntityAttributes :: [Attr] , parsedEntityDefFieldAttributes :: [[Token]] @@ -329,6 +331,7 @@ toParsedEntityDef :: LinesWithComments -> ParsedEntityDef toParsedEntityDef lwc = ParsedEntityDef { parsedEntityDefComments = lwcComments lwc , parsedEntityDefEntityName = entNameHS + , parsedEntityDefSchemaName = schemaName , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entAttribs , parsedEntityDefFieldAttributes = attribs @@ -349,6 +352,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,6 +718,7 @@ mkUnboundEntityDef ps parsedEntDef = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) + , entitySchema = parsedEntityDefSchemaName parsedEntDef } } where @@ -1390,6 +1397,9 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName + , foreignRefSchemaDBName = + Nothing + -- ^ This will be determined in the TH phase ('fixForeignRefSchemaDBName'). , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index c8e099fee..22bf143cd 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,27 +178,28 @@ mkColumns allDefs t overrides = ref :: FieldNameDB -> ReferenceDef -> [FieldAttr] - -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name + -> Maybe (EntityNameDB, Maybe SchemaNameDB, ConstraintNameDB) -- table name, schema name, constraint name ref c fe [] | ForeignRef f <- fe = - Just (resolveTableName allDefs f, refNameFn tableName c) + 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 - (_, constraintName) <- ref c fe as - pure (EntityNameDB x, constraintName) + (_, schema, constraintName) <- ref c fe as + pure (EntityNameDB x, schema, constraintName) FieldAttrConstraint x -> do - (tableName_, _) <- ref c fe as - pure (tableName_, ConstraintNameDB x) + (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 diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index a9f592d86..b221022bb 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -36,9 +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. -- @@ -137,4 +141,3 @@ defaultConnectionPoolConfig = ConnectionPoolConfig 1 600 10 -- processing). newtype Single a = Single {unSingle :: a} deriving (Eq, Ord, Show, Read) - diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index de01e8f25..36440d246 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 = - entityDB (unboundEntityDef parentDef) + getEntityDBName (unboundEntityDef parentDef) + fixForeignRefSchemaDBName = + getEntitySchema (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of FieldListImpliedId ffns -> @@ -1968,7 +1972,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..5aae1f589 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -155,6 +155,10 @@ data EntityDef = EntityDef -- ^ Optional comments on the entity. -- -- @since 2.10.0 + , entitySchema :: !(Maybe SchemaNameDB) + -- ^ The schema the entity belongs to. + -- + -- @since 2.14.7 } deriving (Show, Eq, Read, Ord, Lift) @@ -552,6 +556,10 @@ type ForeignFieldDef = (FieldNameHS, FieldNameDB) 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 diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 02356ee9f..6d08fe27e 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -332,6 +332,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/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index b4e694e57..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,7 +80,7 @@ ChildImplicit name Text parent ParentImplicitId OnDeleteCascade OnUpdateCascade -ParentExplicit +ParentExplicit schema=adult name Text Primary name @@ -176,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 ed971977d..1397f8dbe 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -71,14 +71,13 @@ 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 @@ -371,6 +370,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 @@ -506,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