persistent-mysql 2.12.1.0 → 2.13.0.0
raw patch · 6 files changed
+455/−292 lines, 6 filesdep +http-api-datadep +path-piecesdep ~aesondep ~persistent
Dependencies added: http-api-data, path-pieces
Dependency ranges changed: aeson, persistent
Files
- ChangeLog.md +6/−0
- Database/Persist/MySQL.hs +161/−152
- persistent-mysql.cabal +30/−24
- test/ImplicitUuidSpec.hs +83/−0
- test/MyInit.hs +62/−11
- test/main.hs +113/−105
ChangeLog.md view
@@ -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)
Database/Persist/MySQL.hs view
@@ -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- -- <http://dev.mysql.com/doc/refman/5.5/en/select.html>- , 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+ -- <http://dev.mysql.com/doc/refman/5.5/en/select.html>+ , 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
persistent-mysql.cabal view
@@ -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 <felipe.lessa@gmail.com>, 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
+ test/ImplicitUuidSpec.hs view
@@ -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`)
test/MyInit.hs view
@@ -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
test/main.hs view
@@ -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