diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-mysql +## 2.13.0.0 + +* [#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.1.0 * Expose `openMySQLConn` for explicit reference to opened connection. [#1248](https://github.com/yesodweb/persistent/pull/1248) diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -26,8 +26,6 @@ , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate , HandleUpdateCollision - , pattern SomeField - , SomeField , copyField , copyUnlessNull , copyUnlessEmpty @@ -48,6 +46,7 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Writer (runWriterT) +import qualified Data.List.NonEmpty as NEL import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) @@ -73,6 +72,7 @@ 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 @@ -87,40 +87,40 @@ -- 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' - -- | Open a connection to MySQL server, initialize the 'SqlBackend' and return -- their tuple -- @@ -131,32 +131,30 @@ MySQLBase.autocommit conn False -- disable autocommit! smap <- newIORef $ Map.empty let - backend = 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 - } + backend = + 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 . getEntityDBName + , 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 + } pure (conn, backend) @@ -164,7 +162,6 @@ open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend open' ci logFunc = snd <$> openMySQLConn ci logFunc - -- | Prepare a query. We don't support prepared statements, but -- we'll do some client-side preprocessing here. prepare' :: MySQL.Connection -> Text -> IO Statement @@ -181,14 +178,16 @@ -- | SQL code to be executed when inserting an entity. insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = - case entityPrimary ent of - Just _ -> ISRManyKeys sql vals - Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()" + case getEntityId ent of + EntityIdNaturalKey _ -> + ISRManyKeys sql vals + EntityIdField _ -> + ISRInsertGet sql "SELECT LAST_INSERT_ID()" where (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT) sql = T.concat [ "INSERT INTO " - , escapeET $ entityDB ent + , escapeET $ getEntityDBName ent , "(" , T.intercalate "," fieldNames , ") VALUES(" @@ -353,7 +352,7 @@ -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' connectInfo allDefs getter val = do - let name = entityDB val + let name = getEntityDBName val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val old <- getColumns connectInfo getter val newcols let udspair = map udToPair udefs @@ -374,7 +373,7 @@ let refTarget = addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef) - guard $ cname /= fieldDB (entityId val) + guard $ Just cname /= fmap fieldDB (getEntityIdField val) return $ AlterColumn name refTarget @@ -448,35 +447,58 @@ addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ concat - -- Lower case e: see Database.Persist.Sql.Migration - [ "CREATe TABLE " - , escapeE name - , "(" - , idtxt - , if null nonIdCols then [] else "," - , intercalate "," $ map showColumn nonIdCols - , ")" - ] - where - nonIdCols = - filter (\c -> cName c /= fieldDB (entityId entity) ) cols - name = entityDB entity - idtxt = case entityPrimary entity of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef, ")"] - Nothing -> - let defText = defaultAttribute $ fieldAttrs $ entityId entity - sType = fieldSqlType $ entityId entity - autoIncrementText = case (sType, defText) of - (SqlInt64, Nothing) -> " AUTO_INCREMENT" - _ -> "" - maxlen = findMaxLenOfField (entityId entity) - in concat - [ escapeF $ fieldDB $ entityId entity - , " " <> showSqlType sType maxlen False - , " NOT NULL" - , autoIncrementText - , " PRIMARY KEY" - ] + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeE name + , "(" + , idtxt + , if null nonIdCols then [] else "," + , intercalate "," $ map showColumn nonIdCols + , ")" + ] + where + nonIdCols = + filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity) ) cols + name = + getEntityDBName entity + idtxt = + case getEntityId entity of + EntityIdNaturalKey pdef -> + concat + [ " PRIMARY KEY (" + , intercalate "," + $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef + , ")" + ] + EntityIdField idField -> + let + defText = + defaultAttribute $ fieldAttrs idField + sType = + fieldSqlType idField + autoIncrementText = + case (sType, defText) of + (SqlInt64, Nothing) -> " AUTO_INCREMENT" + _ -> "" + maxlen = + findMaxLenOfField idField + in + concat + [ escapeF $ fieldDB idField + , " " <> showSqlType sType maxlen False + , " NOT NULL" + , autoIncrementText + , " PRIMARY KEY" + , case defText of + Nothing -> + "" + Just def -> + concat + [ " DEFAULT (" + , T.unpack def + , ")" + ] + ] -- | Find out the type of a column. findTypeOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType) @@ -488,8 +510,8 @@ ) ((,) col) $ do - entDef <- find ((== name) . entityDB) allDefs - fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + entDef <- find ((== name) . getEntityDBName) allDefs + fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef) return (fieldType fieldDef) -- | Find out the maxlen of a column (default to 200) @@ -497,8 +519,8 @@ findMaxLenOfColumn allDefs name col = maybe (col, 200) ((,) col) $ do - entDef <- find ((== name) . entityDB) allDefs - fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + entDef <- find ((== name) . getEntityDBName) allDefs + fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef) findMaxLenOfField fieldDef -- | Find out the maxlen of a field @@ -532,8 +554,8 @@ ++ " (allDefs = " ++ show allDefs ++ ")" referencedColumns = fromMaybe errorMessage $ do - entDef <- find ((== reftable) . entityDB) allDefs - return $ map fieldDB $ entityKeyFields entDef + entDef <- find ((== reftable) . getEntityDBName) allDefs + return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef data AlterColumn = Change Column | Add' Column @@ -564,7 +586,7 @@ udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) -udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) +udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud) ---------------------------------------------------------------------- @@ -621,15 +643,15 @@ Nothing -> rs (Just r) -> (unFieldNameDB $ cName c, r) : rs vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unEntityNameDB $ entityDB def - -- , PersistText $ unDBName $ fieldDB $ entityId def + , PersistText $ unEntityNameDB $ getEntityDBName def + -- , PersistText $ unDBName $ fieldDB $ getEntityId def ] helperClmns = CL.mapM getIt .| CL.consume where getIt row = fmap (either Left (Right . Left)) . liftIO . - getColumn connectInfo getter (entityDB def) row $ ref + getColumn connectInfo getter (getEntityDBName def) row $ ref where ref = case row of (PersistText cname : _) -> (Map.lookup cname refMap) _ -> Nothing @@ -837,7 +859,7 @@ getAlters allDefs edef (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where - tblName = entityDB edef + tblName = getEntityDBName edef getAltersC [] old = concatMap dropColumn old getAltersC (new:news) old = let (alters, old') = findAlters edef allDefs new old @@ -900,8 +922,9 @@ refAdd = case (ref == ref', ref) of (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc }) - | tname /= entityDB edef - , unConstraintNameDB cname /= unFieldNameDB (fieldDB (entityId edef)) + | tname /= getEntityDBName edef + , Just idField <- getEntityIdField edef + , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField) -> [addReference allDefs cname tname name cfc] _ -> [] @@ -1211,7 +1234,7 @@ -> EntityDef -> IO (Either [Text] [(Bool, Text)]) mockMigrate _connectInfo allDefs _getter val = do - let name = entityDB val + let name = getEntityDBName val let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val let udspair = map udToPair udefs case () of @@ -1255,37 +1278,34 @@ -- 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 . getEntityDBName + , 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 @@ -1310,21 +1330,10 @@ -- -- @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@. @@ -1487,8 +1496,8 @@ firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field - entityFieldNames = map fieldDbToText (entityFields entityDef') - tableName = T.pack . escapeE . entityDB $ entityDef' + entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef') + tableName = T.pack . escapeE . getEntityDBName $ entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records @@ -1524,12 +1533,12 @@ putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' fields ent n where - fields = entityFields ent + fields = getEntityFieldsDatabase ent repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' fields ent n where - fields = keyAndEntityFields ent + fields = NEL.toList $ keyAndEntityFields ent putManySql' :: [FieldDef] -> EntityDef -> Int -> Text putManySql' (filter isFieldNotGenerated -> fields) ent n = q @@ -1537,7 +1546,7 @@ fieldDbToText = (T.pack . escapeF) . fieldDB mkAssignment f = T.concat [f, "=VALUES(", f, ")"] - table = (T.pack . escapeE) . entityDB $ ent + table = (T.pack . escapeE) . getEntityDBName $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields diff --git a/persistent-mysql.cabal b/persistent-mysql.cabal --- a/persistent-mysql.cabal +++ b/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 2.12.1.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -28,7 +28,7 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10.8 @@ -54,28 +54,34 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test - other-modules: MyInit - InsertDuplicateUpdate - CustomConstraintTest + other-modules: + MyInit + InsertDuplicateUpdate + CustomConstraintTest + ImplicitUuidSpec ghc-options: -Wall - build-depends: base >= 4.9 && < 5 - , persistent - , persistent-mysql - , persistent-qq - , persistent-test - , bytestring - , containers - , fast-logger - , hspec >= 2.4 - , HUnit - , monad-logger - , mysql - , QuickCheck - , quickcheck-instances - , resourcet - , text - , time - , transformers - , unliftio-core + build-depends: + base >= 4.9 && < 5 + , aeson + , bytestring + , containers + , fast-logger + , hspec >= 2.4 + , http-api-data + , HUnit + , monad-logger + , mysql + , path-pieces + , persistent + , persistent-mysql + , persistent-qq + , persistent-test + , QuickCheck + , quickcheck-instances + , resourcet + , text + , time + , transformers + , unliftio-core default-language: Haskell2010 diff --git a/test/ImplicitUuidSpec.hs b/test/ImplicitUuidSpec.hs new file mode 100644 --- /dev/null +++ b/test/ImplicitUuidSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ImplicitUuidSpec where + +import MyInit + +import Data.Proxy +import Database.Persist.MySQL + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +share + [ mkPersist (sqlSettingsUuid "UUID()") + , mkEntityDefList "entities" + ] + [persistLowerCase| + +WithDefUuid + name Text + + deriving Eq Show Ord + +|] + +implicitUuidMigrate :: Migration +implicitUuidMigrate = do + migrateModels entities + +wipe :: IO () +wipe = db $ do + rawExecute "DROP TABLE IF EXISTS with_def_uuid;" [] + void $ runMigrationSilent implicitUuidMigrate + +itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb msg action = it msg $ db $ void action + +pass :: IO () +pass = pure () + +spec :: Spec +spec = describe "ImplicitUuidSpec" $ before_ wipe $ do + describe "WithDefUuidKey" $ do + it "works on UUIDs" $ do + let withDefUuidKey = WithDefUuidKey (UUID "Hello") + pass + describe "getEntityId" $ do + let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) + it "has a SqlString SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlString + it "is an implicit ID column" $ asIO $ do + fieldIsImplicitIdColumn idField `shouldBe` True + + describe "insert" $ do + itDb "successfully has a default" $ do + let matt = WithDefUuid + { withDefUuidName = + "Matt" + } + k <- insert matt + mrec <- get k + uuids <- selectList @WithDefUuid [] [] + liftIO $ do + -- MySQL's insert functionality is currently broken. The @k@ + -- here is derived from @SELECT LAST_INSERT_ID()@ which only + -- works on auto incrementing IDs. + -- + -- See #1251 for more details. + mrec `shouldBe` Nothing + + map entityVal uuids `shouldSatisfy` (matt `elem`) diff --git a/test/MyInit.hs b/test/MyInit.hs --- a/test/MyInit.hs +++ b/test/MyInit.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module MyInit ( (@/=), (@==), (==@) @@ -26,12 +29,14 @@ , MonadUnliftIO , liftIO , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , mkEntityDefList, sqlSettingsUuid , Int32, Int64 , Text , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql , BS.ByteString + , migrateModels , SomeException , MonadFail , TestFn(..) @@ -40,44 +45,71 @@ , truncateUTCTime , arbText , liftA2 + , LoggingT, ResourceT, UUID(..) ) where import Init - ( TestFn(..), truncateTimeOfDay, truncateUTCTime - , truncateToMicro, arbText, GenerateKey(..) - , (@/=), (@==), (==@) - , assertNotEqual, assertNotEmpty, assertEmpty, asIO - , isTravis, RunDb, MonadFail - ) + ( GenerateKey(..) + , MonadFail + , RunDb + , TestFn(..) + , arbText + , asIO + , assertEmpty + , assertNotEmpty + , assertNotEqual + , isTravis + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , (==@) + , (@/=) + , (@==) + ) -- re-exports import Control.Applicative (liftA2) import Control.Exception (SomeException) -import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Trans.Reader -import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Data.Aeson (FromJSON, ToJSON, Value(..)) import Database.Persist.Sql.Raw.QQ +import Database.Persist.TH + ( MkPersistSettings(..) + , migrateModels + , setImplicitIdDef + , mkEntityDefList + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , share + , sqlSettings + ) import Test.Hspec import Test.QuickCheck.Instances () +import Web.Internal.HttpApiData +import Web.PathPieces +import Database.Persist.ImplicitIdDef -- testing -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Control.Monad (unless, (>=>)) -import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Data.ByteString as BS import Data.Int (Int32, Int64) import Data.Text (Text) +import qualified Data.Text.Encoding as TE import qualified Database.MySQL.Base as MySQL import System.Log.FastLogger (fromLogStr) import Database.Persist import Database.Persist.MySQL import Database.Persist.Sql -import Database.Persist.TH () _debugOn :: Bool _debugOn = False @@ -122,3 +154,22 @@ db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do runResourceT $ runConn $ actions >> transactionUndo + +newtype UUID = UUID { unUUID :: Text } + deriving stock + (Show, Eq, Ord, Read) + deriving newtype + ( ToJSON, FromJSON + , PersistField, PersistFieldSql + , FromHttpApiData, ToHttpApiData, PathPiece + ) + +sqlSettingsUuid :: Text -> MkPersistSettings +sqlSettingsUuid defExpr = + let + uuidDef = + setImplicitIdDefMaxLen 100 $ mkImplicitIdDef @UUID defExpr + settings = + setImplicitIdDef uuidDef sqlSettings + in + settings diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,24 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DataKinds, FlexibleInstances #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# OPTIONS_GHC -Wno-unused-top-binds #-} import MyInit -import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import qualified Data.ByteString as BS import Data.Fixed -import Test.QuickCheck -import qualified Data.Text as T import Data.IntMap (IntMap) -import qualified Data.ByteString as BS +import qualified Data.Text as T +import Data.Time (Day, TimeOfDay, UTCTime(..), timeOfDayToTime, timeToTimeOfDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Database.Persist.Sql +import Test.QuickCheck import qualified CompositeTest import qualified CustomPersistFieldTest @@ -35,25 +39,26 @@ import qualified MigrationColumnLengthTest import qualified MigrationIdempotencyTest import qualified MigrationOnlyTest -import qualified MpsNoPrefixTest import qualified MpsCustomPrefixTest -import qualified PersistentTest +import qualified MpsNoPrefixTest import qualified PersistUniqueTest +import qualified PersistentTest -- FIXME: Not used... should it be? -- import qualified PrimaryTest import qualified RawSqlTest import qualified ReadWriteTest import qualified Recursive -- TODO: can't use this as MySQL can't do DEFAULT CURRENT_DATE +import qualified CustomConstraintTest +import qualified ForeignKey +import qualified GeneratedColumnTestSQL +import qualified ImplicitUuidSpec +import qualified LongIdentifierTest import qualified RenameTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified UniqueTest import qualified UpsertTest -import qualified CustomConstraintTest -import qualified LongIdentifierTest -import qualified GeneratedColumnTestSQL -import qualified ForeignKey type Tuple a b = (a, b) @@ -109,98 +114,101 @@ main :: IO () main = do - runConn $ do - mapM_ setup - [ PersistentTest.testMigrate - , PersistentTest.noPrefixMigrate - , PersistentTest.customPrefixMigrate - , EmbedTest.embedMigrate - , EmbedOrderTest.embedOrderMigrate - , LargeNumberTest.numberMigrate - , UniqueTest.uniqueMigrate - , MaxLenTest.maxlenMigrate - , Recursive.recursiveMigrate - , CompositeTest.compositeMigrate - , PersistUniqueTest.migration - , RenameTest.migration - , CustomPersistFieldTest.customFieldMigrate - , InsertDuplicateUpdate.duplicateMigrate - , MigrationIdempotencyTest.migration - , CustomPrimaryKeyReferenceTest.migration - , MigrationColumnLengthTest.migration - , TransactionLevelTest.migration - -- , LongIdentifierTest.migration - , ForeignKey.compositeMigrate - ] - PersistentTest.cleanDB - ForeignKey.cleanDB + runConn $ do + mapM_ setup + [ PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate + , InsertDuplicateUpdate.duplicateMigrate + , MigrationIdempotencyTest.migration + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + , TransactionLevelTest.migration + -- , LongIdentifierTest.migration + , ForeignKey.compositeMigrate + ] + PersistentTest.cleanDB + ForeignKey.cleanDB - hspec $ do - xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ 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" (roundTime . dataTypeTableTime) - , TestFn "utc" (roundUTCTime . dataTypeTableUtc) - , TestFn "timeFrac" (dataTypeTableTimeFrac) - , TestFn "utcFrac" (dataTypeTableUtcFrac) - ] - [ ("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 + hspec $ do + ImplicitUuidSpec.spec + xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ 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" (roundTime . dataTypeTableTime) + , TestFn "utc" (roundUTCTime . dataTypeTableUtc) + , TestFn "timeFrac" (dataTypeTableTimeFrac) + , TestFn "utcFrac" (dataTypeTableUtcFrac) + ] + [ ("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 $ do + void $ rawExecute "DROP TABLE IF EXISTS referencing;" [] + void $ rawExecute "DROP TABLE IF EXISTS two_field;" [] + void $ runMigrationSilent MigrationOnlyTest.migrateAll1 + void $ runMigrationSilent MigrationOnlyTest.migrateAll2 + ) + PersistentTest.specsWith db + PersistentTest.filterOrSpecs db + ReadWriteTest.specsWith db + RawSqlTest.specsWith db + UpsertTest.specsWith + db + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey - ForeignKey.specsWith db - MpsNoPrefixTest.specsWith db - MpsCustomPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith db - PersistUniqueTest.specsWith db - CustomPersistFieldTest.specsWith db - CustomPrimaryKeyReferenceTest.specsWith db - InsertDuplicateUpdate.specs - MigrationColumnLengthTest.specsWith db - EquivalentTypeTest.specsWith db - TransactionLevelTest.specsWith db + ForeignKey.specsWith db + MpsNoPrefixTest.specsWith db + MpsCustomPrefixTest.specsWith db + EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith db + PersistUniqueTest.specsWith db + CustomPersistFieldTest.specsWith db + CustomPrimaryKeyReferenceTest.specsWith db + InsertDuplicateUpdate.specs + MigrationColumnLengthTest.specsWith db + EquivalentTypeTest.specsWith db + TransactionLevelTest.specsWith db - MigrationIdempotencyTest.specsWith db - CustomConstraintTest.specs db - -- TODO: implement automatic truncation for too long foreign keys, so we can run this test. - xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $ - LongIdentifierTest.specsWith db - GeneratedColumnTestSQL.specsWith db + MigrationIdempotencyTest.specsWith db + CustomConstraintTest.specs db + -- TODO: implement automatic truncation for too long foreign keys, so we can run this test. + xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $ + LongIdentifierTest.specsWith db + GeneratedColumnTestSQL.specsWith db roundFn :: RealFrac a => a -> Integer roundFn = round