persistent-mysql-haskell 0.5.2 → 0.6.0

raw patch · 8 files changed

+576/−68 lines, 8 filesdep +HUnitdep +QuickCheckdep +fast-loggerdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, fast-logger, hspec, persistent-qq, persistent-test, quickcheck-instances

Dependency ranges changed: aeson, base, bytestring, conduit, containers, persistent, resourcet, text, time, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Database/Persist/MySQL.hs +39/−53
• example/Main.hs +1/−1
• persistent-mysql-haskell.cabal +46/−14
• test/CustomConstraintTest.hs +45/−0
• test/InsertDuplicateUpdate.hs +144/−0
• test/MyInit.hs +102/−0
• test/main.hs +193/−0

@@ -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.

@@ -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." #-} 

@@ -1,5 +1,5 @@ {-# LANGUAGE EmptyDataDecls             #-}-{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}

@@ -1,12 +1,12 @@ name:            persistent-mysql-haskell-version:         0.5.2+version:         0.6.0 license:         MIT license-file:    LICENSE author:          Naushadh <naushadh@protonmail.com>, Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman maintainer:      Naushadh <naushadh@protonmail.com> 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

@@ -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)

@@ -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)

@@ -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

@@ -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