diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # ChangeLog for `persistent-mysql-haskell` +## 0.6.0 + +- Port [#977](https://github.com/yesodweb/persistent/pull/977) from `persistent-mysql`: Support Stackage Nightly +- Added `constraint=` attribute to allow users to specify foreign reference constraint names. +- Port [#894](https://github.com/yesodweb/persistent/pull/894) from `persistent-mysql`: Remove deprecated `SomeField` type and pattern synonym. Use `HandleUpdateCollision` type instead and the `copyField` function instead of `SomeField` constructor/pattern. + ## 0.5.2 - Fix [stackage#4312](https://github.com/commercialhaskell/stackage/issues/4312): Relax `network` version bound. diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -- | A MySQL backend for @persistent@. module Database.Persist.MySQL ( withMySQLPool @@ -25,14 +22,10 @@ , insertEntityOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate , insertEntityManyOnDuplicateKeyUpdate -#if MIN_VERSION_base(4,7,0) - , HandleUpdateCollision - , pattern SomeField -#elif MIN_VERSION_base(4,9,0) - , HandleUpdateCollision(SomeField) -#endif - , SomeField - , copyField + , HandleUpdateCollision + , pattern SomeField + , SomeField + , copyField , copyUnlessNull , copyUnlessEmpty , copyUnlessEq @@ -48,40 +41,41 @@ import Control.Arrow import Control.Monad (void) -import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (runReaderT, ReaderT) import Control.Monad.Trans.Writer (runWriterT) -import Data.Either (partitionEithers) -import Data.Monoid ((<>)) -import qualified Data.Monoid as Monoid +import Data.Conduit (ConduitM, (.|), runConduit, runConduitRes) +import qualified Data.Conduit.List as CL +import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Either (partitionEithers) import Data.Fixed (Pico) import Data.Function (on) +import Data.Int (Int64) import Data.IORef import Data.List (find, intercalate, sort, groupBy) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import qualified Data.Monoid as Monoid import Data.Pool (Pool) import Data.Text (Text, pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Text.Read (readMaybe) import System.Environment (getEnvironment) -import Data.Acquire (Acquire, mkAcquire, with) -import Data.Conduit (ConduitM, (.|), runConduit, runConduitRes) -import qualified Data.ByteString.Lazy as BS -import qualified Data.Conduit.List as CL -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - import Database.Persist.Sql import Database.Persist.Sql.Types.Internal (mkPersistBackend, makeIsolationLevelStatement) import qualified Database.Persist.Sql.Util as Util import Database.Persist.MySQLConnectInfoShowInstance () -import Data.Int (Int64) import qualified Database.MySQL.Base as MySQL import qualified Database.MySQL.TLS as MySQLTLS @@ -89,23 +83,20 @@ import qualified System.IO.Streams as Streams import qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time -import qualified Data.ByteString.Char8 as BSC import qualified Network.Socket as NetworkSocket import qualified Data.Word as Word -import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.String (fromString) -import Prelude -- | Create a MySQL connection pool and run the given action. -- 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 :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend) +withMySQLPool :: (MonadLogger m, MonadUnliftIO m) => MySQLConnectInfo -- ^ Connection information. -> Int -- ^ Number of connections to be kept open in the pool. - -> (Pool backend -> m a) + -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the connection pool. -> m a withMySQLPool ci = withSqlPool $ open' ci @@ -114,21 +105,21 @@ -- | 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, MonadLogger m, IsSqlBackend backend) +createMySQLPool :: (MonadUnliftIO m, MonadLogger m) => MySQLConnectInfo -- ^ Connection information. -> Int -- ^ Number of connections to be kept open in the pool. - -> m (Pool backend) + -> 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, MonadLogger m, IsSqlBackend backend) +withMySQLConn :: (MonadUnliftIO m, MonadLogger m) => MySQLConnectInfo -- ^ Connection information. - -> (backend -> m a) + -> (SqlBackend -> m a) -- ^ Action to be executed that uses the connection. -> m a withMySQLConn = withSqlConn . open' @@ -142,7 +133,7 @@ -- | Internal function that opens a @persistent@ connection to the MySQL -- server. -open' :: (IsSqlBackend backend) => MySQLConnectInfo -> LogFunc -> IO backend +open' :: MySQLConnectInfo -> LogFunc -> IO SqlBackend open' ci@(MySQLConnectInfo innerCi _) logFunc = do conn <- connect' ci autocommit' conn False -- disable autocommit! @@ -286,6 +277,7 @@ MySQL.putTextField $ MySQL.MySQLDecimal $ read $ show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field render (P (PersistDbSpecific b)) = MySQL.putTextField $ MySQL.MySQLBytes b + render (P (PersistArray a)) = MySQL.render (P (PersistList a)) render (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a MySQL value" @@ -351,8 +343,8 @@ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference=Just (refTblName, _a) } <- newcols - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols + return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs @@ -637,7 +629,7 @@ -- | Parse the type of column as returned by MySQL's -- @INFORMATION_SCHEMA@ tables. -parseColumnType :: Monad m => Text -> ColumnInfo -> m (SqlType, Maybe Integer) +parseColumnType :: Text -> ColumnInfo -> ExceptT String IO (SqlType, Maybe Integer) -- Ints parseColumnType "tinyint" ci | ciColumnType ci == "tinyint(1)" = return (SqlBool, Nothing) parseColumnType "int" ci | ciColumnType ci == "int(11)" = return (SqlInt32, Nothing) @@ -709,12 +701,12 @@ -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols = +findAlters _tblName allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols = case filter ((name ==) . cName) cols of -- new fkey that didnt exist before [] -> case ref of Nothing -> ([(name, Add' col)],[]) - Just (tname, _b) -> let cnstr = [addReference allDefs (refName tblName name) tname name] + Just (tname, cname) -> let cnstr = [addReference allDefs cname tname name] in (map ((,) tname) (Add' col : cnstr), cols) Column _ isNull' type_' def' _defConstraintName' maxLen' ref':_ -> let -- Foreign key @@ -722,7 +714,7 @@ (False, Just (_, cname)) -> [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, _cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)] + (False, Just (tname, cname)) -> [(tname, addReference allDefs cname tname name)] _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] @@ -893,10 +885,6 @@ , escapeDBName cname ] -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ T.concat [table, "_", column, "_fkey"] - ---------------------------------------------------------------------- escape :: DBName -> Text @@ -1052,8 +1040,8 @@ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference=Just (refTblName, _a) } <- newcols - return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols + return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname) let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs @@ -1153,7 +1141,7 @@ -- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via -- 'insertManyOnDuplicateKeyUpdate' in this library. -- --- @since 3.0.0 +-- @since 2.8.0 data HandleUpdateCollision record where -- | Copy the field directly from the record. CopyField :: EntityField record typ -> HandleUpdateCollision record @@ -1167,9 +1155,7 @@ -- @since 2.6.2 type SomeField = HandleUpdateCollision -#if MIN_VERSION_base(4,8,0) pattern SomeField :: EntityField record typ -> SomeField record -#endif 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." #-} diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,5 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/persistent-mysql-haskell.cabal b/persistent-mysql-haskell.cabal --- a/persistent-mysql-haskell.cabal +++ b/persistent-mysql-haskell.cabal @@ -1,12 +1,12 @@ name: persistent-mysql-haskell -version: 0.5.2 +version: 0.6.0 license: MIT license-file: LICENSE author: Naushadh , Felipe Lessa , Michael Snoyman maintainer: Naushadh synopsis: A pure haskell backend for the persistent library using MySQL database server. category: Database, Yesod -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/naushadh/persistent/issues @@ -26,16 +26,16 @@ extra-source-files: ChangeLog.md, README.md library - build-depends: base >= 4.6 && < 5 - , transformers >= 0.2.1 - , persistent >= 2.9.0 && < 3 - , containers >= 0.2 - , bytestring >= 0.9 - , text >= 0.11.0.6 + build-depends: base >= 4.9 && < 5 + , transformers >= 0.5 + , persistent >= 2.10.0 && < 3 + , containers >= 0.5 + , bytestring >= 0.10.8 + , text >= 1.2 , unliftio-core - , aeson >= 0.6.2 - , conduit >= 1.2.8 - , resourcet >= 0.4.10 + , aeson >= 1.0 + , conduit >= 1.2.12 + , resourcet >= 1.1 , monad-logger , resource-pool , mysql-haskell >= 0.8.0.0 && < 1.0 @@ -47,20 +47,52 @@ exposed-modules: Database.Persist.MySQL other-modules: Database.Persist.MySQLConnectInfoShowInstance ghc-options: -Wall + default-language: Haskell2010 executable persistent-mysql-haskell-example hs-source-dirs: example main-is: Main.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: base >= 4.6 && < 5 - , persistent >= 2.6.1 && < 3 + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , persistent >= 2.10.0 && < 3 , monad-logger , persistent-template , persistent-mysql-haskell - , transformers >= 0.2.1 + , transformers >= 0.5 source-repository head type: git location: git://github.com/naushadh/persistent.git branch: persistent-mysql-haskell subdir: persistent-mysql-haskell + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + other-modules: MyInit + InsertDuplicateUpdate + CustomConstraintTest + ghc-options: -Wall + + build-depends: base >= 4.9 && < 5 + , persistent + , persistent-mysql-haskell + , persistent-qq + , persistent-template + , persistent-test + , bytestring + , containers + , fast-logger + , hspec >= 2.4 + , HUnit + , monad-logger + , QuickCheck + , quickcheck-instances + , resourcet + , text + , time + , transformers + , unliftio-core + default-language: Haskell2010 diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs new file mode 100644 --- /dev/null +++ b/test/CustomConstraintTest.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module CustomConstraintTest where + +import MyInit +import qualified Data.Text as T + +share [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] [persistLowerCase| +CustomConstraint1 + some_field Text + deriving Show + +CustomConstraint2 + cc_id CustomConstraint1Id constraint=custom_constraint + deriving Show +|] + +specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec +specs runDb = do + describe "custom constraint used in migration" $ do + it "custom constraint is actually created" $ runDb $ do + runMigration customConstraintMigrate + runMigration customConstraintMigrate -- run a second time to ensure the constraint isn't dropped + let query = T.concat ["SELECT COUNT(*) " + ,"FROM information_schema.key_column_usage " + ,"WHERE ordinal_position=1 " + ,"AND referenced_table_name=? " + ,"AND referenced_column_name=? " + ,"AND table_name=? " + ,"AND column_name=? " + ,"AND constraint_name=?"] + [Single exists] <- rawSql query [PersistText "custom_constraint1" + ,PersistText "id" + ,PersistText "custom_constraint2" + ,PersistText "cc_id" + ,PersistText "custom_constraint"] + liftIO $ 1 @?= (exists :: Int) diff --git a/test/InsertDuplicateUpdate.hs b/test/InsertDuplicateUpdate.hs new file mode 100644 --- /dev/null +++ b/test/InsertDuplicateUpdate.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module InsertDuplicateUpdate where + +import Data.List (sort) + +import Database.Persist.MySQL +import MyInit + +share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| + Item + name Text sqltype=varchar(80) + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + + ItemSize + Id (Key Item) sqltype=varchar(80) + size Int + deriving Eq Show Ord +|] + +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do + let item1 = Item "item1" "" (Just 3) Nothing + item2 = Item "item2" "hello world" Nothing (Just 2) + items = [item1, item2] + item1Size = ItemSize 10 + item2Size = ItemSize 17 + itemsSize = [item1Size, item2Size] + describe "insertOnDuplicateKeyUpdate" $ do + it "inserts appropriately" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertOnDuplicateKeyUpdate item1 [ItemDescription =. "i am item 1"] + Just item <- get (ItemKey "item1") + item @== item1 + + it "performs only updates given if record already exists" $ db $ do + deleteWhere ([] :: [Filter Item]) + let newDescription = "I am a new description" + _ <- insert item1 + insertOnDuplicateKeyUpdate + (Item "item1" "i am inserted description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + Just item <- get (ItemKey "item1") + item @== item1 { itemDescription = newDescription } + + describe "insertEntityOnDuplicateKeyUpdate" $ do + it "inserts appropriately" $ db $ do + deleteWhere ([] :: [Filter Item]) + deleteWhere ([] :: [Filter ItemSize]) + key <- insert item1 + insertEntityOnDuplicateKeyUpdate (Entity (ItemSizeKey key) item1Size) [ItemSizeSize =. 42] + Just itemSize <- get (ItemSizeKey key) + itemSize @== item1Size + + it "performs only updates given if record already exists" $ db $ do + deleteWhere ([] :: [Filter Item]) + deleteWhere ([] :: [Filter ItemSize]) + let newCount = 13 + key <- insert item1 + insertKey (ItemSizeKey key) item1Size + insertEntityOnDuplicateKeyUpdate + (Entity (ItemSizeKey key) item1Size) + [ItemSizeSize =. newCount] + Just itemSize <- get (ItemSizeKey key) + itemSize @== item1Size { itemSizeSize = newCount } + + describe "insertManyOnDuplicateKeyUpdate" $ do + it "inserts fresh records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItem = Item "item3" "fresh" Nothing Nothing + insertManyOnDuplicateKeyUpdate + (newItem : items) + [copyField ItemDescription] + [] + dbItems <- map entityVal <$> selectList [] [] + sort dbItems @== sort (newItem : items) + it "updates existing records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + insertManyOnDuplicateKeyUpdate + items + [] + [ItemQuantity +=. Just 1] + it "only copies passing values" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + insertManyOnDuplicateKeyUpdate + newItems + [ copyUnlessEq ItemQuantity (Just 0) + , copyField ItemPrice + ] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate + it "inserts without modifying existing records if no updates specified" $ db $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + insertManyOnDuplicateKeyUpdate + (newItem : items) + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + + describe "insertEntityManyOnDuplicateKeyUpdate" $ do + it "inserts fresh records" $ db $ do + deleteWhere ([] :: [Filter Item]) + deleteWhere ([] :: [Filter ItemSize]) + keys <- insertMany items + let entities = zipWith (Entity . ItemSizeKey) keys itemsSize + void $ insertEntityMany $ tail entities + insertEntityManyOnDuplicateKeyUpdate + entities + [copyField ItemSizeSize] + [] + dbItems <- selectList [] [] + sort dbItems @== sort entities + it "updates existing records" $ db $ do + deleteWhere ([] :: [Filter Item]) + deleteWhere ([] :: [Filter ItemSize]) + keys <- insertMany items + let entities = zipWith (Entity . ItemSizeKey) keys itemsSize + void $ insertEntityMany entities + insertEntityManyOnDuplicateKeyUpdate + entities + [] + [ItemSizeSize +=. 1] + dbItems <- selectList [] [] + sort dbItems @== sort (map (\(Entity k v) -> Entity k (v { itemSizeSize = itemSizeSize v + 1 })) entities) diff --git a/test/MyInit.hs b/test/MyInit.hs new file mode 100644 --- /dev/null +++ b/test/MyInit.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MyInit ( + (@/=), (@==), (==@) + , asIO + , assertNotEqual + , assertNotEmpty + , assertEmpty + , isTravis + , BackendMonad + , runConn + + , MonadIO + , persistSettings + , MkPersistSettings (..) + , db + , BackendKey(..) + , GenerateKey(..) + + , RunDb + -- re-exports + , module Database.Persist + , module Database.Persist.Sql.Raw.QQ + , module Test.Hspec + , module Test.HUnit + , liftIO + , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , Int32, Int64 + , Text + , module Control.Monad.Trans.Reader + , module Control.Monad + , module Database.Persist.Sql + , BS.ByteString + , SomeException + , MonadFail + , TestFn(..) + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , arbText + , liftA2 + ) where + +import Init + ( TestFn(..), truncateTimeOfDay, truncateUTCTime + , truncateToMicro, arbText, GenerateKey(..) + , (@/=), (@==), (==@) + , assertNotEqual, assertNotEmpty, assertEmpty, asIO + , isTravis, RunDb, MonadFail + ) + +-- re-exports +import Control.Applicative (liftA2) +import Control.Exception (SomeException) +import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad.Trans.Reader +import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Database.Persist.Sql.Raw.QQ +import Test.Hspec +import Test.QuickCheck.Instances () + +-- testing +import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) + +import Control.Monad (unless, (>=>)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.IO.Class +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 System.Log.FastLogger (fromLogStr) + +import Database.Persist +import Database.Persist.MySQL +import Database.Persist.Sql +import Database.Persist.TH () + +_debugOn :: Bool +_debugOn = False + +persistSettings :: MkPersistSettings +persistSettings = sqlSettings { mpsGeneric = True } + +type BackendMonad = SqlBackend + +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 + let ff = rawExecute "SET SESSION sql_mode = ''" [] >> f + flip runLoggingT (\_ _ _ s -> printDebug s) $ do + _ <- if not travis + then withMySQLPool (mkMySQLConnectInfo "localhost" "test" "test" "test") 1 $ runSqlPool ff + else withMySQLPool (mkMySQLConnectInfo "localhost" "travis" "" "persistent") 1 $ runSqlPool ff + return () + +db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion +db actions = do + runResourceT $ runConn $ actions >> transactionUndo diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +import MyInit + +import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import Data.Fixed +import Test.QuickCheck +import qualified Data.Text as T +import Data.IntMap (IntMap) +import qualified Data.ByteString as BS + +import qualified CompositeTest +import qualified CustomPersistFieldTest +import qualified CustomPrimaryKeyReferenceTest +import qualified DataTypeTest +import qualified EmbedOrderTest +import qualified EmbedTest +import qualified EmptyEntityTest +import qualified EquivalentTypeTest +import qualified HtmlTest +import qualified InsertDuplicateUpdate +import qualified LargeNumberTest +import qualified MaxLenTest +import qualified MigrationColumnLengthTest +import qualified MigrationIdempotencyTest +import qualified MigrationOnlyTest +import qualified MpsNoPrefixTest +import qualified PersistentTest +import qualified PersistUniqueTest +-- FIXME: Not used... should it be? +-- import qualified PrimaryTest +import qualified RawSqlTest +import qualified ReadWriteTest +import qualified Recursive +import qualified RenameTest +import qualified SumTypeTest +import qualified TransactionLevelTest +import qualified UniqueTest +import qualified UpsertTest +import qualified CustomConstraintTest + +type Tuple a b = (a, b) + +-- Test lower case names +share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +DataTypeTable no-json + text Text + textMaxLen Text maxlen=100 + bytes ByteString + bytesTextTuple (Tuple ByteString Text) + bytesMaxLen ByteString maxlen=100 + int Int + intList [Int] + intMap (IntMap Int) + double Double + bool Bool + day Day + pico Pico + time TimeOfDay + utc UTCTime + -- For MySQL, provide extra tests for time fields with fractional seconds, + -- since the default (used above) is to have no fractional part. This + -- requires the server version to be at least 5.6.4, and should be switched + -- off for older servers by defining OLD_MYSQL. + timeFrac TimeOfDay sqltype=TIME(6) + utcFrac UTCTime sqltype=DATETIME(6) +|] + +instance Arbitrary (DataTypeTableGeneric backend) where + arbitrary = DataTypeTable + <$> arbText -- text + <*> (T.take 100 <$> arbText) -- textManLen + <*> arbitrary -- bytes + <*> liftA2 (,) arbitrary arbText -- bytesTextTuple + <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen + <*> arbitrary -- int + <*> arbitrary -- intList + <*> arbitrary -- intMap + <*> arbitrary -- double + <*> arbitrary -- bool + <*> arbitrary -- day + <*> arbitrary -- pico + <*> (truncateTimeOfDay =<< arbitrary) -- time + <*> (truncateUTCTime =<< arbitrary) -- utc + <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac + <*> (truncateUTCTime =<< arbitrary) -- utcFrac + +setup :: MonadIO m => Migration -> ReaderT SqlBackend m () +setup migration = do + printMigration migration + runMigrationUnsafe migration + +main :: IO () +main = do + runConn $ do + mapM_ setup + [ PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , 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 + ] + PersistentTest.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" (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 + + MpsNoPrefixTest.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 + +roundFn :: RealFrac a => a -> Integer +roundFn = round + +roundTime :: TimeOfDay -> TimeOfDay +roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t + +roundUTCTime :: UTCTime -> UTCTime +roundUTCTime t = + posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t