diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 0f2702831..d27f4a3d1 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-mysql +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13` changes for SqlBackend being made internal. + * Remove the deprecated `SomeField` type and pattern. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index d6f65dc98..5de7eaac2 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -26,8 +26,6 @@ module Database.Persist.MySQL , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate , HandleUpdateCollision - , pattern SomeField - , SomeField , copyField , copyUnlessNull , copyUnlessEmpty @@ -72,6 +70,7 @@ import qualified Data.Text.IO as T import System.Environment (getEnvironment) import Database.Persist.Sql +import Database.Persist.SqlBackend import Database.Persist.Sql.Types.Internal (makeIsolationLevelStatement) import qualified Database.Persist.Sql.Util as Util @@ -86,40 +85,40 @@ import qualified Database.MySQL.Simple.Types as MySQL -- The pool is properly released after the action finishes using -- it. Note that you should not use the given 'ConnectionPool' -- outside the action since it may be already been released. -withMySQLPool :: (MonadLoggerIO m, MonadUnliftIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> Int - -- ^ Number of connections to be kept open in the pool. - -> (Pool SqlBackend -> m a) - -- ^ Action to be executed that uses the connection pool. - -> m a +withMySQLPool + :: (MonadLoggerIO m, MonadUnliftIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the connection pool. + -> m a withMySQLPool ci = withSqlPool $ open' ci - -- | Create a MySQL connection pool. Note that it's your -- responsibility to properly close the connection pool when -- unneeded. Use 'withMySQLPool' for automatic resource control. -createMySQLPool :: (MonadUnliftIO m, MonadLoggerIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> Int - -- ^ Number of connections to be kept open in the pool. - -> m (Pool SqlBackend) +createMySQLPool + :: (MonadUnliftIO m, MonadLoggerIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) createMySQLPool ci = createSqlPool $ open' ci - -- | Same as 'withMySQLPool', but instead of opening a pool -- of connections, only one connection is opened. -withMySQLConn :: (MonadUnliftIO m, MonadLoggerIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> (SqlBackend -> m a) - -- ^ Action to be executed that uses the connection. - -> m a +withMySQLConn + :: (MonadUnliftIO m, MonadLoggerIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> (SqlBackend -> m a) + -- ^ Action to be executed that uses the connection. + -> m a withMySQLConn = withSqlConn . open' - -- | Internal function that opens a connection to the MySQL -- server. open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend @@ -127,32 +126,30 @@ open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! smap <- newIORef $ Map.empty - return $ SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Nothing - , connUpsertSql = Nothing - , connPutManySql = Just putManySql - , connClose = MySQL.close conn - , connMigrateSql = migrate' ci - , connBegin = \_ mIsolation -> do - forM_ mIsolation $ \iso -> MySQL.execute_ conn (makeIsolationLevelStatement iso) - MySQL.execute_ conn "start transaction" >> return () - , connCommit = const $ MySQL.commit conn - , connRollback = const $ MySQL.rollback conn - , connEscapeFieldName = T.pack . escapeF - , connEscapeTableName = T.pack . escapeE . entityDB - , connEscapeRawName = T.pack . escapeDBName . T.unpack - , connNoLimit = "LIMIT 18446744073709551615" - -- This noLimit is suggested by MySQL's own docs, see - -- - , connRDBMS = "mysql" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" - , connLogFunc = logFunc - , connMaxParams = Nothing - , connRepsertManySql = Just repsertManySql - } + return $ + setConnPutManySql putManySql $ + setConnRepsertManySql repsertManySql $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = MySQL.close conn + , connMigrateSql = migrate' ci + , connBegin = \_ mIsolation -> do + forM_ mIsolation $ \iso -> MySQL.execute_ conn (makeIsolationLevelStatement iso) + MySQL.execute_ conn "start transaction" >> return () + , connCommit = const $ MySQL.commit conn + , connRollback = const $ MySQL.rollback conn + , connEscapeFieldName = T.pack . escapeF + , connEscapeTableName = T.pack . escapeE . entityDB + , connEscapeRawName = T.pack . escapeDBName . T.unpack + , connNoLimit = "LIMIT 18446744073709551615" + -- This noLimit is suggested by MySQL's own docs, see + -- + , connRDBMS = "mysql" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" + , connLogFunc = logFunc + } -- | Prepare a query. We don't support prepared statements, but -- we'll do some client-side preprocessing here. @@ -1244,37 +1241,34 @@ mockMigrate _connectInfo allDefs _getter val = do -- the actual database isn't already present in the system. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - }, - connInsertManySql = Nothing, - connInsertSql = undefined, - connStmtMap = smap, - connClose = undefined, - connMigrateSql = mockMigrate undefined, - connBegin = undefined, - connCommit = undefined, - connRollback = undefined, - connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB, - connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . entityDB, - connEscapeRawName = T.pack . escapeDBName . T.unpack, - connNoLimit = undefined, - connRDBMS = undefined, - connLimitOffset = undefined, - connLogFunc = undefined, - connUpsertSql = undefined, - connPutManySql = undefined, - connMaxParams = Nothing, - connRepsertManySql = Nothing - } - result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend - mapM_ T.putStrLn $ map snd $ snd resp + smap <- newIORef $ Map.empty + let sqlbackend = + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connInsertSql = undefined + , connStmtMap = smap + , connClose = undefined + , connMigrateSql = mockMigrate undefined + , connBegin = undefined + , connCommit = undefined + , connRollback = undefined + , connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB + , connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . entityDB + , connEscapeRawName = T.pack . escapeDBName . T.unpack + , connNoLimit = undefined + , connRDBMS = undefined + , connLimitOffset = undefined + , connLogFunc = undefined + } + result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp -- | MySQL specific 'upsert_'. This will prevent multiple queries, when one will -- do. The record will be inserted into the database. In the event that the @@ -1299,21 +1293,10 @@ insertOnDuplicateKeyUpdate record = -- -- @since 2.8.0 data HandleUpdateCollision record where - -- | Copy the field directly from the record. - CopyField :: EntityField record typ -> HandleUpdateCollision record - -- | Only copy the field if it is not equal to the provided value. - CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record - --- | An alias for 'HandleUpdateCollision'. The type previously was only --- used to copy a single value, but was expanded to be handle more complex --- queries. --- --- @since 2.6.2 -type SomeField = HandleUpdateCollision - -pattern SomeField :: EntityField record typ -> SomeField record -pattern SomeField x = CopyField x -{-# DEPRECATED SomeField "The type SomeField is deprecated. Use the type HandleUpdateCollision instead, and use the function copyField instead of the data constructor." #-} + -- | Copy the field directly from the record. + CopyField :: EntityField record typ -> HandleUpdateCollision record + -- | Only copy the field if it is not equal to the provided value. + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index f17a26847..d9e6708f3 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 2.12.0.0 +version: 2.13.0.0 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.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10.8 diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 580e69507..cc07605db 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-postgresql + +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13.0.0` making SQlBackend internal + # 2.12.1.1 * [#1235](https://github.com/yesodweb/persistent/pull/1235) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 11f565d0b..6313b6802 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -103,6 +103,7 @@ import Data.Time (NominalDiffTime, localTimeToUTC, utc) import System.Environment (getEnvironment) import Database.Persist.Sql +import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection @@ -348,14 +349,15 @@ openSimpleConnWithVersion getVerDouble logFunc conn = do -- and connection. createBackend :: LogFunc -> NonEmpty Word -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend -createBackend logFunc serverVersion smap conn = do - SqlBackend +createBackend logFunc serverVersion smap conn = + maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ + maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ + setConnInsertManySql insertManySql' $ + maybe id setConnRepsertManySql (upsertFunction repsertManySql serverVersion) $ + mkSqlBackend MkSqlBackendArgs { connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = insertSql' - , connInsertManySql = Just insertManySql' - , connUpsertSql = upsertFunction upsertSql' serverVersion - , connPutManySql = upsertFunction putManySql serverVersion , connClose = PG.close conn , connMigrateSql = migrate' , connBegin = \_ mIsolation -> case mIsolation of @@ -374,8 +376,6 @@ createBackend logFunc serverVersion smap conn = do , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" , connLogFunc = logFunc - , connMaxParams = Nothing - , connRepsertManySql = upsertFunction repsertManySql serverVersion } prepare' :: PG.Connection -> Text -> IO Statement @@ -1706,37 +1706,34 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do -- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - }, - connInsertManySql = Nothing, - connInsertSql = undefined, - connUpsertSql = Nothing, - connPutManySql = Nothing, - connStmtMap = smap, - connClose = undefined, - connMigrateSql = mockMigrate, - connBegin = undefined, - connCommit = undefined, - connRollback = undefined, - connEscapeFieldName = escapeF, - connEscapeTableName = escapeE . entityDB, - connEscapeRawName = escape, - connNoLimit = undefined, - connRDBMS = undefined, - connLimitOffset = undefined, - connLogFunc = undefined, - connMaxParams = Nothing, - connRepsertManySql = Nothing - } - result = runReaderT $ runWriterT $ runWriterT mig - resp <- result sqlbackend - mapM_ T.putStrLn $ map snd $ snd resp + smap <- newIORef $ Map.empty + let sqlbackend = + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connInsertSql = undefined + , connStmtMap = smap + , connClose = undefined + , connMigrateSql = mockMigrate + , connBegin = undefined + , connCommit = undefined + , connRollback = undefined + , connEscapeFieldName = escapeF + , connEscapeTableName = escapeE . entityDB + , connEscapeRawName = escape + , connNoLimit = undefined + , connRDBMS = undefined + , connLimitOffset = undefined + , connLogFunc = undefined + } + result = runReaderT $ runWriterT $ runWriterT mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns fields ent n @@ -2025,7 +2022,5 @@ migrateEnableExtension extName = WriterT $ WriterT $ do postgresMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) postgresMkColumns allDefs t = - mkColumns allDefs t (emptyBackendSpecificOverrides - { backendSpecificForeignKeyName = Just refName - } - ) + mkColumns allDefs t + $ setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 279d4af0e..f73a5888c 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.12.1.1 +version: 2.13.0.0 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.12.1.0 && < 2.13 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , attoparsec , blaze-builder diff --git a/persistent-postgresql/test/ArrayAggTest.hs b/persistent-postgresql/test/ArrayAggTest.hs index 1f8167165..b8902a114 100644 --- a/persistent-postgresql/test/ArrayAggTest.hs +++ b/persistent-postgresql/test/ArrayAggTest.hs @@ -43,7 +43,7 @@ specs = do , UserPT "c" $ Just "d" , UserPT "e" Nothing , UserPT "g" $ Just "h" ] - escape <- asks connEscapeRawName + escape <- getEscapeRawNameFunction let query = T.concat [ "SELECT array_agg(", escape dbField, ") " , "FROM ", escape "UserPT" ] diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index 5cc14c55d..122b65228 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -18,6 +18,7 @@ module PgInit , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql + , module Database.Persist.SqlBackend , module Database.Persist , module Database.Persist.Sql.Raw.QQ , module Init @@ -62,6 +63,8 @@ import Control.Monad.Trans.Reader import Data.Aeson (Value(..)) import Database.Persist.Postgresql.JSON () import Database.Persist.Sql.Raw.QQ +import Database.Persist.SqlBackend +import Database.Persist.Postgresql.JSON() import Database.Persist.TH ( MkPersistSettings(..) , mkMigrate @@ -77,13 +80,13 @@ import Test.Hspec import Test.Hspec.Expectations.Lifted import Test.QuickCheck.Instances () import UnliftIO +import Database.Persist.SqlBackend -- testing import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Test.QuickCheck import Control.Monad (unless, (>=>)) - import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index 9aa454e68..7a8f0a71e 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-sqlite +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13` changes for SqlBackend being made internal. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 8b2cd8c51..5b636f541 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -90,6 +90,7 @@ import UnliftIO.Resource (ResourceT, runResourceT) import Database.Persist.Compatible #endif import Database.Persist.Sql +import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util import qualified Database.Sqlite as Sqlite @@ -267,28 +268,27 @@ wrapConnectionInfo connInfo conn logFunc = do Sqlite.finalize stmt smap <- newIORef $ Map.empty - return $ SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connUpsertSql = Nothing - , connPutManySql = Just putManySql - , connInsertManySql = Nothing - , connClose = Sqlite.close conn - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = logFunc - , connMaxParams = Just 999 - , connRepsertManySql = Just repsertManySql - } + return $ + setConnMaxParams 999 $ + setConnPutManySql putManySql $ + setConnRepsertManySql repsertManySql $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = Sqlite.close conn + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = logFunc + } where helper t getter = do stmt <- getter t @@ -454,44 +454,42 @@ migrate' allDefs getter val = do -- with the difference that an actual database isn't needed for it. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend - { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - } - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Nothing - , connClose = undefined - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = undefined - , connUpsertSql = undefined - , connPutManySql = undefined - , connMaxParams = Just 999 - , connRepsertManySql = Nothing - } - result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend - mapM_ TIO.putStrLn $ map snd $ snd resp - where - helper t getter = do - stmt <- getter t - _ <- stmtExecute stmt [] - stmtReset stmt - ignoreExceptions = E.handle (\(_ :: E.SomeException) -> return ()) + smap <- newIORef $ Map.empty + let sqlbackend = + setConnMaxParams 999 $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = undefined + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = undefined + } + result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend + mapM_ TIO.putStrLn $ map snd $ snd resp + where + helper t getter = do + stmt <- getter t + _ <- stmtExecute stmt [] + stmtReset stmt + ignoreExceptions = + E.handle (\(_ :: E.SomeException) -> return ()) -- | Check if a column name is listed as the "safe to remove" in the entity -- list. diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index 81c0ab452..1ccc12f1b 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -44,7 +44,7 @@ flag use-stat4 library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , bytestring >= 0.10 , conduit >= 1.2.12 diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 47595f80e..9c299728e 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -84,21 +84,23 @@ _debugOn = False persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } + type BackendMonad = SqlBackend sqlite_database_file :: Text sqlite_database_file = "testdb.sqlite3" + sqlite_database :: SqliteConnectionInfo sqlite_database = mkSqliteConnectionInfo sqlite_database_file + runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () runConn f = do - travis <- liftIO isTravis - let debugPrint = not travis && _debugOn - let printDebug = if debugPrint then print . fromLogStr else void . return - flip runLoggingT (\_ _ _ s -> printDebug s) $ do - _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f - return () + travis <- liftIO isTravis + 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 db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do - runResourceT $ runConn $ actions >> transactionUndo + runResourceT $ runConn $ actions >> transactionUndo diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index dcfe7dd5b..b2e3d5b90 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -176,160 +176,161 @@ setup migration = do main :: IO () main = do - handle (\(_ :: IOException) -> return ()) - $ removeFile $ fromText sqlite_database_file - - runConn $ do - mapM_ setup - [ ForeignKey.compositeMigrate - , PersistentTest.testMigrate - , PersistentTest.noPrefixMigrate - , PersistentTest.customPrefixMigrate - , EmbedTest.embedMigrate - , EmbedOrderTest.embedOrderMigrate - , LargeNumberTest.numberMigrate - , UniqueTest.uniqueMigrate - , MaxLenTest.maxlenMigrate - , Recursive.recursiveMigrate - , CompositeTest.compositeMigrate - , MigrationTest.migrationMigrate - , PersistUniqueTest.migration - , RenameTest.migration - , CustomPersistFieldTest.customFieldMigrate - , PrimaryTest.migration - , CustomPrimaryKeyReferenceTest.migration - , MigrationColumnLengthTest.migration - , TransactionLevelTest.migration - , LongIdentifierTest.migration - ] - PersistentTest.cleanDB - ForeignKey.cleanDB - - hspec $ do - RenameTest.specsWith db - DataTypeTest.specsWith - db - (Just (runMigrationSilent dataTypeMigrate)) - [ TestFn "text" dataTypeTableText - , TestFn "textMaxLen" dataTypeTableTextMaxLen - , TestFn "bytes" dataTypeTableBytes - , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple - , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen - , TestFn "int" dataTypeTableInt - , TestFn "intList" dataTypeTableIntList - , TestFn "intMap" dataTypeTableIntMap - , TestFn "bool" dataTypeTableBool - , TestFn "day" dataTypeTableDay - , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) - , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) - ] - [ ("pico", dataTypeTablePico) ] - dataTypeTableDouble - HtmlTest.specsWith - db - (Just (runMigrationSilent HtmlTest.htmlMigrate)) - EmbedTest.specsWith db - EmbedOrderTest.specsWith db - LargeNumberTest.specsWith db - UniqueTest.specsWith db - MaxLenTest.specsWith db - Recursive.specsWith db - SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationOnlyTest.specsWith db - (Just - $ runMigrationSilent MigrationOnlyTest.migrateAll1 - >> runMigrationSilent MigrationOnlyTest.migrateAll2 - ) - PersistentTest.specsWith db - PersistentTest.filterOrSpecs db - ReadWriteTest.specsWith db - RawSqlTest.specsWith db - UpsertTest.specsWith - db - UpsertTest.Don'tUpdateNull - UpsertTest.UpsertPreserveOldKey - - MpsNoPrefixTest.specsWith db - MpsCustomPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith db - PersistUniqueTest.specsWith db - PrimaryTest.specsWith db - CustomPersistFieldTest.specsWith db - CustomPrimaryKeyReferenceTest.specsWith db - MigrationColumnLengthTest.specsWith db - EquivalentTypeTest.specsWith db - ForeignKey.specsWith db - TransactionLevelTest.specsWith db - MigrationTest.specsWith db - LongIdentifierTest.specsWith db - GeneratedColumnTestSQL.specsWith db - - it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - insert_ . Test $ read "2014-11-30 05:15:25.123Z" - [Single x] <- rawSql "select strftime('%s%f',time) from test" [] - liftIO $ x `shouldBe` Just ("141732452525.123" :: String) - it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - now <- liftIO getCurrentTime - tid <- insert $ Test now - Just (Test now') <- get tid - liftIO $ now' `shouldBe` now - it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - conn <- Sqlite.open (T.pack fp) - Sqlite.close conn - return () - it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent migrateAll - insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z") - - it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent compositeSetup - void $ runMigrationSilent compositeMigrateTest - pure () - - it "test migrating sparse primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) - runSqliteInfo connInfo $ do - void $ runMigrationSilent idSetup - forM_ (map toSqlKey [1,3]) $ \key -> do - insertKey key (Simple "foo") - insert (SimpleReference key "test") - - validateForeignKeys - - runSqliteInfo connInfo $ do - void $ runMigrationSilent idMigrateTest - validateForeignKeys - - it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do - hClose h - let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) - - runSqliteInfo connInfo $ do + handle (\(_ :: IOException) -> return ()) + $ removeFile $ fromText sqlite_database_file + + runConn $ do + mapM_ setup + [ ForeignKey.compositeMigrate + , PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate + , MigrationTest.migrationMigrate + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate + , PrimaryTest.migration + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + , TransactionLevelTest.migration + , LongIdentifierTest.migration + ] + PersistentTest.cleanDB + ForeignKey.cleanDB + + + hspec $ do + RenameTest.specsWith db + DataTypeTest.specsWith + db + (Just (runMigrationSilent dataTypeMigrate)) + [ TestFn "text" dataTypeTableText + , TestFn "textMaxLen" dataTypeTableTextMaxLen + , TestFn "bytes" dataTypeTableBytes + , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple + , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen + , TestFn "int" dataTypeTableInt + , TestFn "intList" dataTypeTableIntList + , TestFn "intMap" dataTypeTableIntMap + , TestFn "bool" dataTypeTableBool + , TestFn "day" dataTypeTableDay + , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) + , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) + ] + [ ("pico", dataTypeTablePico) ] + dataTypeTableDouble + HtmlTest.specsWith + db + (Just (runMigrationSilent HtmlTest.htmlMigrate)) + EmbedTest.specsWith db + EmbedOrderTest.specsWith db + LargeNumberTest.specsWith db + UniqueTest.specsWith db + MaxLenTest.specsWith db + Recursive.specsWith db + SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) + MigrationOnlyTest.specsWith db + (Just + $ runMigrationSilent MigrationOnlyTest.migrateAll1 + >> runMigrationSilent MigrationOnlyTest.migrateAll2 + ) + PersistentTest.specsWith db + PersistentTest.filterOrSpecs db + ReadWriteTest.specsWith db + RawSqlTest.specsWith db + UpsertTest.specsWith + db + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey + + MpsNoPrefixTest.specsWith db + MpsCustomPrefixTest.specsWith db + EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith db + PersistUniqueTest.specsWith db + PrimaryTest.specsWith db + CustomPersistFieldTest.specsWith db + CustomPrimaryKeyReferenceTest.specsWith db + MigrationColumnLengthTest.specsWith db + EquivalentTypeTest.specsWith db + ForeignKey.specsWith db + TransactionLevelTest.specsWith db + MigrationTest.specsWith db + LongIdentifierTest.specsWith db + GeneratedColumnTestSQL.specsWith db + + it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + insert_ . Test $ read "2014-11-30 05:15:25.123Z" + [Single x] <- rawSql "select strftime('%s%f',time) from test" [] + liftIO $ x `shouldBe` Just ("141732452525.123" :: String) + it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + now <- liftIO getCurrentTime + tid <- insert $ Test now + Just (Test now') <- get tid + liftIO $ now' `shouldBe` now + it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do + hClose h + conn <- Sqlite.open (T.pack fp) + Sqlite.close conn + return () + it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent migrateAll + insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z") + + it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do void $ runMigrationSilent compositeSetup - forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do - let key = SimpleCompositeKey strKey intKey - insertKey key (SimpleComposite intKey strKey) - insert (SimpleCompositeReference intKey strKey "test") - - validateForeignKeys - - runSqliteInfo connInfo $ do void $ runMigrationSilent compositeMigrateTest - validateForeignKeys - - it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - void $ runMigrationSilent testMigrate - let catcher :: forall m. Monad m => SomeException -> m () - catcher _ = return () - insert_ $ Person "A" 0 Nothing - insert_ (Person "A" 1 Nothing) `catch` catcher - insert_ $ Person "B" 0 Nothing - return () + pure () + + it "test migrating sparse primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do + hClose h + let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) + runSqliteInfo connInfo $ do + void $ runMigrationSilent idSetup + forM_ (map toSqlKey [1,3]) $ \key -> do + insertKey key (Simple "foo") + insert (SimpleReference key "test") + + validateForeignKeys + + runSqliteInfo connInfo $ do + void $ runMigrationSilent idMigrateTest + validateForeignKeys + + it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do + hClose h + let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp) + + runSqliteInfo connInfo $ do + void $ runMigrationSilent compositeSetup + forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do + let key = SimpleCompositeKey strKey intKey + insertKey key (SimpleComposite intKey strKey) + insert (SimpleCompositeReference intKey strKey "test") + + validateForeignKeys + + runSqliteInfo connInfo $ do + void $ runMigrationSilent compositeMigrateTest + validateForeignKeys + + it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do + void $ runMigrationSilent testMigrate + let catcher :: forall m. Monad m => SomeException -> m () + catcher _ = return () + insert_ $ Person "A" 0 Nothing + insert_ (Person "A" 1 Nothing) `catch` catcher + insert_ $ Person "B" 0 Nothing + return () validateForeignKeys :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) diff --git a/persistent-test/ChangeLog.md b/persistent-test/ChangeLog.md index 11de8b423..35abcb958 100644 --- a/persistent-test/ChangeLog.md +++ b/persistent-test/ChangeLog.md @@ -1,5 +1,10 @@ ## Unreleased changes +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13` changes for SqlBackend being made internal. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 31d232c8c..a03d8ea55 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -1,5 +1,5 @@ name: persistent-test -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -60,7 +60,7 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 2.13 + , persistent >= 2.13 && < 2.14 , aeson >= 1.0 , blaze-html >= 0.9 , bytestring >= 0.10 diff --git a/persistent-test/src/RawSqlTest.hs b/persistent-test/src/RawSqlTest.hs index 4c26cd65f..33f6e9d97 100644 --- a/persistent-test/src/RawSqlTest.hs +++ b/persistent-test/src/RawSqlTest.hs @@ -8,6 +8,7 @@ import qualified Data.Conduit.List as CL import qualified Data.Text as T import Init +import Database.Persist.SqlBackend import PersistTestPetType import PersistentTestModels @@ -141,7 +142,7 @@ specsWith runDb = describe "rawSql" $ do liftIO $ ret @?= [(Single (1::Int), Single (2::Int), Single (3::Int), Single (4::Int), Single (5::Int), Single (6::Int), Single (7::Int), Single (8::Int), Single (9::Int), Single (10::Int), Single (11::Int), Single (12::Int), Single (13::Int), Single (14::Int), Single (15::Int))] getEscape :: MonadReader SqlBackend m => m (Text -> Text) -getEscape = asks connEscapeRawName +getEscape = getEscapeRawNameFunction caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion caseCommitRollback runDb = runDb $ do diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 951eaf947..6082996bd 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,37 @@ # Changelog for persistent +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * The fields and constructor for `SqlBackend` are no longer exported by + default. They are available from an internal module, + `Database.Persist.Sql.Types.Internal`. Breaking changes from `Internal` + modules are not reflected in the major version. This will allow us to + release new functionality without breaking your code. It's recommended to + switch to using the smart constructor functions and setter functions that + are now exported from `Database.Persist.Sql` instead. + * A new API is available for constructing and using a `SqlBackend`, provided + in `Database.Persist.SqlBackend`. Instead of using the `SqlBackend` + directly, use `mkSqlBackend` and the datatype `MkSqlBackendArgs`. The + `MkSqlBackendArgs` record has the same field names as the `SqlBackend`, so + the translation is easy: + ```diff +- SqlBackend ++ mkSqlBackend MkSqlBackendArgs + { connInsertSql = ... + , connCommit = ... + , connEscapeFieldName = ... + , connEscapeTableName = ... + , etc + } + ``` + Some fields were omitted in `MkSqlBackendArgs`. These fields are + *optional* - they provide enhanced or backend-specific functionality. For + these, use the setter functions like `setConnUpsertSql`. + * Previously hidden modules are now exposed under the `Internal` namespace. + * The `connLimitOffset` function used to have a `Bool` parameter. This + parameter is unused and has been removed. + ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231) diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index 80e280a70..fb87c1657 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -55,8 +55,7 @@ import Database.Persist.Types -- you must manually place a unique index on a field to have a uniqueness -- constraint. -- -class (PersistCore backend, PersistStoreRead backend) => - PersistUniqueRead backend where +class PersistStoreRead backend => PersistUniqueRead backend where -- | Get a record by unique key, if available. Returns also the identifier. -- -- === __Example usage__ diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 9a6a88672..fdc98d9e2 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -419,810 +419,6 @@ module Database.Persist.Quasi , upperCaseSettings , lowerCaseSettings , nullable -#if TEST - , Token (..) - , Line (..) - , preparse - , parseLine - , parseFieldType - , associateLines - , LinesWithComments(..) - , splitExtras - , takeColsEx -#endif ) where -import Prelude hiding (lines) - -import Control.Applicative (Alternative((<|>))) -import Control.Arrow ((&&&)) -import Control.Monad (mplus, msum) -import Data.Char (isLower, isSpace, isUpper, toLower) -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, maybeToList) -import Data.Monoid (mappend) -#if !MIN_VERSION_base(4,11,0) --- This can be removed when GHC < 8.2.2 isn't supported anymore -import Data.Semigroup ((<>)) -#endif -import Data.Text (Text) -import qualified Data.Text as T -import Database.Persist.Types -import Text.Read (readEither) - -data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show - -parseFieldType :: Text -> Either String FieldType -parseFieldType t0 = - case parseApplyFT t0 of - PSSuccess ft t' - | T.all isSpace t' -> Right ft - PSFail err -> Left $ "PSFail " ++ err - other -> Left $ show other - where - parseApplyFT t = - case goMany id t of - PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' - PSSuccess [] _ -> PSFail "empty" - PSFail err -> PSFail err - PSDone -> PSDone - - parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType - parseEnclosed end ftMod t = - let (a, b) = T.break (== end) t - in case parseApplyFT a of - PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of - ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') - (x, y) -> PSFail $ show (b, x, y) - x -> PSFail $ show x - - parse1 t = - case T.uncons t of - Nothing -> PSDone - Just (c, t') - | isSpace c -> parse1 $ T.dropWhile isSpace t' - | c == '(' -> parseEnclosed ')' id t' - | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b - | otherwise -> PSFail $ show (c, t') - getCon t = - case T.breakOnEnd "." t of - (_, "") -> FTTypeCon Nothing t - ("", _) -> FTTypeCon Nothing t - (a, b) -> FTTypeCon (Just $ T.init a) b - goMany front t = - case parse1 t of - PSSuccess x t' -> goMany (front . (x:)) t' - PSFail err -> PSFail err - PSDone -> PSSuccess (front []) t - -- _ -> - -data PersistSettings = PersistSettings - { psToDBName :: !(Text -> Text) - , psStrictFields :: !Bool - -- ^ Whether fields are by default strict. Default value: @True@. - -- - -- @since 1.2 - , psIdName :: !Text - -- ^ The name of the id column. Default value: @id@ - -- The name of the id column can also be changed on a per-model basis - -- - -- - -- @since 2.0 - } - -defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings -defaultPersistSettings = PersistSettings - { psToDBName = id - , psStrictFields = True - , psIdName = "id" - } - -upperCaseSettings = defaultPersistSettings - -lowerCaseSettings = defaultPersistSettings - { psToDBName = - let go c - | isUpper c = T.pack ['_', toLower c] - | otherwise = T.singleton c - in T.dropWhile (== '_') . T.concatMap go - } - --- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: PersistSettings -> Text -> [EntityDef] -parse ps = maybe [] (parseLines ps) . preparse - -preparse :: Text -> Maybe (NonEmpty Line) -preparse txt = do - lns <- NEL.nonEmpty (T.lines txt) - NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) - -parseLine :: Text -> Maybe Line -parseLine txt = do - Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt) - --- | A token used by the parser. -data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. - | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. - deriving (Show, Eq) - -tokenText :: Token -> Text -tokenText tok = - case tok of - Token t -> t - DocComment t -> "-- | " <> t - -parseIndentationAmount :: Text -> Int -parseIndentationAmount txt = - let (spaces, _) = T.span isSpace txt - in T.length spaces - --- | Tokenize a string. -tokenize :: Text -> [Token] -tokenize t - | T.null t = [] - | Just txt <- T.stripPrefix "-- | " t = [DocComment txt] - | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. - | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) - | T.head t == '"' = quotes (T.tail t) id - | T.head t == '(' = parens 1 (T.tail t) id - | isSpace (T.head t) = - tokenize (T.dropWhile isSpace t) - - -- support mid-token quotes and parens - | Just (beforeEquals, afterEquals) <- findMidToken t - , not (T.any isSpace beforeEquals) - , Token next : rest <- tokenize afterEquals = - Token (T.concat [beforeEquals, "=", next]) : rest - - | otherwise = - let (token, rest) = T.break isSpace t - in Token token : tokenize rest - where - findMidToken t' = - case T.break (== '=') t' of - (x, T.drop 1 -> y) - | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) - _ -> Nothing - - quotes t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated quoted string starting with " : front [] - | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') - | T.head t' == '\\' && T.length t' > 1 = - quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','\"']) t' - in quotes y (front . (x:)) - parens count t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated parens string starting with " : front [] - | T.head t' == ')' = - if count == (1 :: Int) - then Token (T.concat $ front []) : tokenize (T.tail t') - else parens (count - 1) (T.tail t') (front . (")":)) - | T.head t' == '(' = - parens (count + 1) (T.tail t') (front . ("(":)) - | T.head t' == '\\' && T.length t' > 1 = - parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','(',')']) t' - in parens count y (front . (x:)) - --- | A line of parsed tokens -data Line = Line - { lineIndent :: Int - , tokens :: NonEmpty Token - } deriving (Eq, Show) - -lineText :: Line -> NonEmpty Text -lineText = fmap tokenText . tokens - -lowestIndent :: NonEmpty Line -> Int -lowestIndent = minimum . fmap lineIndent - --- | Divide lines into blocks and make entity definitions. -parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] -parseLines ps = - fixForeignKeysAll . map mk . associateLines - where - mk :: LinesWithComments -> UnboundEntityDef - mk lwc = - let ln :| rest = lwcLines lwc - (name :| entAttribs) = lineText ln - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest - -isDocComment :: Token -> Maybe Text -isDocComment tok = - case tok of - DocComment txt -> Just txt - _ -> Nothing - -data LinesWithComments = LinesWithComments - { lwcLines :: NonEmpty Line - , lwcComments :: [Text] - } deriving (Eq, Show) - --- TODO: drop this and use <> when 8.2 isn't supported anymore so the --- monoid/semigroup nonsense isn't annoying -appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments -appendLwc a b = - LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) - -newLine :: Line -> LinesWithComments -newLine l = LinesWithComments (pure l) [] - -firstLine :: LinesWithComments -> Line -firstLine = NEL.head . lwcLines - -consLine :: Line -> LinesWithComments -> LinesWithComments -consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } - -consComment :: Text -> LinesWithComments -> LinesWithComments -consComment l lwc = lwc { lwcComments = l : lwcComments lwc } - -associateLines :: NonEmpty Line -> [LinesWithComments] -associateLines lines = - foldr combine [] $ - foldr toLinesWithComments [] lines - where - toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments] - toLinesWithComments line linesWithComments = - case linesWithComments of - [] -> - [newLine line] - (lwc : lwcs) -> - case isDocComment (NEL.head (tokens line)) of - Just comment - | lineIndent line == lowestIndent lines -> - consComment comment lwc : lwcs - _ -> - if lineIndent line <= lineIndent (firstLine lwc) - && lineIndent (firstLine lwc) /= lowestIndent lines - then - consLine line lwc : lwcs - else - newLine line : lwc : lwcs - - combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] - combine lwc [] = - [lwc] - combine lwc (lwc' : lwcs) = - let minIndent = minimumIndentOf lwc - otherIndent = minimumIndentOf lwc' - in - if minIndent < otherIndent then - appendLwc lwc lwc' : lwcs - else - lwc : lwc' : lwcs - - - minimumIndentOf = lowestIndent . lwcLines - -setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef -setComments [] = id -setComments comments = - overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) - -fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] -fixForeignKeysAll unEnts = map fixForeignKeys unEnts - where - ents = map unboundEntityDef unEnts - entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents - - fixForeignKeys :: UnboundEntityDef -> EntityDef - fixForeignKeys (UnboundEntityDef foreigns ent) = - ent { entityForeigns = map (fixForeignKey ent) foreigns } - - -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns - fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = - case mfdefs of - Just fdefs -> - if length foreignFieldTexts /= length fdefs - then - lengthError fdefs - else - let - fds_ffs = - zipWith toForeignFields - foreignFieldTexts - fdefs - dbname = - unEntityNameDB (entityDB pent) - oldDbName = - unEntityNameDB (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - EntityNameDB dbname - , foreignConstraintNameDBName = - ConstraintNameDB - . T.replace oldDbName dbname . unConstraintNameDB - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no primary key found fdef="++show fdef++ " ent="++show ent - where - pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - mfdefs = case parentFieldTexts of - [] -> entitiesPrimary pent - _ -> Just $ map (getFd pent . FieldNameHS) parentFieldTexts - - setNull :: [FieldDef] -> Bool - setNull [] = error "setNull: impossible!" - setNull (fd:fds) = let nullSetting = isNull fd in - if all ((nullSetting ==) . isNull) fds then nullSetting - else error $ "foreign key columns must all be nullable or non-nullable" - ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds)) - isNull = (NotNullable /=) . nullable . fieldAttrs - - toForeignFields :: Text -> FieldDef - -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) - toForeignFields fieldText pfd = - case chktypes fd haskellField pfd of - Just err -> error err - Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) - where - fd = getFd ent haskellField - - haskellField = FieldNameHS fieldText - (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - - chktypes ffld _fkey pfld = - if fieldType ffld == fieldType pfld then Nothing - else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - - getFd :: EntityDef -> FieldNameHS -> FieldDef - getFd entity t = go (keyAndEntityFields entity) - where - go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity) - ++ " unknown column: " ++ show t - go (f:fs) - | fieldHaskell f == t = f - | otherwise = go fs - - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef - - -data UnboundEntityDef = UnboundEntityDef - { _unboundForeignDefs :: [UnboundForeignDef] - , unboundEntityDef :: EntityDef - } - -overUnboundEntityDef - :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overUnboundEntityDef f ubed = - ubed { unboundEntityDef = f (unboundEntityDef ubed) } - -lookupKeyVal :: Text -> [Text] -> Maybe Text -lookupKeyVal key = lookupPrefix $ key `mappend` "=" - -lookupPrefix :: Text -> [Text] -> Maybe Text -lookupPrefix prefix = msum . map (T.stripPrefix prefix) - --- | Construct an entity definition. -mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines - -> UnboundEntityDef -mkEntityDef ps name entattribs lines = - UnboundEntityDef foreigns $ - EntityDef - { entityHaskell = EntityNameHS name' - , entityDB = EntityNameDB $ getDbName ps name' entattribs - -- idField is the user-specified Id - -- otherwise useAutoIdField - -- but, adjust it if the user specified a Primary - , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entattribs - , entityFields = cols - , entityUniques = uniqs - , entityForeigns = [] - , entityDerives = concat $ mapMaybe takeDerives textAttribs - , entityExtra = extras - , entitySum = isSum - , entityComments = Nothing - } - where - entName = EntityNameHS name' - (isSum, name') = - case T.uncons name of - Just ('+', x) -> (True, x) - _ -> (False, name) - (attribs, extras) = splitExtras lines - - textAttribs :: [[Text]] - textAttribs = - fmap tokenText <$> attribs - - attribPrefix = flip lookupKeyVal entattribs - idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" - | otherwise = Nothing - - (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr - squish xs m = xs `mappend` maybeToList m - in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs - - cols :: [FieldDef] - cols = reverse . fst . foldr k ([], []) $ reverse attribs - - k x (!acc, !comments) = - case listToMaybe x of - Just (DocComment comment) -> - (acc, comment : comments) - _ -> - case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of - Just sm -> - (sm : acc, []) - Nothing -> - (acc, []) - - autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType - idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite - - setComposite Nothing fd = fd - setComposite (Just c) fd = fd - { fieldReference = CompositeRef c - } - -setFieldComments :: [Text] -> FieldDef -> FieldDef -setFieldComments xs fld = - case xs of - [] -> fld - _ -> fld { fieldComments = Just (T.unlines xs) } - -just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x -just1 (Just x) (Just y) = error $ "expected only one of: " - `mappend` show x `mappend` " " `mappend` show y -just1 x y = x `mplus` y - -mkAutoIdField :: PersistSettings -> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef -mkAutoIdField ps entName idName idSqlType = - FieldDef - { fieldHaskell = FieldNameHS "Id" - -- this should be modeled as a Maybe - -- but that sucks for non-ID field - -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName - , fieldSqlType = idSqlType - -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - , fieldCascade = noCascade - , fieldGenerated = Nothing - } - -defaultReferenceTypeCon :: FieldType -defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" - -keyConName :: Text -> Text -keyConName entName = entName `mappend` "Id" - -splitExtras - :: [Line] - -> ( [[Token]] - , M.Map Text [ExtraLine] - ) -splitExtras lns = - case lns of - [] -> ([], M.empty) - (line : rest) -> - case NEL.toList (tokens line) of - [Token name] - | isCapitalizedText name -> - let indent = lineIndent line - (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = splitExtras rest' - in (x, M.insert name (NEL.toList . lineText <$> children) y) - ts -> - let (x, y) = splitExtras rest - in (ts:x, y) - -isCapitalizedText :: Text -> Bool -isCapitalizedText t = - not (T.null t) && isUpper (T.head t) - -takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef -takeColsEx = - takeCols - (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) - -takeCols - :: (Text -> String -> Maybe FieldDef) - -> PersistSettings - -> [Text] - -> Maybe FieldDef -takeCols _ _ ("deriving":_) = Nothing -takeCols onErr ps (n':typ:rest') - | not (T.null n) && isLower (T.head n) = - case parseFieldType typ of - Left err -> onErr typ err - Right ft -> Just FieldDef - { fieldHaskell = FieldNameHS n - , fieldDB = FieldNameDB $ getDbName ps n attrs_ - , fieldType = ft - , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = fieldAttrs_ - , fieldStrict = fromMaybe (psStrictFields ps) mstrict - , fieldReference = NoReference - , fieldComments = Nothing - , fieldCascade = cascade_ - , fieldGenerated = generated_ - } - where - fieldAttrs_ = parseFieldAttrs attrs_ - generated_ = parseGenerated attrs_ - (cascade_, attrs_) = parseCascade rest' - (mstrict, n) - | Just x <- T.stripPrefix "!" n' = (Just True, x) - | Just x <- T.stripPrefix "~" n' = (Just False, x) - | otherwise = (Nothing, n') - -takeCols _ _ _ = Nothing - -parseGenerated :: [Text] -> Maybe Text -parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing - -getDbName :: PersistSettings -> Text -> [Text] -> Text -getDbName ps n [] = psToDBName ps n -getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a - -takeConstraint :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' - where - takeConstraint' - | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) - | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) - | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) - | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint -takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) - --- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. --- need to re-work takeCols function -takeId :: PersistSettings -> Text -> [Text] -> FieldDef -takeId ps tableName (n:rest) = - setFieldDef - $ fromMaybe (error "takeId: impossible!") - $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) - where - field = case T.uncons n of - Nothing -> error "takeId: empty field" - Just (f, ield) -> toLower f `T.cons` ield - addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) - setFieldDef fd = fd - { fieldReference = - ForeignRef (EntityNameHS tableName) $ - if fieldType fd == FTTypeCon Nothing keyCon - then defaultReferenceTypeCon - else fieldType fd - } - keyCon = keyConName tableName - -- this will be ignored if there is already an existing sql= - -- TODO: I think there is a ! ignore syntax that would screw this up - -- setIdName = ["sql=" `mappend` psIdName ps] -takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName - - -takeComposite - :: [FieldDef] - -> [Text] - -> CompositeDef -takeComposite fields pkcols = - CompositeDef (map (getDef fields) pkcols) attrs - where - (_, attrs) = break ("!" `T.isPrefixOf`) pkcols - getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t - getDef (d:ds) t - | fieldHaskell d == FieldNameHS t = - if nullable (fieldAttrs d) /= NotNullable - then error $ "primary key column cannot be nullable: " ++ show t ++ show fields - else d - | otherwise = getDef ds t - --- Unique UppercaseConstraintName list of lowercasefields terminated --- by ! or sql= such that a unique constraint can look like: --- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` --- Here using sql= sets the name of the constraint. -takeUniq :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UniqueDef -takeUniq ps tableName defs (n:rest) - | isCapitalizedText n - = UniqueDef - (ConstraintNameHS n) - dbName - (map (FieldNameHS &&& getDBName defs) fields) - attrs - where - isAttr a = - "!" `T.isPrefixOf` a - isSqlName a = - "sql=" `T.isPrefixOf` a - isNonField a = - isAttr a - || isSqlName a - (fields, nonFields) = - break isNonField rest - attrs = filter isAttr nonFields - usualDbName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - sqlName :: Maybe ConstraintNameDB - sqlName = - case find isSqlName nonFields of - Nothing -> - Nothing - (Just t) -> - case drop 1 $ T.splitOn "=" t of - (x : _) -> Just (ConstraintNameDB x) - _ -> Nothing - dbName = fromMaybe usualDbName sqlName - getDBName [] t = - error $ "Unknown column in unique constraint: " ++ show t - ++ " " ++ show defs ++ show n ++ " " ++ show attrs - getDBName (d:ds) t - | fieldHaskell d == FieldNameHS t = fieldDB d - | otherwise = getDBName ds t -takeUniq _ tableName _ xs = - error $ "invalid unique constraint on table[" - ++ show tableName - ++ "] expecting an uppercase constraint name xs=" - ++ show xs - -data UnboundForeignDef = UnboundForeignDef - { _unboundForeignFields :: [Text] -- ^ fields in the parent entity - , _unboundParentFields :: [Text] -- ^ fields in parent entity - , _unboundForeignDef :: ForeignDef - } - -takeForeign - :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UnboundForeignDef -takeForeign ps tableName _defs = takeRefTable - where - errorPrefix :: String - errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " - - takeRefTable :: [Text] -> UnboundForeignDef - takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" - takeRefTable (refTableName:restLine) = go restLine Nothing Nothing - where - go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fFields pFields $ ForeignDef - { foreignRefTableHaskell = - EntityNameHS refTableName - , foreignRefTableDBName = - EntityNameDB $ psToDBName ps refTableName - , foreignConstraintNameHaskell = - ConstraintNameHS n - , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - , foreignFieldCascade = FieldCascade - { fcOnDelete = onDelete - , fcOnUpdate = onUpdate - } - , foreignFields = - [] - , foreignAttrs = - attrs - , foreignNullable = - False - , foreignToPrimary = - null pFields - } - where - (fields,attrs) = break ("!" `T.isPrefixOf`) rest - (fFields, pFields) = case break (== "References") fields of - (ffs, []) -> (ffs, []) - (ffs, _ : pfs) -> case (length ffs, length pfs) of - (flen, plen) | flen == plen -> (ffs, pfs) - (flen, plen) -> error $ errorPrefix ++ concat - [ "Found ", show flen, " foreign fields but " - , show plen, " parent fields" ] - - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = - case onDelete' of - Nothing -> - go rest (Just cascadingAction) onUpdate - Just _ -> - error $ errorPrefix ++ "found more than one OnDelete actions" - - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = - case onUpdate' of - Nothing -> - go rest 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 - -data CascadePrefix = CascadeUpdate | CascadeDelete - -parseCascade :: [Text] -> (FieldCascade, [Text]) -parseCascade allTokens = - go [] Nothing Nothing allTokens - where - go acc mupd mdel tokens_ = - case tokens_ of - [] -> - ( FieldCascade - { fcOnDelete = mdel - , fcOnUpdate = mupd - } - , acc - ) - this : rest -> - case parseCascadeAction CascadeUpdate this of - Just cascUpd -> - case mupd of - Nothing -> - go acc (Just cascUpd) mdel rest - Just _ -> - nope "found more than one OnUpdate action" - Nothing -> - case parseCascadeAction CascadeDelete this of - Just cascDel -> - case mdel of - Nothing -> - go acc mupd (Just cascDel) rest - Just _ -> - nope "found more than one OnDelete action: " - Nothing -> - go (this : acc) mupd mdel rest - nope msg = - error $ msg <> ", tokens: " <> show allTokens - -parseCascadeAction - :: CascadePrefix - -> Text - -> Maybe CascadeAction -parseCascadeAction prfx text = do - cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text - case readEither (T.unpack cascadeStr) of - Right a -> - Just a - Left _ -> - Nothing - where - toPrefix cp = - case cp of - CascadeUpdate -> "Update" - CascadeDelete -> "Delete" - -takeDerives :: [Text] -> Maybe [Text] -takeDerives ("deriving":rest) = Just rest -takeDerives _ = Nothing - -nullable :: [FieldAttr] -> IsNullable -nullable s - | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr - | FieldAttrNullable `elem` s = Nullable ByNullableAttr - | otherwise = NotNullable +import Database.Persist.Quasi.Internal diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs new file mode 100644 index 000000000..255065d36 --- /dev/null +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -0,0 +1,824 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This @Internal@ module may have breaking changes that will not be reflected +-- in major version bumps. Please use "Database.Persist.Quasi" instead. If you +-- need something in this module, please file an issue on GitHub. +-- +-- @since 2.13.0.0 +module Database.Persist.Quasi.Internal + ( parse + , PersistSettings (..) + , upperCaseSettings + , lowerCaseSettings + , nullable + , Token (..) + , Line (..) + , preparse + , parseLine + , parseFieldType + , associateLines + , LinesWithComments(..) + , splitExtras + , takeColsEx + ) where + +import Prelude hiding (lines) + +import Control.Applicative ( Alternative((<|>)) ) +import Control.Arrow ((&&&)) +import Control.Monad (msum, mplus) +import Data.Char ( isLower, isSpace, isUpper, toLower ) +import Data.List (find, foldl') +import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) +import Data.Monoid (mappend) +#if !MIN_VERSION_base(4,11,0) +-- This can be removed when GHC < 8.2.2 isn't supported anymore +import Data.Semigroup ((<>)) +#endif +import Data.Text (Text) +import qualified Data.Text as T +import Database.Persist.Types +import Text.Read (readEither) + +data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show + +parseFieldType :: Text -> Either String FieldType +parseFieldType t0 = + case parseApplyFT t0 of + PSSuccess ft t' + | T.all isSpace t' -> Right ft + PSFail err -> Left $ "PSFail " ++ err + other -> Left $ show other + where + parseApplyFT t = + case goMany id t of + PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' + PSSuccess [] _ -> PSFail "empty" + PSFail err -> PSFail err + PSDone -> PSDone + + parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType + parseEnclosed end ftMod t = + let (a, b) = T.break (== end) t + in case parseApplyFT a of + PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of + ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') + (x, y) -> PSFail $ show (b, x, y) + x -> PSFail $ show x + + parse1 t = + case T.uncons t of + Nothing -> PSDone + Just (c, t') + | isSpace c -> parse1 $ T.dropWhile isSpace t' + | c == '(' -> parseEnclosed ')' id t' + | c == '[' -> parseEnclosed ']' FTList t' + | isUpper c -> + let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t + in PSSuccess (getCon a) b + | otherwise -> PSFail $ show (c, t') + getCon t = + case T.breakOnEnd "." t of + (_, "") -> FTTypeCon Nothing t + ("", _) -> FTTypeCon Nothing t + (a, b) -> FTTypeCon (Just $ T.init a) b + goMany front t = + case parse1 t of + PSSuccess x t' -> goMany (front . (x:)) t' + PSFail err -> PSFail err + PSDone -> PSSuccess (front []) t + -- _ -> + +data PersistSettings = PersistSettings + { psToDBName :: !(Text -> Text) + , psStrictFields :: !Bool + -- ^ Whether fields are by default strict. Default value: @True@. + -- + -- @since 1.2 + , psIdName :: !Text + -- ^ The name of the id column. Default value: @id@ + -- The name of the id column can also be changed on a per-model basis + -- + -- + -- @since 2.0 + } + +defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings +defaultPersistSettings = PersistSettings + { psToDBName = id + , psStrictFields = True + , psIdName = "id" + } + +upperCaseSettings = defaultPersistSettings + +lowerCaseSettings = defaultPersistSettings + { psToDBName = + let go c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c + in T.dropWhile (== '_') . T.concatMap go + } + +-- | Parses a quasi-quoted syntax into a list of entity definitions. +parse :: PersistSettings -> Text -> [EntityDef] +parse ps = maybe [] (parseLines ps) . preparse + +preparse :: Text -> Maybe (NonEmpty Line) +preparse txt = do + lns <- NEL.nonEmpty (T.lines txt) + NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) + +parseLine :: Text -> Maybe Line +parseLine txt = do + Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt) + +-- | A token used by the parser. +data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. + | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. + deriving (Show, Eq) + +tokenText :: Token -> Text +tokenText tok = + case tok of + Token t -> t + DocComment t -> "-- | " <> t + +parseIndentationAmount :: Text -> Int +parseIndentationAmount txt = + let (spaces, _) = T.span isSpace txt + in T.length spaces + +-- | Tokenize a string. +tokenize :: Text -> [Token] +tokenize t + | T.null t = [] + | Just txt <- T.stripPrefix "-- | " t = [DocComment txt] + | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. + | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) + | T.head t == '"' = quotes (T.tail t) id + | T.head t == '(' = parens 1 (T.tail t) id + | isSpace (T.head t) = + tokenize (T.dropWhile isSpace t) + + -- support mid-token quotes and parens + | Just (beforeEquals, afterEquals) <- findMidToken t + , not (T.any isSpace beforeEquals) + , Token next : rest <- tokenize afterEquals = + Token (T.concat [beforeEquals, "=", next]) : rest + + | otherwise = + let (token, rest) = T.break isSpace t + in Token token : tokenize rest + where + findMidToken t' = + case T.break (== '=') t' of + (x, T.drop 1 -> y) + | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) + _ -> Nothing + + quotes t' front + | T.null t' = error $ T.unpack $ T.concat $ + "Unterminated quoted string starting with " : front [] + | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') + | T.head t' == '\\' && T.length t' > 1 = + quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) + | otherwise = + let (x, y) = T.break (`elem` ['\\','\"']) t' + in quotes y (front . (x:)) + parens count t' front + | T.null t' = error $ T.unpack $ T.concat $ + "Unterminated parens string starting with " : front [] + | T.head t' == ')' = + if count == (1 :: Int) + then Token (T.concat $ front []) : tokenize (T.tail t') + else parens (count - 1) (T.tail t') (front . (")":)) + | T.head t' == '(' = + parens (count + 1) (T.tail t') (front . ("(":)) + | T.head t' == '\\' && T.length t' > 1 = + parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) + | otherwise = + let (x, y) = T.break (`elem` ['\\','(',')']) t' + in parens count y (front . (x:)) + +-- | A line of parsed tokens +data Line = Line + { lineIndent :: Int + , tokens :: NonEmpty Token + } deriving (Eq, Show) + +lineText :: Line -> NonEmpty Text +lineText = fmap tokenText . tokens + +lowestIndent :: NonEmpty Line -> Int +lowestIndent = minimum . fmap lineIndent + +-- | Divide lines into blocks and make entity definitions. +parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] +parseLines ps = + fixForeignKeysAll . map mk . associateLines + where + mk :: LinesWithComments -> UnboundEntityDef + mk lwc = + let ln :| rest = lwcLines lwc + (name :| entAttribs) = lineText ln + in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest + +isDocComment :: Token -> Maybe Text +isDocComment tok = + case tok of + DocComment txt -> Just txt + _ -> Nothing + +data LinesWithComments = LinesWithComments + { lwcLines :: NonEmpty Line + , lwcComments :: [Text] + } deriving (Eq, Show) + +-- TODO: drop this and use <> when 8.2 isn't supported anymore so the +-- monoid/semigroup nonsense isn't annoying +appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments +appendLwc a b = + LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) + +newLine :: Line -> LinesWithComments +newLine l = LinesWithComments (pure l) [] + +firstLine :: LinesWithComments -> Line +firstLine = NEL.head . lwcLines + +consLine :: Line -> LinesWithComments -> LinesWithComments +consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } + +consComment :: Text -> LinesWithComments -> LinesWithComments +consComment l lwc = lwc { lwcComments = l : lwcComments lwc } + +associateLines :: NonEmpty Line -> [LinesWithComments] +associateLines lines = + foldr combine [] $ + foldr toLinesWithComments [] lines + where + toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments] + toLinesWithComments line linesWithComments = + case linesWithComments of + [] -> + [newLine line] + (lwc : lwcs) -> + case isDocComment (NEL.head (tokens line)) of + Just comment + | lineIndent line == lowestIndent lines -> + consComment comment lwc : lwcs + _ -> + if lineIndent line <= lineIndent (firstLine lwc) + && lineIndent (firstLine lwc) /= lowestIndent lines + then + consLine line lwc : lwcs + else + newLine line : lwc : lwcs + + combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] + combine lwc [] = + [lwc] + combine lwc (lwc' : lwcs) = + let minIndent = minimumIndentOf lwc + otherIndent = minimumIndentOf lwc' + in + if minIndent < otherIndent then + appendLwc lwc lwc' : lwcs + else + lwc : lwc' : lwcs + + + minimumIndentOf = lowestIndent . lwcLines + +setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef +setComments [] = id +setComments comments = + overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) + +fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] +fixForeignKeysAll unEnts = map fixForeignKeys unEnts + where + ents = map unboundEntityDef unEnts + entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents + + fixForeignKeys :: UnboundEntityDef -> EntityDef + fixForeignKeys (UnboundEntityDef foreigns ent) = + ent { entityForeigns = map (fixForeignKey ent) foreigns } + + -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns + fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef + fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = + case mfdefs of + Just fdefs -> + if length foreignFieldTexts /= length fdefs + then + lengthError fdefs + else + let + fds_ffs = + zipWith toForeignFields + foreignFieldTexts + fdefs + dbname = + unEntityNameDB (entityDB pent) + oldDbName = + unEntityNameDB (foreignRefTableDBName fdef) + in fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + EntityNameDB dbname + , foreignConstraintNameDBName = + ConstraintNameDB + . T.replace oldDbName dbname . unConstraintNameDB + $ foreignConstraintNameDBName fdef + } + Nothing -> + error $ "no primary key found fdef="++show fdef++ " ent="++show ent + where + pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + mfdefs = case parentFieldTexts of + [] -> entitiesPrimary pent + _ -> Just $ map (getFd pent . FieldNameHS) parentFieldTexts + + setNull :: [FieldDef] -> Bool + setNull [] = error "setNull: impossible!" + setNull (fd:fds) = let nullSetting = isNull fd in + if all ((nullSetting ==) . isNull) fds then nullSetting + else error $ "foreign key columns must all be nullable or non-nullable" + ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds)) + isNull = (NotNullable /=) . nullable . fieldAttrs + + toForeignFields :: Text -> FieldDef + -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) + toForeignFields fieldText pfd = + case chktypes fd haskellField pfd of + Just err -> error err + Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) + where + fd = getFd ent haskellField + + haskellField = FieldNameHS fieldText + (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) + + chktypes ffld _fkey pfld = + if fieldType ffld == fieldType pfld then Nothing + else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) + + getFd :: EntityDef -> FieldNameHS -> FieldDef + getFd entity t = go (keyAndEntityFields entity) + where + go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity) + ++ " unknown column: " ++ show t + go (f:fs) + | fieldHaskell f == t = f + | otherwise = go fs + + lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef + + +data UnboundEntityDef = UnboundEntityDef + { _unboundForeignDefs :: [UnboundForeignDef] + , unboundEntityDef :: EntityDef + } + +overUnboundEntityDef + :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef +overUnboundEntityDef f ubed = + ubed { unboundEntityDef = f (unboundEntityDef ubed) } + +lookupKeyVal :: Text -> [Text] -> Maybe Text +lookupKeyVal key = lookupPrefix $ key `mappend` "=" + +lookupPrefix :: Text -> [Text] -> Maybe Text +lookupPrefix prefix = msum . map (T.stripPrefix prefix) + +-- | Construct an entity definition. +mkEntityDef :: PersistSettings + -> Text -- ^ name + -> [Attr] -- ^ entity attributes + -> [Line] -- ^ indented lines + -> UnboundEntityDef +mkEntityDef ps name entattribs lines = + UnboundEntityDef foreigns $ + EntityDef + { entityHaskell = EntityNameHS name' + , entityDB = EntityNameDB $ getDbName ps name' entattribs + -- idField is the user-specified Id + -- otherwise useAutoIdField + -- but, adjust it if the user specified a Primary + , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField + , entityAttrs = entattribs + , entityFields = cols + , entityUniques = uniqs + , entityForeigns = [] + , entityDerives = concat $ mapMaybe takeDerives textAttribs + , entityExtra = extras + , entitySum = isSum + , entityComments = Nothing + } + where + entName = EntityNameHS name' + (isSum, name') = + case T.uncons name of + Just ('+', x) -> (True, x) + _ -> (False, name) + (attribs, extras) = splitExtras lines + + textAttribs :: [[Text]] + textAttribs = + fmap tokenText <$> attribs + + attribPrefix = flip lookupKeyVal entattribs + idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" + | otherwise = Nothing + + (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> + let (i, p, u, f) = takeConstraint ps name' cols attr + squish xs m = xs `mappend` maybeToList m + in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs + + cols :: [FieldDef] + cols = reverse . fst . foldr k ([], []) $ reverse attribs + + k x (!acc, !comments) = + case listToMaybe x of + Just (DocComment comment) -> + (acc, comment : comments) + _ -> + case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of + Just sm -> + (sm : acc, []) + Nothing -> + (acc, []) + + autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType + idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite + + setComposite Nothing fd = fd + setComposite (Just c) fd = fd + { fieldReference = CompositeRef c + } + +setFieldComments :: [Text] -> FieldDef -> FieldDef +setFieldComments xs fld = + case xs of + [] -> fld + _ -> fld { fieldComments = Just (T.unlines xs) } + +just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x +just1 (Just x) (Just y) = error $ "expected only one of: " + `mappend` show x `mappend` " " `mappend` show y +just1 x y = x `mplus` y + +mkAutoIdField :: PersistSettings -> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef +mkAutoIdField ps entName idName idSqlType = + FieldDef + { fieldHaskell = FieldNameHS "Id" + -- this should be modeled as a Maybe + -- but that sucks for non-ID field + -- TODO: use a sumtype FieldDef | IdFieldDef + , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName + , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName + , fieldSqlType = idSqlType + -- the primary field is actually a reference to the entity + , fieldReference = ForeignRef entName defaultReferenceTypeCon + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + , fieldGenerated = Nothing + } + +defaultReferenceTypeCon :: FieldType +defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" + +keyConName :: Text -> Text +keyConName entName = entName `mappend` "Id" + +splitExtras + :: [Line] + -> ( [[Token]] + , M.Map Text [ExtraLine] + ) +splitExtras lns = + case lns of + [] -> ([], M.empty) + (line : rest) -> + case NEL.toList (tokens line) of + [Token name] + | isCapitalizedText name -> + let indent = lineIndent line + (children, rest') = span ((> indent) . lineIndent) rest + (x, y) = splitExtras rest' + in (x, M.insert name (NEL.toList . lineText <$> children) y) + ts -> + let (x, y) = splitExtras rest + in (ts:x, y) + +isCapitalizedText :: Text -> Bool +isCapitalizedText t = + not (T.null t) && isUpper (T.head t) + +takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef +takeColsEx = + takeCols + (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) + +takeCols + :: (Text -> String -> Maybe FieldDef) + -> PersistSettings + -> [Text] + -> Maybe FieldDef +takeCols _ _ ("deriving":_) = Nothing +takeCols onErr ps (n':typ:rest') + | not (T.null n) && isLower (T.head n) = + case parseFieldType typ of + Left err -> onErr typ err + Right ft -> Just FieldDef + { fieldHaskell = FieldNameHS n + , fieldDB = FieldNameDB $ getDbName ps n attrs_ + , fieldType = ft + , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n + , fieldAttrs = fieldAttrs_ + , fieldStrict = fromMaybe (psStrictFields ps) mstrict + , fieldReference = NoReference + , fieldComments = Nothing + , fieldCascade = cascade_ + , fieldGenerated = generated_ + } + where + fieldAttrs_ = parseFieldAttrs attrs_ + generated_ = parseGenerated attrs_ + (cascade_, attrs_) = parseCascade rest' + (mstrict, n) + | Just x <- T.stripPrefix "!" n' = (Just True, x) + | Just x <- T.stripPrefix "~" n' = (Just False, x) + | otherwise = (Nothing, n') + +takeCols _ _ _ = Nothing + +parseGenerated :: [Text] -> Maybe Text +parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing + +getDbName :: PersistSettings -> Text -> [Text] -> Text +getDbName ps n [] = psToDBName ps n +getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a + +takeConstraint :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) +takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' + where + takeConstraint' + | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) + | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) + | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) + | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) + | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint +takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) + +-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. +-- need to re-work takeCols function +takeId :: PersistSettings -> Text -> [Text] -> FieldDef +takeId ps tableName (n:rest) = + setFieldDef + $ fromMaybe (error "takeId: impossible!") + $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) + where + field = case T.uncons n of + Nothing -> error "takeId: empty field" + Just (f, ield) -> toLower f `T.cons` ield + addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) + setFieldDef fd = fd + { fieldReference = + ForeignRef (EntityNameHS tableName) $ + if fieldType fd == FTTypeCon Nothing keyCon + then defaultReferenceTypeCon + else fieldType fd + } + keyCon = keyConName tableName + -- this will be ignored if there is already an existing sql= + -- TODO: I think there is a ! ignore syntax that would screw this up + -- setIdName = ["sql=" `mappend` psIdName ps] +takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName + + +takeComposite + :: [FieldDef] + -> [Text] + -> CompositeDef +takeComposite fields pkcols = + CompositeDef (map (getDef fields) pkcols) attrs + where + (_, attrs) = break ("!" `T.isPrefixOf`) pkcols + getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t + getDef (d:ds) t + | fieldHaskell d == FieldNameHS t = + if nullable (fieldAttrs d) /= NotNullable + then error $ "primary key column cannot be nullable: " ++ show t ++ show fields + else d + | otherwise = getDef ds t + +-- Unique UppercaseConstraintName list of lowercasefields terminated +-- by ! or sql= such that a unique constraint can look like: +-- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` +-- Here using sql= sets the name of the constraint. +takeUniq :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UniqueDef +takeUniq ps tableName defs (n:rest) + | isCapitalizedText n + = UniqueDef + (ConstraintNameHS n) + dbName + (map (FieldNameHS &&& getDBName defs) fields) + attrs + where + isAttr a = + "!" `T.isPrefixOf` a + isSqlName a = + "sql=" `T.isPrefixOf` a + isNonField a = + isAttr a + || isSqlName a + (fields, nonFields) = + break isNonField rest + attrs = filter isAttr nonFields + usualDbName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + sqlName :: Maybe ConstraintNameDB + sqlName = + case find isSqlName nonFields of + Nothing -> + Nothing + (Just t) -> + case drop 1 $ T.splitOn "=" t of + (x : _) -> Just (ConstraintNameDB x) + _ -> Nothing + dbName = fromMaybe usualDbName sqlName + getDBName [] t = + error $ "Unknown column in unique constraint: " ++ show t + ++ " " ++ show defs ++ show n ++ " " ++ show attrs + getDBName (d:ds) t + | fieldHaskell d == FieldNameHS t = fieldDB d + | otherwise = getDBName ds t +takeUniq _ tableName _ xs = + error $ "invalid unique constraint on table[" + ++ show tableName + ++ "] expecting an uppercase constraint name xs=" + ++ show xs + +data UnboundForeignDef = UnboundForeignDef + { _unboundForeignFields :: [Text] -- ^ fields in the parent entity + , _unboundParentFields :: [Text] -- ^ fields in parent entity + , _unboundForeignDef :: ForeignDef + } + +takeForeign + :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UnboundForeignDef +takeForeign ps tableName _defs = takeRefTable + where + errorPrefix :: String + errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " + + takeRefTable :: [Text] -> UnboundForeignDef + takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" + takeRefTable (refTableName:restLine) = go restLine Nothing Nothing + where + go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) + = UnboundForeignDef fFields pFields $ ForeignDef + { foreignRefTableHaskell = + EntityNameHS refTableName + , foreignRefTableDBName = + EntityNameDB $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + ConstraintNameHS n + , foreignConstraintNameDBName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + , foreignFieldCascade = FieldCascade + { fcOnDelete = onDelete + , fcOnUpdate = onUpdate + } + , foreignFields = + [] + , foreignAttrs = + attrs + , foreignNullable = + False + , foreignToPrimary = + null pFields + } + where + (fields,attrs) = break ("!" `T.isPrefixOf`) rest + (fFields, pFields) = case break (== "References") fields of + (ffs, []) -> (ffs, []) + (ffs, _ : pfs) -> case (length ffs, length pfs) of + (flen, plen) | flen == plen -> (ffs, pfs) + (flen, plen) -> error $ errorPrefix ++ concat + [ "Found ", show flen, " foreign fields but " + , show plen, " parent fields" ] + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + case onDelete' of + Nothing -> + go rest (Just cascadingAction) onUpdate + Just _ -> + error $ errorPrefix ++ "found more than one OnDelete actions" + + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + case onUpdate' of + Nothing -> + go rest 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 + +data CascadePrefix = CascadeUpdate | CascadeDelete + +parseCascade :: [Text] -> (FieldCascade, [Text]) +parseCascade allTokens = + go [] Nothing Nothing allTokens + where + go acc mupd mdel tokens_ = + case tokens_ of + [] -> + ( FieldCascade + { fcOnDelete = mdel + , fcOnUpdate = mupd + } + , acc + ) + this : rest -> + case parseCascadeAction CascadeUpdate this of + Just cascUpd -> + case mupd of + Nothing -> + go acc (Just cascUpd) mdel rest + Just _ -> + nope "found more than one OnUpdate action" + Nothing -> + case parseCascadeAction CascadeDelete this of + Just cascDel -> + case mdel of + Nothing -> + go acc mupd (Just cascDel) rest + Just _ -> + nope "found more than one OnDelete action: " + Nothing -> + go (this : acc) mupd mdel rest + nope msg = + error $ msg <> ", tokens: " <> show allTokens + +parseCascadeAction + :: CascadePrefix + -> Text + -> Maybe CascadeAction +parseCascadeAction prfx text = do + cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text + case readEither (T.unpack cascadeStr) of + Right a -> + Just a + Left _ -> + Nothing + where + toPrefix cp = + case cp of + CascadeUpdate -> "Update" + CascadeDelete -> "Delete" + +takeDerives :: [Text] -> Maybe [Text] +takeDerives ("deriving":rest) = Just rest +takeDerives _ = Nothing + +nullable :: [FieldAttr] -> IsNullable +nullable s + | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr + | FieldAttrNullable `elem` s = Nullable ByNullableAttr + | otherwise = NotNullable diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index 5bb716e98..ff6751e42 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -19,10 +19,15 @@ module Database.Persist.Sql , transactionSaveWithIsolation , transactionUndo , transactionUndoWithIsolation - , IsolationLevel (..) , getStmtConn + , mkColumns + , BackendSpecificOverrides + , emptyBackendSpecificOverrides + , getBackendSpecificForeignKeyName + , setBackendSpecificForeignKeyName + , defaultAttribute -- * Internal - , module Database.Persist.Sql.Internal + , IsolationLevel(..) , decorateSQLWithLimitOffset ) where @@ -36,7 +41,7 @@ import Database.Persist.Sql.Migration import Database.Persist.Sql.Raw import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel(..)) +import Database.Persist.Sql.Types.Internal (IsolationLevel(..), SqlBackend(..)) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index d33dbfd6e..94649b02a 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -8,6 +8,8 @@ module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute , BackendSpecificOverrides(..) + , getBackendSpecificForeignKeyName + , setBackendSpecificForeignKeyName , emptyBackendSpecificOverrides ) where @@ -21,15 +23,43 @@ import Database.Persist.Sql.Types import Database.Persist.Types import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) --- | Record of functions to override the default behavior in 'mkColumns'. --- It is recommended you initialize this with 'emptyBackendSpecificOverrides' and override the default values, --- so that as new fields are added, your code still compiles. +-- | Record of functions to override the default behavior in 'mkColumns'. It is +-- recommended you initialize this with 'emptyBackendSpecificOverrides' and +-- override the default values, so that as new fields are added, your code still +-- compiles. +-- +-- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@ +-- functions, as a breaking change to the record field labels won't be reflected +-- in a major version bump of the library. -- -- @since 2.11 data BackendSpecificOverrides = BackendSpecificOverrides { backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) } +-- | If the override is defined, then this returns a function that accepts an +-- entity name and field name and provides the 'ConstraintNameDB' for the +-- foreign key constraint. +-- +-- An abstract accessor for the 'BackendSpecificOverrides' +-- +-- @since 2.13.0.0 +getBackendSpecificForeignKeyName + :: BackendSpecificOverrides + -> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) +getBackendSpecificForeignKeyName = + backendSpecificForeignKeyName + +-- | Set the backend's foreign key generation function to this value. +-- +-- @since 2.13.0.0 +setBackendSpecificForeignKeyName + :: (EntityNameDB -> FieldNameDB -> ConstraintNameDB) + -> BackendSpecificOverrides + -> BackendSpecificOverrides +setBackendSpecificForeignKeyName func bso = + bso { backendSpecificForeignKeyName = Just func } + findMaybe :: (a -> Maybe b) -> [a] -> Maybe b findMaybe p = listToMaybe . mapMaybe p diff --git a/persistent/Database/Persist/Sql/Migration.hs b/persistent/Database/Persist/Sql/Migration.hs index f4846f309..6e2ecd090 100644 --- a/persistent/Database/Persist/Sql/Migration.hs +++ b/persistent/Database/Persist/Sql/Migration.hs @@ -31,6 +31,7 @@ import System.IO.Silently (hSilence) import GHC.Stack import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw import Database.Persist.Types import Database.Persist.Sql.Orphan.PersistStore() diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 2308ef2ae..24f6f8f9a 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | TODO: delete this module and get it in with SqlBackend.Internal module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount @@ -20,19 +21,26 @@ import Data.ByteString.Char8 (readInteger) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Int (Int64) -import Data.List (transpose, inits, find) +import Data.List (find, inits, transpose) import Data.Maybe (isJust) -import Data.Monoid (Monoid (..), (<>)) -import qualified Data.Text as T +import Data.Monoid (Monoid(..), (<>)) import Data.Text (Text) +import qualified Data.Text as T import Database.Persist hiding (updateField) -import Database.Persist.Sql.Util ( - entityColumnNames, parseEntityValues, isIdField, updatePersistValue - , mkUpdateText, commaSeparated, dbIdColumns) -import Database.Persist.Sql.Types -import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Types.Internal + (SqlBackend(..), SqlReadBackend, SqlWriteBackend) +import Database.Persist.Sql.Util + ( commaSeparated + , dbIdColumns + , entityColumnNames + , isIdField + , mkUpdateText + , parseEntityValues + , updatePersistValue + ) -- orphaned instance for convenience of modularity instance PersistQueryRead SqlBackend where @@ -103,7 +111,7 @@ instance PersistQueryRead SqlBackend where [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords cols = commaSeparated . entityColumnNames t - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat + sql conn = connLimitOffset conn (limit,offset) $ mconcat [ "SELECT " , cols conn , " FROM " @@ -124,7 +132,7 @@ instance PersistQueryRead SqlBackend where wher conn = if null filts then "" else filterClause Nothing conn filts - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat + sql conn = connLimitOffset conn (limit,offset) $ mconcat [ "SELECT " , cols conn , " FROM " @@ -457,8 +465,12 @@ orderClause includeTable conn o = $ connEscapeFieldName conn (fieldName x) -- | Generates sql for limit and offset for postgres, sqlite and mysql. -decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text -decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = +decorateSQLWithLimitOffset + :: Text + -> (Int,Int) + -> Text + -> Text +decorateSQLWithLimitOffset nolimit (limit,offset) sql = let lim = case (limit, offset) of (0, 0) -> "" diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index e3420c255..906e2972b 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -43,6 +43,7 @@ import Database.Persist.Class () import Database.Persist.Sql.Class (PersistFieldSql) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Util ( dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames , updatePersistValue, mkUpdateText, commaSeparated, mkInsertValues) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs index f9a0c62d3..3d4338727 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues) -import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index b3bd2b72e..8c5eda0de 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -16,6 +16,8 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal +import Database.Persist.SqlBackend.Internal import Database.Persist.Sql.Class rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) @@ -66,8 +68,8 @@ rawExecuteCount sql vals = do return res getStmt - :: (MonadIO m, BackendCompatible SqlBackend backend) - => Text -> ReaderT backend m Statement + :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend) + => Text -> m Statement getStmt sql = do conn <- projectBackend `liftM` ask liftIO $ getStmtConn conn sql diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index 2bc79b3ea..d66c72a9c 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel) +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw -- | Get a connection from the pool, run the given action, and then return the diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index 9d5e870d7..8df81a30f 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -1,6 +1,6 @@ module Database.Persist.Sql.Types ( module Database.Persist.Sql.Types - , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..) + , SqlBackend, SqlReadBackend (..), SqlWriteBackend (..) , Statement (..), LogFunc, InsertSqlResult (..) , readToUnknown, readToWrite, writeToUnknown , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend @@ -12,15 +12,15 @@ import Database.Persist.Types.Base (FieldCascade) import Control.Exception (Exception(..)) import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Writer (WriterT) import Data.Pool (Pool) import Data.Text (Text, unpack) -import Database.Persist.Types -import Database.Persist.Sql.Types.Internal import Data.Time (NominalDiffTime) +import Database.Persist.Sql.Types.Internal +import Database.Persist.Types data Column = Column { cName :: !FieldNameDB diff --git a/persistent/Database/Persist/Sql/Types/Internal.hs b/persistent/Database/Persist/Sql/Types/Internal.hs index 9ba89cde3..831071e7d 100644 --- a/persistent/Database/Persist/Sql/Types/Internal.hs +++ b/persistent/Database/Persist/Sql/Types/Internal.hs @@ -1,5 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} +{-# language RecordWildCards #-} +{-# language DuplicateRecordFields #-} + +-- | Breaking changes to this module are not reflected in the major version +-- number. Prefer to import from "Database.Persist.Sql" instead. If you neeed +-- something from this module, please file an issue on GitHub. module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..) @@ -26,183 +32,27 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger (LogSource, LogLevel, Loc) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) -import Data.Acquire (Acquire) -import Data.Conduit (ConduitM) -import Data.Int (Int64) -import Data.IORef (IORef) -import Data.Map (Map) import Data.Monoid ((<>)) -import Data.String (IsString) -import Data.Text (Text) -import System.Log.FastLogger (LogStr) import Database.Persist.Class - ( HasPersistBackend (..) - , PersistQueryRead, PersistQueryWrite - , PersistStoreRead, PersistStoreWrite - , PersistUniqueRead, PersistUniqueWrite - , BackendCompatible(..) - ) + ( HasPersistBackend (..) + , PersistQueryRead, PersistQueryWrite + , PersistStoreRead, PersistStoreWrite + , PersistUniqueRead, PersistUniqueWrite + , BackendCompatible(..) + ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.Types - -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -data InsertSqlResult = ISRSingle Text - | ISRInsertGet Text Text - | ISRManyKeys Text [PersistValue] - -data Statement = Statement - { stmtFinalize :: IO () - , stmtReset :: IO () - , stmtExecute :: [PersistValue] -> IO Int64 - , stmtQuery :: forall m. MonadIO m - => [PersistValue] - -> Acquire (ConduitM () [PersistValue] m ()) - } - --- | Please refer to the documentation for the database in question for a full --- overview of the semantics of the varying isloation levels -data IsolationLevel = ReadUncommitted - | ReadCommitted - | RepeatableRead - | Serializable - deriving (Show, Eq, Enum, Ord, Bounded) - -makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s -makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of - ReadUncommitted -> "READ UNCOMMITTED" - ReadCommitted -> "READ COMMITTED" - RepeatableRead -> "REPEATABLE READ" - Serializable -> "SERIALIZABLE" - --- | A 'SqlBackend' represents a handle or connection to a database. It --- contains functions and values that allow databases to have more --- optimized implementations, as well as references that benefit --- performance and sharing. --- --- A 'SqlBackend' is *not* thread-safe. You should not assume that --- a 'SqlBackend' can be shared among threads and run concurrent queries. --- This *will* result in problems. Instead, you should create a @'Pool' --- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in --- multi-threaded applications. --- --- To run actions in the @persistent@ library, you should use the --- 'runSqlConn' function. If you're using a multithreaded application, use --- the 'runSqlPool' function. -data SqlBackend = SqlBackend - { connPrepare :: Text -> IO Statement - -- ^ This function should prepare a 'Statement' in the target database, - -- which should allow for efficient query reuse. - , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult - -- ^ This function generates the SQL and values necessary for - -- performing an insert against the database. - , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) - -- ^ SQL for inserting many rows and returning their primary keys, for - -- backends that support this functionality. If 'Nothing', rows will be - -- inserted one-at-a-time using 'connInsertSql'. - , connUpsertSql :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) - -- ^ Some databases support performing UPSERT _and_ RETURN entity - -- in a single call. - -- - -- This field when set will be used to generate the UPSERT+RETURN sql given - -- * an entity definition - -- * updates to be run on unique key(s) collision - -- - -- When left as 'Nothing', we find the unique key from entity def before - -- * trying to fetch an entity by said key - -- * perform an update when result found, else issue an insert - -- * return new entity from db - -- - -- @since 2.6 - , connPutManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk UPSERT, specifically - -- "insert or replace many records" in a single call. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a PUT MANY sql with placeholders for records - -- - -- When left as 'Nothing', we default to using 'defaultPutMany'. - -- - -- @since 2.8.1 - , connStmtMap :: IORef (Map Text Statement) - -- ^ A reference to the cache of statements. 'Statement's are keyed by - -- the 'Text' queries that generated them. - , connClose :: IO () - -- ^ Close the underlying connection. - , connMigrateSql - :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [(Bool, Text)]) - -- ^ This function returns the migrations required to include the - -- 'EntityDef' parameter in the @['EntityDef']@ database. This might - -- include creating a new table if the entity is not present, or - -- altering an existing table if it is. - , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () - -- ^ A function to begin a transaction for the underlying database. - , connCommit :: (Text -> IO Statement) -> IO () - -- ^ A function to commit a transaction to the underlying database. - , connRollback :: (Text -> IO Statement) -> IO () - -- ^ A function to roll back a transaction on the underlying database. - , connEscapeFieldName :: FieldNameDB -> Text - -- ^ A function to extract and escape the name of the column corresponding - -- to the provided field. - -- - -- @since 2.12.0.0 - , connEscapeTableName :: EntityDef -> Text - -- ^ A function to extract and escape the name of the table corresponding - -- to the provided entity. PostgreSQL uses this to support schemas. - -- - -- @since 2.12.0.0 - , connEscapeRawName :: Text -> Text - -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while - -- PostgreSQL uses quotes, and so on. - -- - -- @since 2.12.0.0 - , connNoLimit :: Text - , connRDBMS :: Text - -- ^ A tag displaying what database the 'SqlBackend' is for. Can be - -- used to differentiate features in downstream libraries for different - -- database backends. - , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text - -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that - -- LIMIT/OFFSET is problematic for performance, and indexed range - -- queries are the superior way to offer pagination. - , connLogFunc :: LogFunc - -- ^ A log function for the 'SqlBackend' to use. - , connMaxParams :: Maybe Int - -- ^ Some databases (probably only Sqlite) have a limit on how - -- many question-mark parameters may be used in a statement - -- - -- @since 2.6.1 - , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk an atomic+bulk INSERT where - -- constraint conflicting entities can replace existing entities. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a INSERT sql with placeholders for primary+record fields - -- - -- When left as 'Nothing', we default to using 'defaultRepsertMany'. - -- - -- @since 2.9.0 - } - -instance HasPersistBackend SqlBackend where - type BaseBackend SqlBackend = SqlBackend - persistBackend = id - -instance IsPersistBackend SqlBackend where - mkPersistBackend = id +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.IsolationLevel -- | An SQL backend which can only handle read queries -- -- The constructor was exposed in 2.10.0. -newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } +newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend @@ -260,4 +110,7 @@ type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backe type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a -- | A backend which is a wrapper around @SqlBackend@. -type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend) +type IsSqlBackend backend = + ( IsPersistBackend backend + , BaseBackend backend ~ SqlBackend + ) diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index d68e55320..3643cae23 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -34,7 +34,8 @@ import Database.Persist ( , FieldDef(..) ) -import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeFieldName) +import Database.Persist.Sql.Types (Sql) +import Database.Persist.SqlBackend.Internal(SqlBackend(..)) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn = diff --git a/persistent/Database/Persist/SqlBackend.hs b/persistent/Database/Persist/SqlBackend.hs new file mode 100644 index 000000000..936502e6f --- /dev/null +++ b/persistent/Database/Persist/SqlBackend.hs @@ -0,0 +1,189 @@ +-- | This module contains types and information necessary for a SQL database. +-- Database support libraries, like @persistent-postgresql@, will be responsible +-- for constructing these values. +module Database.Persist.SqlBackend + ( -- * The type and construction + SqlBackend + , mkSqlBackend + , MkSqlBackendArgs(..) + -- * Utilities + + -- $utilities + + -- ** SqlBackend Getters + , getEscapedFieldName + , getEscapedRawName + , getEscapeRawNameFunction + , getConnLimitOffset + , getConnUpsertSql + -- ** SqlBackend Setters + , setConnMaxParams + , setConnRepsertManySql + , setConnInsertManySql + , setConnUpsertSql + , setConnPutManySql + ) where + +import Control.Monad.Reader +import Data.Text (Text) +import Database.Persist.Class.PersistStore (BackendCompatible(..)) +import Database.Persist.SqlBackend.Internal +import qualified Database.Persist.SqlBackend.Internal as SqlBackend + (SqlBackend(..)) +import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) +import Database.Persist.Types.Base +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Data.List.NonEmpty (NonEmpty) + +-- $utilities +-- +-- The functions exported here are a bit more general than the record accessors. +-- The easiest way to use them is to provide the 'SqlBackend' directly to the +-- function. However, you can also use them in a 'ReaderT' context, and you can +-- even use them with any @backend@ type tht has a @'BackendCompatible' +-- 'SqlBackend' backend@ instance. + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a 'FieldNameDB'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedFieldName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedFieldName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedFieldName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => FieldNameDB -> m Text +getEscapedFieldName fieldName = do + func <- asks (SqlBackend.connEscapeFieldName . projectBackend) + pure (func fieldName) + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a raw 'Text'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedRawName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedRawName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedRawName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => Text -> m Text +getEscapedRawName name = do + func <- getEscapeRawNameFunction + pure (func name) + +-- | Return the function for escaping a raw name. +-- +-- @since 2.13.0.0 +getEscapeRawNameFunction + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m (Text -> Text) +getEscapeRawNameFunction = do + asks (SqlBackend.connEscapeRawName . projectBackend) + +-- | Decorate the given SQL query with the @(LIMIT, OFFSET)@ specified. +-- +-- @since 2.13.0.0 +getConnLimitOffset + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => (Int, Int) + -- ^ The @(LIMIT, OFFSET)@ to put on the query. + -> Text + -- ^ The SQL query that the LIMIT/OFFSET clause will be attached to. + -> m Text +getConnLimitOffset limitOffset sql = do + func <- asks (SqlBackend.connLimitOffset . projectBackend) + pure $ func limitOffset sql + +-- | Retrieve the function for generating an upsert statement, if the backend +-- supports it. +-- +-- @since 2.13.0.0 +getConnUpsertSql + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m (Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)) +getConnUpsertSql = do + asks (SqlBackend.connUpsertSql . projectBackend) + + +-- | Set the maximum parameters that may be issued in a given SQL query. This +-- should be used only if the database backend have this limitation. +-- +-- @since 2.13.0.0 +setConnMaxParams + :: Int + -> SqlBackend + -> SqlBackend +setConnMaxParams i sb = + sb { connMaxParams = Just i } + +-- | Set the 'connRepsertManySql' field on the 'SqlBackend'. This should only be +-- set by the database backend library. If this is not set, a slow default will +-- be used. +-- +-- @since 2.13.0.0 +setConnRepsertManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnRepsertManySql mkQuery sb = + sb { connRepsertManySql = Just mkQuery } + +-- | Set the 'connInsertManySql' field on the 'SqlBackend'. This should only be +-- used by the database backend library to provide an efficient implementation +-- of a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnInsertManySql + :: (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -> SqlBackend + -> SqlBackend +setConnInsertManySql mkQuery sb = + sb { connInsertManySql = Just mkQuery } + +-- | Set the 'connUpsertSql' field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnUpsertSql + :: (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -> SqlBackend + -> SqlBackend +setConnUpsertSql mkQuery sb = + sb { connUpsertSql = Just mkQuery } + +-- | Set the 'connPutManySql field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnPutManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnPutManySql mkQuery sb = + sb { connPutManySql = Just mkQuery } diff --git a/persistent/Database/Persist/SqlBackend/Internal.hs b/persistent/Database/Persist/SqlBackend/Internal.hs new file mode 100644 index 000000000..b74332a26 --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal.hs @@ -0,0 +1,164 @@ +{-# language RecordWildCards #-} +{-# language RankNTypes #-} + +module Database.Persist.SqlBackend.Internal where + +import Data.String +import Data.Map (Map) +import Data.List.NonEmpty (NonEmpty) +import Control.Monad.Logger (LogSource, LogLevel, Loc, LogStr) +import Data.Text (Text) +import Data.Acquire +import Database.Persist.Class.PersistStore +import Conduit +import Database.Persist.Types.Base +import Data.Int +import Data.IORef +import Control.Monad.Reader +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel + +-- | A 'SqlBackend' represents a handle or connection to a database. It +-- contains functions and values that allow databases to have more +-- optimized implementations, as well as references that benefit +-- performance and sharing. +-- +-- Instead of using the 'SqlBackend' constructor directly, use the +-- 'mkSqlBackend' function. +-- +-- A 'SqlBackend' is *not* thread-safe. You should not assume that +-- a 'SqlBackend' can be shared among threads and run concurrent queries. +-- This *will* result in problems. Instead, you should create a @'Pool' +-- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in +-- multi-threaded applications. +-- +-- To run actions in the @persistent@ library, you should use the +-- 'runSqlConn' function. If you're using a multithreaded application, use +-- the 'runSqlPool' function. +data SqlBackend = SqlBackend + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -- ^ SQL for inserting many rows and returning their primary keys, for + -- backends that support this functionality. If 'Nothing', rows will be + -- inserted one-at-a-time using 'connInsertSql'. + , connUpsertSql :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -- ^ Some databases support performing UPSERT _and_ RETURN entity + -- in a single call. + -- + -- This field when set will be used to generate the UPSERT+RETURN sql given + -- * an entity definition + -- * updates to be run on unique key(s) collision + -- + -- When left as 'Nothing', we find the unique key from entity def before + -- * trying to fetch an entity by said key + -- * perform an update when result found, else issue an insert + -- * return new entity from db + -- + -- @since 2.6 + , connPutManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk UPSERT, specifically + -- "insert or replace many records" in a single call. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a PUT MANY sql with placeholders for records + -- + -- When left as 'Nothing', we default to using 'defaultPutMany'. + -- + -- @since 2.8.1 + , connStmtMap :: IORef (Map Text Statement) + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int,Int) -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + , connMaxParams :: Maybe Int + -- ^ Some databases (probably only Sqlite) have a limit on how + -- many question-mark parameters may be used in a statement + -- + -- @since 2.6.1 + , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk an atomic+bulk INSERT where + -- constraint conflicting entities can replace existing entities. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a INSERT sql with placeholders for primary+record fields + -- + -- When left as 'Nothing', we default to using 'defaultRepsertMany'. + -- + -- @since 2.9.0 + } + +-- | A function for creating a value of the 'SqlBackend' type. You should prefer +-- to use this instead of the constructor for 'SqlBackend', because default +-- values for this will be provided for new fields on the record when new +-- functionality is added. +-- +-- @since 2.13.0.0 +mkSqlBackend :: MkSqlBackendArgs -> SqlBackend +mkSqlBackend MkSqlBackendArgs {..} = + SqlBackend + { connMaxParams = Nothing + , connRepsertManySql = Nothing + , connPutManySql = Nothing + , connUpsertSql = Nothing + , connInsertManySql = Nothing + , .. + } + +instance HasPersistBackend SqlBackend where + type BaseBackend SqlBackend = SqlBackend + persistBackend = id + +instance IsPersistBackend SqlBackend where + mkPersistBackend = id diff --git a/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs b/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs new file mode 100644 index 000000000..90a69528b --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs @@ -0,0 +1,9 @@ +module Database.Persist.SqlBackend.Internal.InsertSqlResult where + +import Database.Persist.Types.Base (PersistValue) +import Data.Text (Text) + +data InsertSqlResult + = ISRSingle Text + | ISRInsertGet Text Text + | ISRManyKeys Text [PersistValue] diff --git a/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs new file mode 100644 index 000000000..d4c9926bd --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs @@ -0,0 +1,19 @@ +module Database.Persist.SqlBackend.Internal.IsolationLevel where + +import Data.String (IsString(..)) +import Data.Monoid ((<>)) -- TODO: remove when GHC-8.2 support is dropped + +-- | Please refer to the documentation for the database in question for a full +-- overview of the semantics of the varying isloation levels +data IsolationLevel = ReadUncommitted + | ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Enum, Ord, Bounded) + +makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s +makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of + ReadUncommitted -> "READ UNCOMMITTED" + ReadCommitted -> "READ COMMITTED" + RepeatableRead -> "REPEATABLE READ" + Serializable -> "SERIALIZABLE" diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs new file mode 100644 index 000000000..4b5045d27 --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.MkSqlBackend where + +import Conduit +import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr) +import Control.Monad.Reader +import Data.Acquire +import Data.IORef +import Data.Int +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.String +import Data.Text (Text) +import Database.Persist.Class.PersistStore +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.Types.Base + +-- | This type shares many of the same field names as the 'SqlBackend' type. +-- It's useful for library authors to use this when migrating from using the +-- 'SqlBackend' constructor directly to the 'mkSqlBackend' function. +-- +-- This type will only contain required fields for constructing a 'SqlBackend'. +-- For fields that aren't present on this record, you'll want to use the various +-- @set@ functions or +-- +-- @since 2.13.0.0 +data MkSqlBackendArgs = MkSqlBackendArgs + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connStmtMap :: IORef (Map Text Statement) + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int,Int) -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + } + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () diff --git a/persistent/Database/Persist/SqlBackend/Internal/Statement.hs b/persistent/Database/Persist/SqlBackend/Internal/Statement.hs new file mode 100644 index 000000000..ef69a644c --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/Statement.hs @@ -0,0 +1,19 @@ +{-# language RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.Statement where + +import Data.Acquire +import Database.Persist.Types.Base +import Data.Int +import Conduit + +-- | A 'Statement' is a representation of a database query that has been +-- prepared and stored on the server side. +data Statement = Statement + { stmtFinalize :: IO () + , stmtReset :: IO () + , stmtExecute :: [PersistValue] -> IO Int64 + , stmtQuery :: forall m. MonadIO m + => [PersistValue] + -> Acquire (ConduitM () [PersistValue] m ()) + } diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index ca2bfd164..d7bba56b4 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ViewPatterns #-} -- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} @@ -61,54 +64,68 @@ module Database.Persist.TH -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. -import Prelude hiding ((++), take, concat, splitAt, exp) +import Prelude hiding (concat, exp, splitAt, take, (++)) -import Data.Either import Control.Monad import Data.Aeson - ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object - , Value (Object), (.:), (.:?) - , eitherDecodeStrict' - ) + ( FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Object) + , eitherDecodeStrict' + , object + , (.:) + , (.:?) + , (.=) + ) import qualified Data.ByteString as BS -import Data.Typeable (Typeable) -import Data.Ix (Ix) -import Data.Data (Data) import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.Either import qualified Data.HashMap.Strict as HM import Data.Int (Int64) +import Data.Ix (Ix) import Data.List (foldl') import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) -import Data.Monoid ((<>), mappend, mconcat) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import Data.Monoid (mappend, mconcat, (<>)) +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text, append, concat, cons, pack, stripSuffix, uncons, unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` -import Language.Haskell.TH.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit) +import qualified Data.Set as Set +import Language.Haskell.TH.Lib + (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax +import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) -import qualified Data.Set as Set import Database.Persist -import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi +import Database.Persist.Sql + (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter persistWith ps = QuasiQuoter - { quoteExp = parseReferences ps . pack + { quoteExp = + parseReferences ps . pack + , quotePat = + error "persistWith can't be used as pattern" + , quoteType = + error "persistWith can't be used as type" + , quoteDec = + error "persistWith can't be used as declaration" } -- | Apply 'persistWith' to 'upperCaseSettings'. @@ -1028,7 +1045,7 @@ headNote = \case xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] -fromValues entDef funName conE fields = do +fromValues entDef funName constructExpr fields = do x <- newName "x" let funMsg = entityText entDef `mappend` ": " `mappend` funName `mappend` " failed on: " patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] @@ -1040,13 +1057,13 @@ fromValues entDef funName conE fields = do case fields of [] -> do rightE <- [|Right|] - return $ normalClause [ListP []] (rightE `AppE` conE) + return $ normalClause [ListP []] (rightE `AppE` constructExpr) _ -> do x1 <- newName "x1" restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields] (fpv1:mkPersistValues) <- mapM mkPersistValue fields app1E <- [|(<$>)|] - let conApp = infixFromPersistValue app1E fpv1 conE x1 + let conApp = infixFromPersistValue app1E fpv1 constructExpr x1 applyE <- [|(<*>)|] let applyFromPersistValue = infixFromPersistValue applyE diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 073db1d1a..9b58142ed 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.1.1 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -15,79 +15,95 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md library - build-depends: base >= 4.9 && < 5 - , aeson >= 1.0 - , attoparsec - , base64-bytestring - , blaze-html >= 0.9 - , bytestring >= 0.10 - , conduit >= 1.2.12 - , containers >= 0.5 - , fast-logger >= 2.4 - , http-api-data >= 0.3 - , monad-logger >= 0.3.28 - , mtl - , path-pieces >= 0.2 - , resource-pool >= 0.2.3 - , resourcet >= 1.1.10 - , scientific - , silently - , template-haskell >= 2.11 && < 2.17 - , text >= 1.2 - , time >= 1.6 - , transformers >= 0.5 - , unliftio-core - , unliftio - , unordered-containers - , th-lift-instances >= 0.1.14 && < 0.2 - , vector + build-depends: + base >= 4.9 && < 5 + , aeson >= 1.0 + , attoparsec + , base64-bytestring + , blaze-html >= 0.9 + , bytestring >= 0.10 + , conduit >= 1.2.12 + , containers >= 0.5 + , fast-logger >= 2.4 + , http-api-data >= 0.3 + , monad-logger >= 0.3.28 + , mtl + , path-pieces >= 0.2 + , resource-pool >= 0.2.3 + , resourcet >= 1.1.10 + , scientific + , silently + , template-haskell >= 2.11 && < 2.18 + , text >= 1.2 + , time >= 1.6 + , transformers >= 0.5 + , unliftio-core + , unliftio + , unordered-containers + , th-lift-instances >= 0.1.14 && < 0.2 + , vector - default-extensions: FlexibleContexts - , MultiParamTypeClasses - , OverloadedStrings - , TypeFamilies + default-extensions: + FlexibleContexts + , MultiParamTypeClasses + , OverloadedStrings + , TypeFamilies - exposed-modules: Database.Persist - Database.Persist.Quasi - Database.Persist.TH - - Database.Persist.Types - Database.Persist.Class - Database.Persist.Sql - Database.Persist.Sql.Util - Database.Persist.Sql.Types.Internal - - other-modules: Database.Persist.Types.Base - Database.Persist.Class.DeleteCascade - Database.Persist.Class.PersistEntity - Database.Persist.Class.PersistQuery - Database.Persist.Class.PersistUnique - Database.Persist.Class.PersistConfig - Database.Persist.Class.PersistField - Database.Persist.Class.PersistStore - - Database.Persist.Sql.Migration - Database.Persist.Sql.Internal - Database.Persist.Sql.Types - Database.Persist.Sql.Raw - Database.Persist.Sql.Run - Database.Persist.Sql.Class - Database.Persist.Sql.Orphan.PersistQuery - Database.Persist.Sql.Orphan.PersistStore - Database.Persist.Sql.Orphan.PersistUnique + exposed-modules: + Database.Persist + Database.Persist.Types + Database.Persist.TH + + Database.Persist.Quasi + Database.Persist.Quasi.Internal + + Database.Persist.Sql + Database.Persist.Sql.Util + Database.Persist.Sql.Types.Internal + + Database.Persist.SqlBackend + Database.Persist.SqlBackend.Internal + Database.Persist.SqlBackend.Internal.InsertSqlResult + Database.Persist.SqlBackend.Internal.IsolationLevel + Database.Persist.SqlBackend.Internal.Statement + Database.Persist.SqlBackend.Internal.MkSqlBackend + + Database.Persist.Class + Database.Persist.Class.DeleteCascade + Database.Persist.Class.PersistEntity + Database.Persist.Class.PersistQuery + Database.Persist.Class.PersistUnique + Database.Persist.Class.PersistConfig + Database.Persist.Class.PersistField + Database.Persist.Class.PersistStore + + other-modules: + Database.Persist.Types.Base + + Database.Persist.Sql.Migration + Database.Persist.Sql.Internal + Database.Persist.Sql.Types + Database.Persist.Sql.Raw + Database.Persist.Sql.Run + Database.Persist.Sql.Class + Database.Persist.Sql.Orphan.PersistQuery + Database.Persist.Sql.Orphan.PersistStore + Database.Persist.Sql.Orphan.PersistUnique -- These modules only make sense for compilers with access to DerivingVia if impl(ghc >= 8.6.1) - exposed-modules: Database.Persist.Compatible - other-modules: Database.Persist.Compatible.Types - Database.Persist.Compatible.TH + exposed-modules: + Database.Persist.Compatible + other-modules: + Database.Persist.Compatible.Types + Database.Persist.Compatible.TH ghc-options: -Wall default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 - main-is: test/main.hs + main-is: main.hs build-depends: base >= 4.9 && < 5 @@ -100,6 +116,7 @@ test-suite test , hspec >= 2.4 , http-api-data , path-pieces + , persistent , scientific , shakespeare , text @@ -124,7 +141,6 @@ test-suite test , th-lift-instances hs-source-dirs: - ./ test/ cpp-options: -DTEST @@ -134,11 +150,11 @@ test-suite test , TypeFamilies other-modules: - Database.Persist.Class.PersistEntity - Database.Persist.Class.PersistField - Database.Persist.Quasi - Database.Persist.Types - Database.Persist.Types.Base + -- Database.Persist.Class.PersistEntity + -- Database.Persist.Class.PersistField + -- Database.Persist.Quasi + -- Database.Persist.Types + -- Database.Persist.Types.Base Database.Persist.THSpec TemplateTestImports Database.Persist.TH.SharedPrimaryKeySpec diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 5cb405888..01329e177 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -22,7 +22,7 @@ import Data.Aeson import qualified Data.ByteString.Char8 as BS8 import Database.Persist.Class.PersistField -import Database.Persist.Quasi +import Database.Persist.Quasi.Internal import Database.Persist.Types import qualified Database.Persist.THSpec as THSpec diff --git a/stack-8.10.yaml b/stack-8.10.yaml new file mode 100644 index 000000000..4821c74d8 --- /dev/null +++ b/stack-8.10.yaml @@ -0,0 +1,10 @@ +resolver: lts-17.8 +packages: + - ./persistent + - ./persistent-sqlite + - ./persistent-test + - ./persistent-mongoDB + - ./persistent-mysql + - ./persistent-postgresql + - ./persistent-redis + - ./persistent-qq diff --git a/stack-8.10.yaml.lock b/stack-8.10.yaml.lock new file mode 100644 index 000000000..72d7dad32 --- /dev/null +++ b/stack-8.10.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 565720 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/8.yaml + sha256: 76bf8992ff8dfe6eda9c02f81866138c2369344d5011ab39ae403457c4448b03 + original: lts-17.8