persistent-mysql-pure (empty) → 1.0.0
raw patch · 11 files changed
+2813/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +aeson
Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, conduit, containers, fast-logger, hspec, http-api-data, io-streams, monad-logger, mysql-pure, network, path-pieces, persistent, persistent-mysql-pure, persistent-qq, persistent-test, quickcheck-instances, resource-pool, resourcet, text, time, tls, transformers, unliftio-core
Files
- ChangeLog.md +101/−0
- LICENSE +20/−0
- README.md +170/−0
- example/Main.hs +58/−0
- persistent-mysql-pure.cabal +113/−0
- src/Database/Persist/MySQL.hs +1677/−0
- test/CustomConstraintTest.hs +72/−0
- test/ImplicitUuidSpec.hs +83/−0
- test/InsertDuplicateUpdate.hs +139/−0
- test/MyInit.hs +155/−0
- test/main.hs +225/−0
+ ChangeLog.md view
@@ -0,0 +1,101 @@+# ChangeLog for `persistent-mysql-pure`++## 1.0.0++ fork from `persistent-mysql-haskell`.++ Use persistent-mysql-pure under the hood.++ Delete all other persistent stuff.++ Add CI++ Add autobump action for constraints++ Add nightly build++## 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.++## 0.5.1++- [#9](https://github.com/naushadh/persistent/pull/9) Add `insertEntityOnDuplicateKeyUpdate` and `insertEntityManyOnDuplicateKeyUpdate` functions++## 0.5.0++- Port [#812](https://github.com/yesodweb/persistent/pull/812) from `persistent-mysql`: Add support for SQL isolation levels+- Port [#833](https://github.com/yesodweb/persistent/pull/833) from `persistent-mysql`: `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic.++## 0.4.2++- [#7](https://github.com/naushadh/persistent/pull/7) Fix boolean conversion bug.++## 0.4.1++- Fix [#2](https://github.com/naushadh/persistent/issues/2): Better compatibility with `yesod` scaffold.++## 0.4.0++- Port [#770](https://github.com/yesodweb/persistent/pull/770) from `persistent-mysql`: Performance enhancements for bulk writes.+- Port [#773](https://github.com/yesodweb/persistent/pull/773) from `persistent-mysql`: Support new conduit release. Includes bundled changes from other PRs.+ - [#723](https://github.com/yesodweb/persistent/pull/723) More BackendCompatible generalizations.+ - [#760](https://github.com/yesodweb/persistent/pull/760) Rename SomeField type to HandleUpdateCollision.++## 0.3.6++- Port [#752](https://github.com/yesodweb/persistent/pull/754) from `persistent-mysql`: Fix mysql sqltype migrations.++## 0.3.5++- Updated `selectSource` implementation to stream results instead of loading everything into memory.++## 0.3.4.1++- Fix a haddock issue down-streamed from [#693](https://github.com/yesodweb/persistent/pull/693).++## 0.3.4++- Port [#693](https://github.com/yesodweb/persistent/pull/693) from `persistent-mysql`: Extend the `SomeField` type to allow `insertManyOnDuplicateKeyUpdate` to conditionally copy values.+- Port [#702](https://github.com/yesodweb/persistent/pull/702) from `persistent-mysql`: Fix behavior of `insertManyOnDuplicateKeyUpdate` to ignore duplicate key exceptions when no updates specified.+- Bumped TLS bounds to be in [sync with `mysql-haskell`](https://github.com/winterland1989/mysql-haskell/pull/15) and land ourselves [back on stackage](https://github.com/fpco/stackage/pull/2956).++## 0.3.3++- Port from `persistent-mysql`: MySQL on duplicate key update [#674](https://github.com/yesodweb/persistent/pull/674).++## 0.3.2.1++- Port from `persistent-mysql`: Prevent spurious no-op migrations when `default=NULL` is specified - revised version [#672](https://github.com/yesodweb/persistent/pull/672) (which fixes bug [#671](https://github.com/yesodweb/persistent/issues/671) introduced by the earlier attempt [#641](https://github.com/yesodweb/persistent/pull/641)).++## 0.3.2.0++- Added conditional declaration of `Show` instance for mysql-haskell's `ConnectInfo` for compatibility with `mysql-haskell-0.8.1.0+`.++## 0.3.1.0++- Fixed compiler warnings in `stack --pedantic` mode so the project can run upstream tests on Travis.+- Minor README enhancements for badges and fixed URL for example when viewing outside of Github.++## 0.3.0.0++- Added API for setting [TLS client parameters](https://hackage.haskell.org/package/mysql-haskell-0.8.0.0/docs/Database-MySQL-TLS.html) for secure MySQL connections.+- Exported [Data.TLSSetting](https://hackage.haskell.org/package/tcp-streams-1.0.0.0/docs/Data-TLSSetting.html) for convenient usage of TLS.++## 0.2.1.0++- Bumped up version to update README.++## 0.2.0.0++- Added APIs for setting port number and character encoding.+- Updated type signature for mkMySQLConnectInfo to align with mysql-haskell.++## 0.1.1.0++- Bumped up version to include README and example.++## 0.1.0.0++- Ported persistent-mysql 2.6 to use mysql-haskell as the underlying database driver.+- Deprecated MySQLConf and ConnectInfo native constructor and default instance in favor of mk functions for better forward compatibility. See http://www.snoyman.com/blog/2016/11/designing-apis-for-extensibility.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,170 @@+# persistent-mysql-pure++[](https://hackage.haskell.org/package/persistent-mysql-pure)++This is a fork of persistent-mysql-haskell.+Using the latest [branch](https://github.com/chordify/persistent/tree/persistent-mysql-haskell-9.2)+from chordify.++A pure haskell backend for [persistent](https://github.com/yesodweb/persistent) using the MySQL database server.+Internally it uses the [mysql-pure](https://github.com/jappeace/mysql-pure) driver in order to access the database.++See [example/Main.hs](https://github.com/naushadh/persistent/blob/persistent-mysql-pure/persistent-mysql-pure/example/Main.hs) for how this MySQL backend can be used with Persistent.++### Motivation++`persistent-mysql` uses [mysql](https://hackage.haskell.org/package/mysql) (via [mysql-simple](https://hackage.haskell.org/package/mysql-simple)) as the database driver. `mysql` is a haskell FFI wrapper for `mysqlclient` written in C.++Reasons to use a pure haskell driver:++- `mysql` has [concurrency issues](https://ro-che.info/articles/2015-04-17-safe-concurrent-mysql-pure) as noted by [@feuerbach](https://github.com/feuerbach).++- [mysql-pure](https://hackage.haskell.org/package/mysql-pure), a pure haskell driver by [@winterland1989](https://github.com/winterland1989), outperforms `mysql-simple` in benchmarks (see hackage or project repo).++- better portability and possible static compilation of an entire project that uses `persistent-mysql`.++- result streaming support means persistent [`selectSource` streams data from database](http://www.jakubkonka.com/2014/01/23/conduit-haskell.html). Effectively addressing [#657 selectSource does not stream results](https://github.com/yesodweb/persistent/issues/657).++- a newtype-d `MySQLConnectInfo` allows adding configuring _how_ persistent and the underlying driver are glued. Ex: [#679](https://github.com/yesodweb/persistent/issues/679) can be elegantly addressed in this library.++Personal experience on replacing `mysql-simple` with `mysql-pure` in a project:++- Performance gains consistent with benchmark.++- Smoother deployment to [AWS](https://en.wikipedia.org/wiki/Amazon_Machine_Image), since `mysql` appears to have a hard dependency on the oracle version of `libmysqlclient` that does not work with the open source variant that is available by default on Amazon Linux (and possibly on other Linux distros).++### Potential issues moving from persistent-mysql to persistent-mysql-pure++`ConnectInfo` and `defaultConnectInfo` are not the same between `mysql` and `mysql-pure`, therefore this package is not a 100% drop in replacement for persistent-mysql from the connection configuration perspective.++- `mysql-pure` does not allow provide an API for the entirety of [mysqlclient options](https://hackage.haskell.org/package/mysql-0.1.4/docs/Database-MySQL-Base.html#t:Option). Therefore neither can this package.++- Given the inevitable incompatibility with `persistent-mysql`, and in the interest of [providing a forward-compatible API](http://www.snoyman.com/blog/2016/11/designing-apis-for-extensibility), `ConnectInfo` internals and `defaultConnectInfo` have been deprecated. However the similar utility can be achieved like so:++ ```diff+ import Database.Persist.MySQL++ connectInfo :: MySQLConnectInfo+ - connectInfo = defaultConnectInfo+ - { connectHost = "localhost"+ - , connectUser = "test"+ - , connectPassword = "test"+ - , connectDatabase = "test"+ - }+ + connectInfo = mkMySQLConnectInfo "localhost" "test" "test" "test"++ connectInfoNewPort :: MySQLConnectInfo+ - connectInfoNewPort = connectInfo { connectPort = 3307 }+ + connectInfoNewPort = setMySQLConnectInfoPort 3307 connectInfo++ connectInfoNewCharSet :: MySQLConnectInfo+ - connectInfoNewCharSet = connectInfo { connectOptions = [CharsetName "utf8"] }+ + connectInfoNewCharSet = setMySQLConnectInfoCharset 33 connectInfo++ ```++- `mysql-pure` and `mysql` have different APIs/mechanisms for securing the+connection to MySQL. `persistent-mysql-pure` exposes an API to utilize+[TLS client params](https://hackage.haskell.org/package/mysql-pure/docs/Database-MySQL-TLS.html)+that ships with `mysql-pure`.++ ```diff+ connectInfoCustomCaStore :: MySQLConnectInfo+ - connectInfoCustomCaStore = connectInfo { connectSSL = Just customCaParams }+ + connectInfoCustomCaStore = setMySQLConnectInfoTLS customCaParams connectInfo+ where+ - customCaParams = defaultSSLInfo { sslCAPath = "foobar.pem" }+ + customCaParams = makeClientParams $ CustomCAStore "foobar.pem"+ ```+++Aside from connection configuration, persistent-mysql-pure is functionally on par with persistent-mysql (as of writing this). This can be seen by [comparing persistent-test between this fork and upstream](https://github.com/yesodweb/persistent/compare/master...naushadh:persistent-mysql-pure#diff-028f5df7b2b9c5c8b0fa670fc8c69bff).++#### Yesod++In order to use `persistent-mysql-pure` with `yesod` you have to modify `Settings.hs`:++ ```diff+ - import Database.Persist.MySQL (MySQLConf (..))+ + import Database.Persist.MySQL (MySQLConf, mkMySQLConf, myConnInfo, myPoolSize, setMySQLConnectInfoCharset)+ ```++ ```diff+ - import qualified Database.MySQL.Base as MySQL+ ```++ ```diff+ - -- This code enables MySQL's strict mode, without which MySQL will truncate data.+ - -- See https://github.com/yesodweb/persistent/wiki/Database-Configuration#strict-mode for details+ - -- If you choose to keep strict mode enabled, it's recommended that you enable it in your my.cnf file so that it's also enabled for your MySQL console sessions.+ - -- (If you enable it in your my.cnf file, you can delete this code).+ - let appDatabaseConf = fromYamlAppDatabaseConf { myConnInfo = (myConnInfo fromYamlAppDatabaseConf) {+ - MySQL.connectOptions =+ - ( MySQL.connectOptions (myConnInfo fromYamlAppDatabaseConf)) ++ [MySQL.InitCommand "SET SESSION sql_mode = 'STRICT_ALL_TABLES';\0"]+ - }+ - }+ ```++And in `Application.hs`:++ ```diff+ - import qualified Database.MySQL.Base as MySQL+ ```++ ```diff+ import Network.Wai.Handler.Warp (Settings, defaultSettings,+ defaultShouldDisplayException,+ runSettings, setHost,+ - setFork, setOnOpen, setOnClose,+ + setFork,+ setOnException, setPort, getPort)+ ```++ ```diff+ - -- See http://www.yesodweb.com/blog/2016/11/use-mysql-safely-in-yesod+ - MySQL.initLibrary+ ```++ ```diff+ - $ setOnOpen (const $ MySQL.initThread >> return True)+ - $ setOnClose (const MySQL.endThread)+ ```++Optionally you may enable the MYSQL strict mode (in each transaction)+by modifying `Foundation.hs` (or editing the `my.cnf` server configuration):++ ```diff+ - import Database.Persist.Sql (ConnectionPool, runSqlPool)+ + import Database.Persist.Sql (ConnectionPool, rawExecute, runSqlPool)+ ```++ ```diff+ - runSqlPool action $ appConnPool master+ + runSqlPool+ + (rawExecute "SET SESSION sql_mode = 'STRICT_ALL_TABLES'" [] >> action)+ + (appConnPool master)+ ```++### FAQs++#### Why isn't this part of the main/upstream persistent repo?++- TLDR: Upstream wants to gauge community interest before absorbing this backend into the main repo.+- Long version: See [issue yesodweb/persistent/issues/659](https://github.com/yesodweb/persistent/issues/659).++#### persistent-mysql supports X but persistent-mysql-pure API doesn't. Why?++- Internals (getters/setters) of MySQLConnectInfo and `defaultConnectInfo` are intentionally masked for [forward compatibility](http://www.snoyman.com/blog/2016/11/designing-apis-for-extensibility).++- For all others, feel free to open an issue and/or submit a PR.++#### Does persistent-mysql-pure ship with tests?++- It does! :) `persistent-test` is fully re-used with an additional flag to specifically test persistent-mysql-pure.++ - [CI/Travis](https://travis-ci.org/naushadh/persistent), see [.travis.yml](../.travis.yml).++ - Local,+ ```bash+ stack test persistent-test --flag persistent-test:mysql_haskell --exec persistent-test+ ```
+ example/Main.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+++-- | Taken from http://www.yesodweb.com/book/persistent.+module Main where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (runStderrLoggingT)+import Database.Persist+import Database.Persist.MySQL+import Database.Persist.TH+import Control.Monad (void)++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+Person+ name String+ age Int Maybe+ deriving Show+BlogPost+ title String+ authorId PersonId+ deriving Show+|]++connectionInfo :: MySQLConnectInfo+connectionInfo = mkMySQLConnectInfo "localhost" "test" "test" "example"++main :: IO ()+main = runStderrLoggingT $ withMySQLPool connectionInfo 10 $ \pool -> liftIO $ do+ flip runSqlPersistMPool pool $ do+ runMigration migrateAll++ johnId <- insert $ Person "John Doe" $ Just 35+ janeId <- insert $ Person "Jane Doe" Nothing++ void $ insert $ BlogPost "My fr1st p0st" johnId+ void $ insert $ BlogPost "One more for good measure" johnId++ oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1]+ liftIO $ print (oneJohnPost :: [Entity BlogPost])++ john <- get johnId+ liftIO $ print (john :: Maybe Person)++ delete janeId+ deleteWhere [BlogPostAuthorId ==. johnId]
+ persistent-mysql-pure.cabal view
@@ -0,0 +1,113 @@+cabal-version: 2.2+name: persistent-mysql-pure+version: 1.0.0+license: MIT+license-file: LICENSE+author:+ Naushadh <naushadh@protonmail.com>, Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman++maintainer: Jappie <hi@jappie.me>+synopsis:+ A pure haskell backend for the persistent library using MySQL database server.++category: Database, Yesod+build-type: Simple+homepage: http://www.yesodweb.com/book/persistent+bug-reports: https://github.com/jappeace/persistent-mysql-pure/issues+description:+ This package contains a backend for persistent using the+ MySQL database server. Internally it uses the @mysql-pure@+ package in order to access the database. See README.md for more.+ .+ This package supports only MySQL 5.1 and above. However, it+ has been tested only on MySQL 5.5.+ Only the InnoDB storage engine is officially supported.+ .+ Known problems:+ .+ * This package does not support statements inside other+ statements.++extra-doc-files:+ ChangeLog.md+extra-source-files:+ README.md++library+ build-depends:+ , aeson >=1.0 && <2.3+ , base >=4.9 && <4.19+ , bytestring >=0.10.8 && <0.13+ , conduit >=1.2.12 && <1.4+ , containers >=0.5 && <0.7+ , io-streams >=1.2 && <2.0+ , monad-logger >=0.3.0 && <0.4+ , mysql-pure >=1.0 && <2.0+ , network >=2.3 && <4.0+ , persistent >=2.10.0 && <3+ , resource-pool <0.5+ , resourcet >=1.1 && <1.4+ , text >=1.2 && <2.1+ , time >=1.5.0 && <1.13+ , tls >=1.3.5 && <1.6+ , transformers >=0.5 && <0.7+ , unliftio-core <0.3++ -- keep the following in sync with @mysql-haskell@ .cabal+ exposed-modules: Database.Persist.MySQL+ ghc-options: -Wall+ default-language: Haskell2010+ hs-source-dirs: src++executable persistent-mysql-pure-example+ hs-source-dirs: example+ main-is: Main.hs+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ build-depends:+ , base >=4.9 && <5+ , monad-logger+ , persistent >=2.10.0 && <3+ , persistent-mysql-pure+ , transformers >=0.5++source-repository head+ type: git+ location: git://github.com/jappeace/persistent-mysql-pure.git++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules:+ CustomConstraintTest+ ImplicitUuidSpec+ InsertDuplicateUpdate+ MyInit++ ghc-options: -Wall+ build-depends:+ , aeson+ , base >=4.9 && <5+ , bytestring+ , containers+ , fast-logger+ , hspec >=2.4+ , http-api-data+ , HUnit+ , monad-logger+ , mysql-pure >=0.8+ , path-pieces+ , persistent+ , persistent-mysql-pure+ , persistent-qq+ , persistent-test+ , QuickCheck+ , quickcheck-instances+ , resourcet+ , text+ , time+ , transformers+ , unliftio-core++ default-language: Haskell2010
+ src/Database/Persist/MySQL.hs view
@@ -0,0 +1,1677 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'+-- | A MySQL backend for @persistent@.+module Database.Persist.MySQL+ ( withMySQLPool+ , withMySQLConn+ , createMySQLPool+ , module Database.Persist.Sql+ , MySQLConnectInfo+ , mkMySQLConnectInfo+ , setMySQLConnectInfoPort+ , setMySQLConnectInfoCharset+ , MySQLConf+ , mkMySQLConf+ , mockMigration+ -- * @ON DUPLICATE KEY UPDATE@ Functionality+ , insertOnDuplicateKeyUpdate+ , insertEntityOnDuplicateKeyUpdate+ , insertManyOnDuplicateKeyUpdate+ , insertEntityManyOnDuplicateKeyUpdate+ , HandleUpdateCollision+ , copyField+ , copyUnlessNull+ , copyUnlessEmpty+ , copyUnlessEq+ -- * TLS configuration+ , setMySQLConnectInfoTLS+ , MySQLTLS.TrustedCAStore(..)+ , MySQLTLS.makeClientParams+ , MySQLTLS.makeClientParams'+ , openMySQLConn+ -- * persistent-mysql compatibility+ , myConnInfo+ , myPoolSize+) where++import Control.Arrow+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (runReaderT, ReaderT)+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)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Conduit (ConduitM, (.|), runConduit, runConduitRes)+import qualified Data.Conduit.List as CL+import Data.Either (partitionEithers)+import Data.Fixed (Pico)+import Data.Function (on)+import Data.IORef+import Data.Int (Int64)+import Data.List (find, groupBy, intercalate, sort)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+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 GHC.Stack+import System.Environment (getEnvironment)++import Database.Persist.Sql+import qualified Database.Persist.SqlBackend as SqlBackend+import Database.Persist.SqlBackend.Internal+import Database.Persist.SqlBackend.StatementCache (mkSimpleStatementCache, mkStatementCache)+import Database.Persist.Sql.Types.Internal (mkPersistBackend, makeIsolationLevelStatement)+import qualified Database.Persist.Sql.Util as Util++import qualified Database.MySQL.Base as MySQL+import qualified Database.MySQL.Protocol.Escape as MySQL+import qualified Database.MySQL.TLS as MySQLTLS+import qualified Network.TLS as TLS+import qualified System.IO.Streams as Streams+import qualified Data.Time.Calendar as Time+import qualified Data.Time.LocalTime as Time+import qualified Network.Socket as NetworkSocket+import qualified Data.Word as Word+import Data.String (fromString)++-- | 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 :: (MonadLoggerIO m, MonadUnliftIO m, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)+ => MySQLConnectInfo+ -- ^ Connection information.+ -> Int+ -- ^ Number of connections to be kept open in the pool.+ -> (Pool backend -> 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, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)+ => MySQLConnectInfo+ -- ^ Connection information.+ -> Int+ -- ^ Number of connections to be kept open in the pool.+ -> m (Pool backend)+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, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)+ => MySQLConnectInfo+ -- ^ Connection information.+ -> (backend -> m a)+ -- ^ Action to be executed that uses the connection.+ -> m a+withMySQLConn = withSqlConn . open'++-- | Internal function that opens a @mysql-haskell@ connection to the server.+connect' :: MySQLConnectInfo -> IO MySQL.MySQLConn+connect' (MySQLConnectInfo innerCi Nothing)+ = MySQL.connect innerCi+connect' (MySQLConnectInfo innerCi (Just tls))+ = MySQLTLS.connect innerCi (tls, "persistent-mysql-haskell")++-- | Open a connection to MySQL server, initialize the 'SqlBackend' and return+-- their tuple+--+-- @since 2.12.1.0+openMySQLConn :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)+ => MySQLConnectInfo+ -> LogFunc+ -> IO (MySQL.MySQLConn, backend)+openMySQLConn ci@(MySQLConnectInfo innerCi _) logFunc = do+ conn <- connect' ci+ autocommit' conn False -- disable autocommit!+ smap <- newIORef $ Map.empty+ let stCache = mkStatementCache $ mkSimpleStatementCache smap+ let backend = + mkPersistBackend $ + projectBackend $ + SqlBackend+ { connPrepare = prepare' conn+ , connStmtMap = stCache+ , connInsertSql = insertSql'+ , connInsertManySql = Nothing+ , connUpsertSql = Nothing+ , connPutManySql = Just putManySql+ , connClose = MySQL.close conn+ , connMigrateSql = migrate' innerCi+ , connBegin = const $ begin' conn+ , connCommit = const $ commit' conn+ , connRollback = const $ 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+ , connMaxParams = Nothing+ , connRepsertManySql = Just repsertManySql+ , connVault = mempty+ , connHooks = emptySqlBackendHooks+ }+ pure (conn,backend)++-- | Internal function that opens a connection to the MySQL server.+open' :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)+ => MySQLConnectInfo+ -> LogFunc+ -> IO backend+open' ci logFunc = snd <$> openMySQLConn ci logFunc++-- | Set autocommit setting+autocommit' :: MySQL.MySQLConn -> Bool -> IO ()+autocommit' conn bool = void $ MySQL.execute conn "SET autocommit=?" [encodeBool bool]++-- | Start a transaction.+begin' :: MySQL.MySQLConn -> Maybe IsolationLevel -> IO ()+begin' conn mIso+ = void+ $ mapM_ (MySQL.execute_ conn . fromString . makeIsolationLevelStatement) mIso+ >> MySQL.execute_ conn "BEGIN"++-- | Commit the current transaction.+commit' :: MySQL.MySQLConn -> IO ()+commit' conn = void $ MySQL.execute_ conn "COMMIT"++-- | Rollback the current transaction.+rollback' :: MySQL.MySQLConn -> IO ()+rollback' conn = void $ MySQL.execute_ conn "ROLLBACK"++-- | Prepare a query. We don't support prepared statements, but+-- we'll do some client-side preprocessing here.+prepare' :: MySQL.MySQLConn -> Text -> IO Statement+prepare' conn sql = do+ let query = MySQL.Query . BS.fromStrict . T.encodeUtf8 $ sql+ return Statement+ { stmtFinalize = return ()+ , stmtReset = return ()+ , stmtExecute = execute' conn query+ , stmtQuery = withStmt' conn query+ }+++-- | SQL code to be executed when inserting an entity.+insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult+insertSql' ent vals =+ 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 $ getEntityDBName ent+ , "("+ , T.intercalate "," fieldNames+ , ") VALUES("+ , T.intercalate "," placeholders+ , ")"+ ]++-- | Execute an statement that doesn't return any results.+execute' :: MySQL.MySQLConn -> MySQL.Query -> [PersistValue] -> IO Int64+execute' conn query vals+ = fmap (fromIntegral . MySQL.okAffectedRows) $ MySQL.execute conn query (map P vals)++-- | query' allows arguments to be empty.+query'+ :: MySQL.QueryParam p => MySQL.MySQLConn -> MySQL.Query -> [p]+ -> IO ([MySQL.ColumnDef], Streams.InputStream [MySQL.MySQLValue])+query' conn qry [] = MySQL.query_ conn qry+query' conn qry ps = MySQL.query conn qry ps++-- | Execute an statement that does return results.+-- unlike @persistent-mysql@, we actually _stream_ results.+withStmt' :: MonadIO m+ => MySQL.MySQLConn+ -> MySQL.Query+ -> [PersistValue]+ -> Acquire (ConduitM () [PersistValue] m ())+withStmt' conn query vals+ = fetchRows <$> mkAcquire createResult releaseResult+ where+ createResult = query' conn query (map P vals)+ releaseResult (_, is) = Streams.skipToEof is+ fetchRows (fields, is) = CL.unfoldM getVal is+ where+ -- Find out the type of the columns+ getters = fmap getGetter fields+ convert = zipWith (\g -> \c -> g c) getters+ getVal s = do+ v <- liftIO $ Streams.read s+ case v of+ (Just r) -> pure $ Just (convert r, s)+ _ -> pure Nothing++-- | Encode a Haskell bool into a MySQLValue+encodeBool :: Bool -> MySQL.MySQLValue+encodeBool True = MySQL.MySQLInt8U 1+encodeBool False = MySQL.MySQLInt8U 0++-- | Decode a whole number into a PersistInt64+decodeInteger :: Integral a => a -> PersistValue+decodeInteger = PersistInt64 . fromIntegral++-- | Decode a decimal number into a PersistDouble+decodeDouble :: Real a => a -> PersistValue+decodeDouble = PersistDouble . realToFrac++-- | @newtype@ around 'PersistValue' that supports the+-- 'MySQL.Param' type class.+newtype P = P PersistValue++instance MySQL.QueryParam P where+ render (P (PersistText t)) = MySQL.putTextField $ MySQL.MySQLText t+ render (P (PersistByteString b)) = MySQL.putTextField $ MySQL.MySQLBytes b+ render (P (PersistInt64 i)) = MySQL.putTextField $ MySQL.MySQLInt64 i+ render (P (PersistDouble d)) = MySQL.putTextField $ MySQL.MySQLDouble d+ render (P (PersistBool b)) = MySQL.putTextField $ encodeBool b+ render (P (PersistDay d)) = MySQL.putTextField $ MySQL.MySQLDate d+ render (P (PersistTimeOfDay t)) = MySQL.putTextField $ MySQL.MySQLTime 0 t+ render (P (PersistUTCTime t)) = MySQL.putTextField . MySQL.MySQLTimeStamp $ Time.utcToLocalTime Time.utc t+ render (P (PersistNull)) = MySQL.putTextField $ MySQL.MySQLNull+ render (P (PersistList l)) = MySQL.putTextField . MySQL.MySQLText $ listToJSON l+ render (P (PersistMap m)) = MySQL.putTextField . MySQL.MySQLText $ mapToJSON m+ render (P (PersistRational r)) =+ MySQL.putTextField $ MySQL.MySQLDecimal $ read $ show (fromRational r :: Pico)+ -- FIXME: Too Ambigous, can not select precision without information about field+ render (P (PersistLiteral_ DbSpecific s)) = MySQL.putTextField $ MySQL.MySQLBytes s+ render (P (PersistLiteral_ Unescaped l)) = MySQL.putTextField $ MySQL.MySQLBytes l+ render (P (PersistLiteral_ Escaped e)) = MySQL.putTextField $ MySQL.MySQLBytes $ MySQL.escapeBytes e+ render (P (PersistArray a)) = MySQL.render (P (PersistList a))+ render (P (PersistObjectId _)) =+ error "Refusing to serialize a PersistObjectId to a MySQL value"++-- | @Getter a@ is a function that converts an incoming "MySQLValue"+-- into a data type @a@.+type Getter a = MySQL.MySQLValue -> a++-- | Get the corresponding @'Getter' 'PersistValue'@ depending on+-- the type of the column.+getGetter :: MySQL.ColumnDef -> Getter PersistValue+getGetter _field = go+ where+ -- Int64+ go (MySQL.MySQLInt8U v) = decodeInteger v+ go (MySQL.MySQLInt8 v) = decodeInteger v+ go (MySQL.MySQLInt16U v) = decodeInteger v+ go (MySQL.MySQLInt16 v) = decodeInteger v+ go (MySQL.MySQLInt32U v) = decodeInteger v+ go (MySQL.MySQLInt32 v) = decodeInteger v+ go (MySQL.MySQLInt64U v) = decodeInteger v+ go (MySQL.MySQLInt64 v) = decodeInteger v+ go (MySQL.MySQLBit v) = decodeInteger v+ -- Double+ -- TODO: FIX WARNING(S) AND TRY TO PROVIDE LEAST PRECISION LOSS+ go (MySQL.MySQLFloat v) = decodeDouble v+ go (MySQL.MySQLDouble v) = decodeDouble v+ go (MySQL.MySQLDecimal v) = decodeDouble v+ -- ByteString and Text+ go (MySQL.MySQLBytes v) = PersistByteString v+ go (MySQL.MySQLText v) = PersistText v+ -- Time-related+ -- TODO: REMOVE ASSUMPTION THAT DATETIME and TIMESTAMP are in UTC+ go (MySQL.MySQLDateTime v) = PersistUTCTime $ Time.localTimeToUTC Time.utc v+ go (MySQL.MySQLTimeStamp v) = PersistUTCTime $ Time.localTimeToUTC Time.utc v+ go (MySQL.MySQLYear v) = PersistDay (Time.fromGregorian (fromIntegral v) 1 1)+ go (MySQL.MySQLDate v) = PersistDay v+ go (MySQL.MySQLTime _ v) = PersistTimeOfDay v+ -- Null+ go (MySQL.MySQLNull ) = PersistNull+ -- Conversion using PersistDbSpecific+ go (MySQL.MySQLGeometry v) = PersistLiteral v++----------------------------------------------------------------------+++-- | Create the migration plan for the given 'PersistEntity'+-- @val@.+migrate' :: MySQL.ConnectInfo+ -> [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] [(Bool, Text)])+migrate' connectInfo allDefs getter val = do+ let name = getEntityDBName val+ let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val+ old <- getColumns connectInfo getter val newcols+ let udspair = map udToPair udefs+ case ([], old, partitionEithers old) of+ -- Nothing found, create everything+ ([], [], _) -> do+ let uniques = do+ (uname, ucols) <- udspair+ pure+ $ AlterTable name+ $ AddUniqueConstraint uname+ $ map (findTypeAndMaxLen name) ucols++ let foreigns = do+ Column { cName=cname, cReference=Just cRef } <- newcols+ let refConstraintName = crConstraintName cRef+ let refTblName = crTableName cRef+ let refTarget =+ addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef)++ guard $ Just cname /= fmap fieldDB (getEntityIdField val)+ return $ AlterColumn name refTarget+++ let foreignsAlt =+ map+ (\fdef ->+ let (childfields, parentfields) =+ unzip+ $ map (\((_,b),(_,d)) -> (b,d))+ $ foreignFields fdef+ in+ AlterColumn+ name+ (AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields+ parentfields+ (foreignFieldCascade fdef)+ )+ )+ fdefs++ return+ $ Right+ $ map showAlterDb+ $ (addTable newcols val) : uniques ++ foreigns ++ foreignsAlt++ -- No errors and something found, migrate+ (_, _, ([], old')) -> do+ let excludeForeignKeys (xs,ys) =+ ( map+ (\c ->+ case cReference c of+ Just ColumnReference {crConstraintName=fk} ->+ case find (\f -> fk == foreignConstraintNameDBName f) fdefs of+ Just _ -> c { cReference = Nothing }+ Nothing -> c+ Nothing -> c+ )+ xs+ , ys+ )+ (acs, ats) =+ getAlters+ allDefs+ val+ (newcols, udspair)+ $ excludeForeignKeys+ $ partitionEithers+ $ old'+ acs' =+ map (AlterColumn name) acs+ ats' =+ map (AlterTable name) ats+ return+ $ Right+ $ map showAlterDb+ $ acs' ++ ats'++ -- Errors+ (_, _, (errs, _)) ->+ return $ Left errs++ where+ findTypeAndMaxLen tblName col =+ let (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml)++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 -> 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)+findTypeOfColumn allDefs name col =+ maybe+ (error $ "Could not find type of column " +++ show col ++ " on table " ++ show name +++ " (allDefs = " ++ show allDefs ++ ")"+ )+ ((,) col)+ $ do+ entDef <- find ((== name) . getEntityDBName) allDefs+ fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)+ return (fieldType fieldDef)++-- | Find out the maxlen of a column (default to 200)+findMaxLenOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)+findMaxLenOfColumn allDefs name col =+ maybe (col, 200)+ ((,) col) $ do+ entDef <- find ((== name) . getEntityDBName) allDefs+ fieldDef <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)+ findMaxLenOfField fieldDef++-- | Find out the maxlen of a field+findMaxLenOfField :: FieldDef -> Maybe Integer+findMaxLenOfField fieldDef =+ listToMaybe+ . mapMaybe (\case+ FieldAttrMaxlen x -> Just x+ _ -> Nothing)+ . fieldAttrs+ $ fieldDef++-- | Helper for 'AddReference' that finds out the which primary key columns to reference.+addReference+ :: [EntityDef]+ -- ^ List of all known 'EntityDef's.+ -> ConstraintNameDB+ -- ^ Foreign key name+ -> EntityNameDB+ -- ^ Referenced table name+ -> FieldNameDB+ -- ^ Column name+ -> FieldCascade+ -> AlterColumn+addReference allDefs fkeyname reftable cname fc =+ AddReference reftable fkeyname [cname] referencedColumns fc+ where+ errorMessage =+ error+ $ "Could not find ID of entity " ++ show reftable+ ++ " (allDefs = " ++ show allDefs ++ ")"+ referencedColumns =+ fromMaybe errorMessage $ do+ entDef <- find ((== reftable) . getEntityDBName) allDefs+ return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef++data AlterColumn = Change Column+ | Add' Column+ | Drop Column+ | Default Column String+ | NoDefault Column+ | Gen Column SqlType (Maybe Integer) String+ | NoGen Column SqlType (Maybe Integer)+ | Update' Column String+ -- | See the definition of the 'showAlter' function to see how these fields are used.+ | AddReference+ EntityNameDB -- Referenced table+ ConstraintNameDB -- Foreign key name+ [FieldNameDB] -- Referencing columns+ [FieldNameDB] -- Referenced columns+ FieldCascade+ | DropReference ConstraintNameDB+ deriving Show++data AlterTable = AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType, Integer)]+ | DropUniqueConstraint ConstraintNameDB+ deriving Show++data AlterDB = AddTable String+ | AlterColumn EntityNameDB AlterColumn+ | AlterTable EntityNameDB AlterTable+ deriving Show+++udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)++----------------------------------------------------------------------+++-- | Returns all of the 'Column'@s@ in the given table currently+-- in the database.+getColumns+ :: HasCallStack+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> EntityDef -> [Column]+ -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]+getColumns connectInfo getter def cols = do++ -- Find out all columns.+ stmtClmns <- getter $ T.concat+ [ "SELECT COLUMN_NAME, "+ , "IS_NULLABLE, "+ , "DATA_TYPE, "+ , "COLUMN_TYPE, "+ , "CHARACTER_MAXIMUM_LENGTH, "+ , "NUMERIC_PRECISION, "+ , "NUMERIC_SCALE, "+ , "COLUMN_DEFAULT, "+ , "GENERATION_EXPRESSION "+ , "FROM INFORMATION_SCHEMA.COLUMNS "+ , "WHERE TABLE_SCHEMA = ? "+ , "AND TABLE_NAME = ? "+ -- , "AND COLUMN_NAME <> ?"+ ]+ inter2 <- with (stmtQuery stmtClmns vals) (\src -> runConduitRes $ src .| CL.consume)+ cs <- runConduitRes $ CL.sourceList inter2 .| helperClmns -- avoid nested queries++ -- Find out the constraints.+ stmtCntrs <- getter $ T.concat+ [ "SELECT CONSTRAINT_NAME, "+ , "COLUMN_NAME "+ , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE "+ , "WHERE TABLE_SCHEMA = ? "+ , "AND TABLE_NAME = ? "+ -- , "AND COLUMN_NAME <> ? "+ , "AND CONSTRAINT_NAME <> 'PRIMARY' "+ , "AND REFERENCED_TABLE_SCHEMA IS NULL "+ , "ORDER BY CONSTRAINT_NAME, "+ , "COLUMN_NAME"+ ]+ us <- with (stmtQuery stmtCntrs vals) (\src -> runConduitRes $ src .| helperCntrs)++ -- Return both+ return (cs ++ us)+ where+ refMap = Map.fromList $ foldl ref [] cols+ where ref rs c = case cReference c of+ Nothing -> rs+ (Just r) -> (unFieldNameDB $ cName c, r) : rs+ vals = [ PersistText $ T.decodeUtf8 $ MySQL.ciDatabase connectInfo+ , 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 (getEntityDBName def) row $ ref+ where ref = case row of+ (PersistText cname : _) -> (Map.lookup cname refMap)+ _ -> Nothing++ helperCntrs = do+ let check [ PersistText cntrName+ , PersistText clmnName] = return ( cntrName, clmnName )+ check other = fail $ "helperCntrs: unexpected " ++ show other+ rows <- mapM check =<< CL.consume+ return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd)))+ $ groupBy ((==) `on` fst) rows+++-- | Get the information about a column in a table.+getColumn+ :: HasCallStack+ => MySQL.ConnectInfo+ -> (Text -> IO Statement)+ -> EntityNameDB+ -> [PersistValue]+ -> Maybe ColumnReference+ -> IO (Either Text Column)+getColumn connectInfo getter tname [ PersistText cname+ , PersistText null_+ , PersistText dataType+ , PersistText colType+ , colMaxLen+ , colPrecision+ , colScale+ , default'+ , generated+ ] cRef =+ fmap (either (Left . pack) Right) $+ runExceptT $ do+ -- Default value+ default_ <-+ case default' of+ PersistNull -> return Nothing+ PersistText t -> return (Just t)+ PersistByteString bs ->+ case T.decodeUtf8' bs of+ Left exc ->+ fail+ $ "Invalid default column: "+ ++ show default'+ ++ " (error: " ++ show exc ++ ")"+ Right t ->+ return (Just t)+ _ ->+ fail $ "Invalid default column: " ++ show default'++ generated_ <-+ case generated of+ PersistNull -> return Nothing+ PersistText "" -> return Nothing+ PersistByteString "" -> return Nothing+ PersistText t -> return (Just t)+ PersistByteString bs ->+ case T.decodeUtf8' bs of+ Left exc ->+ fail+ $ "Invalid generated column: "+ ++ show generated+ ++ " (error: " ++ show exc ++ ")"+ Right t ->+ return (Just t)+ _ ->+ fail $ "Invalid generated column: " ++ show generated++ ref <- getRef (crConstraintName <$> cRef)++ let colMaxLen' =+ case colMaxLen of+ PersistInt64 l -> Just (fromIntegral l)+ _ -> Nothing+ ci = ColumnInfo+ { ciColumnType = colType+ , ciMaxLength = colMaxLen'+ , ciNumericPrecision = colPrecision+ , ciNumericScale = colScale+ }++ (typ, maxLen) <- parseColumnType dataType ci++ -- Okay!+ return Column+ { cName = FieldNameDB cname+ , cNull = null_ == "YES"+ , cSqlType = typ+ , cDefault = default_+ , cGenerated = generated_+ , cDefaultConstraintName = Nothing+ , cMaxLen = maxLen+ , cReference = ref+ }+ where+ getRef Nothing = return Nothing+ getRef (Just refName') = do+ -- Foreign key (if any)+ stmt <- lift . getter $ T.concat+ [ "SELECT KCU.REFERENCED_TABLE_NAME, "+ , "KCU.CONSTRAINT_NAME, "+ , "KCU.ORDINAL_POSITION, "+ , "DELETE_RULE, "+ , "UPDATE_RULE "+ , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU "+ , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC "+ , " USING (CONSTRAINT_SCHEMA, CONSTRAINT_NAME) "+ , "WHERE KCU.TABLE_SCHEMA = ? "+ , "AND KCU.TABLE_NAME = ? "+ , "AND KCU.COLUMN_NAME = ? "+ , "AND KCU.REFERENCED_TABLE_SCHEMA = ? "+ , "AND KCU.CONSTRAINT_NAME = ? "+ , "ORDER BY KCU.CONSTRAINT_NAME, "+ , "KCU.COLUMN_NAME"+ ]+ let vars =+ [ PersistText $ T.decodeUtf8 $ MySQL.ciDatabase connectInfo+ , PersistText $ unEntityNameDB tname+ , PersistText cname+ , PersistText $ T.decodeUtf8 $ MySQL.ciDatabase connectInfo+ , PersistText $ unConstraintNameDB refName'+ ]+ parseCascadeAction txt =+ case txt of+ "RESTRICT" -> Just Restrict+ "CASCADE" -> Just Cascade+ "SET NULL" -> Just SetNull+ "SET DEFAULT" -> Just SetDefault+ "NO ACTION" -> Nothing+ _ ->+ error $ "Unexpected value in parseCascadeAction: " <> show txt++ cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume)+ pure $ case cntrs of+ [] ->+ Nothing+ [[PersistText tab, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] ->+ if pos == 1+ then Just $ ColumnReference (EntityNameDB tab) (ConstraintNameDB ref) FieldCascade+ { fcOnUpdate = parseCascadeAction onUpd+ , fcOnDelete = parseCascadeAction onDel+ }+ else Nothing+ xs -> error $ mconcat+ [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: "+ , T.unpack (unEntityNameDB tname)+ , " and column: "+ , T.unpack cname+ , " but got: "+ , show xs+ ]++getColumn _ _ _ x _ =+ return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x++-- | Extra column information from MySQL schema+data ColumnInfo = ColumnInfo+ { ciColumnType :: Text+ , ciMaxLength :: Maybe Integer+ , ciNumericPrecision :: PersistValue+ , ciNumericScale :: PersistValue+ }++-- | Parse the type of column as returned by MySQL's+-- @INFORMATION_SCHEMA@ tables.+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)+parseColumnType "bigint" ci | ciColumnType ci == "bigint(20)" = return (SqlInt64, Nothing)+-- Double+parseColumnType x@("double") ci | ciColumnType ci == x = return (SqlReal, Nothing)+parseColumnType "decimal" ci =+ case (ciNumericPrecision ci, ciNumericScale ci) of+ (PersistInt64 p, PersistInt64 s) ->+ return (SqlNumeric (fromIntegral p) (fromIntegral s), Nothing)+ _ ->+ fail "missing DECIMAL precision in DB schema"+-- Text+parseColumnType "varchar" ci = return (SqlString, ciMaxLength ci)+parseColumnType "text" _ = return (SqlString, Nothing)+-- ByteString+parseColumnType "varbinary" ci = return (SqlBlob, ciMaxLength ci)+parseColumnType "blob" _ = return (SqlBlob, Nothing)+-- Time-related+parseColumnType "time" _ = return (SqlTime, Nothing)+parseColumnType "datetime" _ = return (SqlDayTime, Nothing)+parseColumnType "date" _ = return (SqlDay, Nothing)++parseColumnType _ ci = return (SqlOther (ciColumnType ci), Nothing)+++----------------------------------------------------------------------+++-- | @getAlters allDefs tblName new old@ finds out what needs to+-- be changed from @old@ to become @new@.+getAlters+ :: [EntityDef]+ -> EntityDef+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([AlterColumn], [AlterTable])+getAlters allDefs edef (c1, u1) (c2, u2) =+ (getAltersC c1 c2, getAltersU u1 u2)+ where+ tblName = getEntityDBName edef+ getAltersC [] old = concatMap dropColumn old+ getAltersC (new:news) old =+ let (alters, old') = findAlters edef allDefs new old+ in alters ++ getAltersC news old'++ dropColumn col =+ [DropReference (crConstraintName cr) | Just cr <- [cReference col]] +++ [Drop col]++ getAltersU [] old = map (DropUniqueConstraint . fst) old+ getAltersU ((name, cols):news) old =+ case lookup name old of+ Nothing ->+ AddUniqueConstraint name (map findTypeAndMaxLen cols)+ : getAltersU news old+ Just ocols ->+ let old' = filter (\(x, _) -> x /= name) old+ in if sort cols == ocols+ then getAltersU news old'+ else DropUniqueConstraint name+ : AddUniqueConstraint name (map findTypeAndMaxLen cols)+ : getAltersU news old'+ where+ findTypeAndMaxLen col =+ let (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in+ (col', ty, ml)+++-- | @findAlters x y newColumn oldColumns@ finds out what needs to be+-- changed in the columns @oldColumns@ for @newColumn@ to be+-- supported.+findAlters+ :: EntityDef+ -> [EntityDef]+ -> Column+ -> [Column]+ -> ([AlterColumn], [Column])+findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName maxLen ref) cols =+ case filter ((name ==) . cName) cols of+ -- new fkey that didn't exist before+ [] ->+ case ref of+ Nothing -> ([Add' col],[])+ Just cr ->+ let tname = crTableName cr+ cname = crConstraintName cr+ cnstr = [addReference allDefs cname tname name (crFieldCascade cr)]+ in+ (Add' col : cnstr, cols)+ Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ ->+ let -- Foreign key+ refDrop =+ case (ref == ref', ref') of+ (False, Just ColumnReference {crConstraintName=cname}) ->+ [DropReference cname]+ _ ->+ []+ refAdd =+ case (ref == ref', ref) of+ (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc })+ | tname /= getEntityDBName edef+ , Just idField <- getEntityIdField edef+ , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField)+ ->+ [addReference allDefs cname tname name cfc]+ _ -> []+ -- Type and nullability+ modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = []+ | otherwise = [Change col]++ -- Default value+ -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields+ modDef =+ if def == def' then []+ else case def of+ Nothing -> [NoDefault col]+ Just s ->+ if T.toUpper s == "NULL" then []+ else [Default col $ T.unpack s]++ -- Does the generated value need to change?+ modGen =+ if gen == gen' then []+ else case gen of+ Nothing -> [NoGen col type_ maxLen]+ Just genExpr -> [Gen col type_ maxLen $ T.unpack genExpr]++ in ( refDrop ++ modType ++ modDef ++ modGen ++ refAdd+ , filter ((name /=) . cName) cols+ )++ where+ ciEquals x y = T.toCaseFold (T.pack x) == T.toCaseFold (T.pack y)++----------------------------------------------------------------------+++-- | Prints the part of a @CREATE TABLE@ statement about a given+-- column.+showColumn :: Column -> String+showColumn (Column n nu t def gen _defConstraintName maxLen ref) = concat+ [ escapeF n+ , " "+ , showSqlType t maxLen True+ , " "+ , case gen of+ Nothing -> ""+ Just genExpr ->+ if T.toUpper genExpr == "NULL" then ""+ else " GENERATED ALWAYS AS (" <> T.unpack genExpr <> ") STORED "+ , if nu then "NULL" else "NOT NULL"+ , case def of+ Nothing -> ""+ Just s -> -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields+ if T.toUpper s == "NULL" then ""+ else " DEFAULT " ++ T.unpack s+ , case ref of+ Nothing -> ""+ Just cRef -> " REFERENCES " ++ escapeE (crTableName cRef)+ <> " " <> T.unpack (renderFieldCascade (crFieldCascade cRef))+ ]+++-- | Renders an 'SqlType' in MySQL's format.+showSqlType :: SqlType+ -> Maybe Integer -- ^ @maxlen@+ -> Bool -- ^ include character set information?+ -> String+showSqlType SqlBlob Nothing _ = "BLOB"+showSqlType SqlBlob (Just i) _ = "VARBINARY(" ++ show i ++ ")"+showSqlType SqlBool _ _ = "TINYINT(1)"+showSqlType SqlDay _ _ = "DATE"+showSqlType SqlDayTime _ _ = "DATETIME"+showSqlType SqlInt32 _ _ = "INT(11)"+showSqlType SqlInt64 _ _ = "BIGINT"+showSqlType SqlReal _ _ = "DOUBLE"+showSqlType (SqlNumeric s prec) _ _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")"+showSqlType SqlString Nothing True = "TEXT CHARACTER SET utf8mb4"+showSqlType SqlString Nothing False = "TEXT"+showSqlType SqlString (Just i) True = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8mb4"+showSqlType SqlString (Just i) False = "VARCHAR(" ++ show i ++ ")"+showSqlType SqlTime _ _ = "TIME"+showSqlType (SqlOther t) _ _ = T.unpack t++-- | Render an action that must be done on the database.+showAlterDb :: AlterDB -> (Bool, Text)+showAlterDb (AddTable s) = (False, pack s)+showAlterDb (AlterColumn t ac) =+ (isUnsafe ac, pack $ showAlter t ac)+ where+ isUnsafe Drop{} = True+ isUnsafe _ = False+showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at)+++-- | Render an action that must be done on a table.+showAlterTable :: EntityNameDB -> AlterTable -> String+showAlterTable table (AddUniqueConstraint cname cols) = concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD CONSTRAINT "+ , escapeC cname+ , " UNIQUE("+ , intercalate "," $ map escapeDBName' cols+ , ")"+ ]+ where+ escapeDBName' (name, (FTTypeCon _ "Text" ), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, (FTTypeCon _ "String" ), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, (FTTypeCon _ "ByteString"), maxlen) = escapeF name ++ "(" ++ show maxlen ++ ")"+ escapeDBName' (name, _ , _) = escapeF name+showAlterTable table (DropUniqueConstraint cname) = concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP INDEX "+ , escapeC cname+ ]+++-- | Render an action that must be done on a column.+showAlter :: EntityNameDB -> AlterColumn -> String+showAlter table (Change (Column n nu t def gen defConstraintName maxLen _ref)) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " CHANGE "+ , escapeF n+ , " "+ , showColumn (Column n nu t def gen defConstraintName maxLen Nothing)+ ]+showAlter table (Add' col) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD COLUMN "+ , showColumn col+ ]+showAlter table (Drop c) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP COLUMN "+ , escapeF (cName c)+ ]+showAlter table (Default c s) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ALTER COLUMN "+ , escapeF (cName c)+ , " SET DEFAULT "+ , s+ ]+showAlter table (NoDefault c) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " ALTER COLUMN "+ , escapeF (cName c)+ , " DROP DEFAULT"+ ]+showAlter table (Gen col typ len expr) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " MODIFY COLUMN "+ , escapeF (cName col)+ , " "+ , showSqlType typ len True+ , " GENERATED ALWAYS AS ("+ , expr+ , ") STORED"+ ]+showAlter table (NoGen col typ len) =+ concat+ [ "ALTER TABLE "+ , escapeE table+ , " MODIFY COLUMN "+ , escapeF (cName col)+ , " "+ , showSqlType typ len True+ ]+showAlter table (Update' c s) =+ concat+ [ "UPDATE "+ , escapeE table+ , " SET "+ , escapeF (cName c)+ , "="+ , s+ , " WHERE "+ , escapeF (cName c)+ , " IS NULL"+ ]+showAlter table (AddReference reftable fkeyname t2 id2 fc) = concat+ [ "ALTER TABLE "+ , escapeE table+ , " ADD CONSTRAINT "+ , escapeC fkeyname+ , " FOREIGN KEY("+ , intercalate "," $ map escapeF t2+ , ") REFERENCES "+ , escapeE reftable+ , "("+ , intercalate "," $ map escapeF id2+ , ") "+ , T.unpack $ renderFieldCascade fc+ ]+showAlter table (DropReference cname) = concat+ [ "ALTER TABLE "+ , escapeE table+ , " DROP FOREIGN KEY "+ , escapeC cname+ ]++----------------------------------------------------------------------++escapeC :: ConstraintNameDB -> String+escapeC = escapeWith (escapeDBName . T.unpack)++escapeE :: EntityNameDB -> String+escapeE = escapeWith (escapeDBName . T.unpack)++escapeF :: FieldNameDB -> String+escapeF = escapeWith (escapeDBName . T.unpack)++escapeET :: EntityNameDB -> Text+escapeET = escapeWith (T.pack . escapeDBName . T.unpack)++escapeFT :: FieldNameDB -> Text+escapeFT = escapeWith (T.pack . escapeDBName . T.unpack)++-- | Escape a database name to be included on a query.+escapeDBName :: String -> String+escapeDBName str = '`' : go str+ where+ go ('`':xs) = '`' : '`' : go xs+ go ( x :xs) = x : go xs+ go "" = "`"++-- | Information required to connect to a MySQL database+-- using @persistent@'s generic facilities. These values are the+-- same that are given to 'withMySQLPool'.+data MySQLConf = MySQLConf+ MySQLConnectInfo+ Int+ deriving Show++-- | Extract connection configs from 'MySQLConf'+-- @since 0.4.1+myConnInfo :: MySQLConf -> MySQLConnectInfo+myConnInfo (MySQLConf c _) = c++-- | Extract connection pool size from 'MySQLConf'+-- @since 0.4.1+myPoolSize :: MySQLConf -> Int+myPoolSize (MySQLConf _ p) = p++setMyConnInfo :: MySQLConnectInfo -> MySQLConf -> MySQLConf+setMyConnInfo c (MySQLConf _ p) = MySQLConf c p++-- | Public constructor for @MySQLConf@.+mkMySQLConf+ :: MySQLConnectInfo -- ^ The connection information.+ -> Int -- ^ How many connections should be held on the connection pool.+ -> MySQLConf+mkMySQLConf = MySQLConf++-- | MySQL connection information.+data MySQLConnectInfo = MySQLConnectInfo+ { innerConnInfo :: MySQL.ConnectInfo+ , innerConnTLS :: (Maybe TLS.ClientParams)+ } deriving Show++-- | Public constructor for @MySQLConnectInfo@.+mkMySQLConnectInfo+ :: NetworkSocket.HostName -- ^ hostname+ -> BSC.ByteString -- ^ username+ -> BSC.ByteString -- ^ password+ -> BSC.ByteString -- ^ database+ -> MySQLConnectInfo+mkMySQLConnectInfo host user pass db+ = MySQLConnectInfo innerCi Nothing+ where+ innerCi = MySQL.defaultConnectInfo {+ MySQL.ciHost = host+ , MySQL.ciUser = user+ , MySQL.ciPassword = pass+ , MySQL.ciDatabase = db+ }++-- | Update port number for @MySQLConnectInfo@.+setMySQLConnectInfoPort+ :: NetworkSocket.PortNumber -> MySQLConnectInfo -> MySQLConnectInfo+setMySQLConnectInfoPort port ci+ = ci {innerConnInfo = innerCi { MySQL.ciPort = port } }+ where innerCi = innerConnInfo ci++-- | Update character set for @MySQLConnectInfo@.+setMySQLConnectInfoCharset+ :: Word.Word8 -- ^ Numeric ID of collation. See https://dev.mysql.com/doc/refman/5.7/en/show-collation.html.+ -> MySQLConnectInfo -- ^ Reference connectInfo to perform update on+ -> MySQLConnectInfo+setMySQLConnectInfoCharset charset ci+ = ci {innerConnInfo = innerCi { MySQL.ciCharset = charset } }+ where innerCi = innerConnInfo ci++-- | Set TLS ClientParams for @MySQLConnectInfo@.+setMySQLConnectInfoTLS+ :: TLS.ClientParams -- ^ @ClientParams@ to establish a TLS connection with.+ -> MySQLConnectInfo -- ^ Reference connectInfo to perform update on+ -> MySQLConnectInfo+setMySQLConnectInfoTLS tls ci+ = ci {innerConnTLS = Just tls}++instance FromJSON MySQLConf where+ parseJSON v = modifyFailure ("Persistent: error loading MySQL conf: " ++) $+ flip (withObject "MySQLConf") v $ \o -> do+ database <- o .: "database"+ host <- o .: "host"+ port <- o .: "port"+ user <- o .: "user"+ password <- o .: "password"+ pool <- o .: "poolsize"+ let ci = MySQL.defaultConnectInfo+ { MySQL.ciHost = host+ , MySQL.ciPort = fromIntegral (port :: Word)+ , MySQL.ciUser = BSC.pack user+ , MySQL.ciPassword = BSC.pack password+ , MySQL.ciDatabase = BSC.pack database+ }+ return $ MySQLConf (MySQLConnectInfo ci Nothing) pool++instance PersistConfig MySQLConf where+ type PersistConfigBackend MySQLConf = SqlPersistT++ type PersistConfigPool MySQLConf = ConnectionPool++ createPoolConfig (MySQLConf cs size)+ = runNoLoggingT $ createMySQLPool cs size -- FIXME++ runPool _ = runSqlPool++ loadConfig = parseJSON++ applyEnv conf = do+ env <- getEnvironment+ let maybeEnv old var = maybe old id $ fmap BSC.pack $ lookup ("MYSQL_" ++ var) env+ let innerCi = innerConnInfo . myConnInfo $ conf+ let innerCiNew = case innerCi of+ MySQL.ConnectInfo+ { MySQL.ciHost = host+ , MySQL.ciPort = port+ , MySQL.ciUser = user+ , MySQL.ciPassword = password+ , MySQL.ciDatabase = database+ } -> (innerCi)+ { MySQL.ciHost = BSC.unpack $ maybeEnv (BSC.pack host) "HOST"+ , MySQL.ciPort = read (BSC.unpack $ maybeEnv (BSC.pack $ show port) "PORT")+ , MySQL.ciUser = maybeEnv user "USER"+ , MySQL.ciPassword = maybeEnv password "PASSWORD"+ , MySQL.ciDatabase = maybeEnv database "DATABASE"+ }+ return $ setMyConnInfo (MySQLConnectInfo innerCiNew Nothing) conf++mockMigrate :: MySQL.ConnectInfo+ -> [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] [(Bool, Text)])+mockMigrate _connectInfo allDefs _getter val = do+ let name = getEntityDBName val+ let (newcols, udefs, fdefs) = mysqlMkColumns allDefs val+ let udspair = map udToPair udefs+ case () of+ -- Nothing found, create everything+ () -> do+ let uniques = flip concatMap udspair $ \(uname, ucols) ->+ [ AlterTable name $+ AddUniqueConstraint uname $+ map (findTypeAndMaxLen name) ucols ]+ let foreigns = do+ Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols+ return $ AlterColumn name (addReference allDefs refConstr refTable cname cfc)++ let foreignsAlt =+ map+ (\fdef ->+ let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))+ in+ AlterColumn+ name+ (AddReference+ (foreignRefTableDBName fdef)+ (foreignConstraintNameDBName fdef)+ childfields+ parentfields+ (foreignFieldCascade fdef)+ )+ )+ fdefs++ return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt++ where+ findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in (col', ty, ml)+++-- | Mock a migration even when the database is not present.+-- This function will mock the migration for a database even when+-- the actual database isn't already present in the system.+mockMigration :: Migration -> IO ()+mockMigration mig = do+ smap <- newIORef $ Map.empty+ let sqlbackend =+ mkSqlBackend SqlBackend.MkSqlBackendArgs+ { SqlBackend.connPrepare = \_ -> do+ return Statement+ { stmtFinalize = return ()+ , stmtReset = return ()+ , stmtExecute = undefined+ , stmtQuery = \_ -> return $ return ()+ }+ , SqlBackend.connInsertSql = undefined+ , SqlBackend.connStmtMap = smap+ , SqlBackend.connClose = undefined+ , SqlBackend.connMigrateSql = mockMigrate undefined+ , SqlBackend.connBegin = undefined+ , SqlBackend.connCommit = undefined+ , SqlBackend.connRollback = undefined+ , SqlBackend.connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB+ , SqlBackend.connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . getEntityDBName+ , SqlBackend.connEscapeRawName = T.pack . escapeDBName . T.unpack+ , SqlBackend.connNoLimit = undefined+ , SqlBackend.connRDBMS = undefined+ , SqlBackend.connLimitOffset = undefined+ , SqlBackend.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+-- record already exists in the database, the record will have the+-- relevant updates performed.+insertOnDuplicateKeyUpdate+ :: ( backend ~ PersistEntityBackend record+ , PersistEntity record+ , MonadIO m+ , PersistStore backend+ , BackendCompatible SqlBackend backend+ )+ => record+ -> [Update record]+ -> ReaderT backend m ()+insertOnDuplicateKeyUpdate record =+ insertManyOnDuplicateKeyUpdate [record] []++-- | Combination of 'insertOnDuplicateKeyUpdate' and 'insertKey'.+-- @since 5.1.0+insertEntityOnDuplicateKeyUpdate+ :: ( backend ~ PersistEntityBackend record+ , PersistEntity record+ , MonadIO m+ , PersistStore backend+ , BackendCompatible SqlBackend backend+ )+ => Entity record+ -> [Update record]+ -> ReaderT backend m ()+insertEntityOnDuplicateKeyUpdate entity =+ insertEntityManyOnDuplicateKeyUpdate [entity] []+++-- | This type is used to determine how to update rows using MySQL's+-- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via+-- 'insertManyOnDuplicateKeyUpdate' in this library.+--+-- @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++-- | Copy the field into the database only if the value in the+-- corresponding record is non-@NULL@.+--+-- @since 2.6.2+copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record+copyUnlessNull field = CopyUnlessEq field Nothing++-- | Copy the field into the database only if the value in the+-- corresponding record is non-empty, where "empty" means the Monoid+-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc.+--+-- The resulting 'HandleUpdateCollision' type is useful for the+-- 'insertManyOnDuplicateKeyUpdate' function.+--+-- @since 2.6.2+copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record+copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty++-- | Copy the field into the database only if the field is not equal to the+-- provided value. This is useful to avoid copying weird nullary data into+-- the database.+--+-- The resulting 'HandleUpdateCollision' type is useful for the+-- 'insertManyOnDuplicateKeyUpdate' function.+--+-- @since 2.6.2+copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record+copyUnlessEq = CopyUnlessEq++-- | Copy the field directly from the record.+--+-- @since 3.0+copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record+copyField = CopyField++-- | Do a bulk insert on the given records in the first parameter. In the event+-- that a key conflicts with a record currently in the database, the second and+-- third parameters determine what will happen.+--+-- The second parameter is a list of fields to copy from the original value.+-- This allows you to specify which fields to copy from the record you're trying+-- to insert into the database to the preexisting row.+--+-- The third parameter is a list of updates to perform that are independent of+-- the value that is provided. You can use this to increment a counter value.+-- These updates only occur if the original record is present in the database.+--+-- === __More details on 'HandleUpdateCollision' usage__+--+-- The @['HandleUpdateCollision']@ parameter allows you to specify which fields (and+-- under which conditions) will be copied from the inserted rows. For+-- a brief example, consider the following data model and existing data set:+--+-- @+-- Item+-- name Text+-- description Text+-- price Double Maybe+-- quantity Int Maybe+--+-- Primary name+-- @+--+-- > items:+-- > +------+-------------+-------+----------++-- > | name | description | price | quantity |+-- > +------+-------------+-------+----------++-- > | foo | very good | | 3 |+-- > | bar | | 3.99 | |+-- > +------+-------------+-------+----------++--+-- This record type has a single natural key on @itemName@. Let's suppose+-- that we download a CSV of new items to store into the database. Here's+-- our CSV:+--+-- > name,description,price,quantity+-- > foo,,2.50,6+-- > bar,even better,,5+-- > yes,wow,,+--+-- We parse that into a list of Haskell records:+--+-- @+-- records =+-- [ Item { itemName = "foo", itemDescription = ""+-- , itemPrice = Just 2.50, itemQuantity = Just 6+-- }+-- , Item "bar" "even better" Nothing (Just 5)+-- , Item "yes" "wow" Nothing Nothing+-- ]+-- @+--+-- The new CSV data is partial. It only includes __updates__ from the+-- upstream vendor. Our CSV library parses the missing description field as+-- an empty string. We don't want to override the existing description. So+-- we can use the 'copyUnlessEmpty' function to say: "Don't update when the+-- value is empty."+--+-- Likewise, the new row for @bar@ includes a quantity, but no price. We do+-- not want to overwrite the existing price in the database with a @NULL@+-- value. So we can use 'copyUnlessNull' to only copy the existing values+-- in.+--+-- The final code looks like this:+-- @+-- 'insertManyOnDuplicateKeyUpdate' records+-- [ 'copyUnlessEmpty' ItemDescription+-- , 'copyUnlessNull' ItemPrice+-- , 'copyUnlessNull' ItemQuantity+-- ]+-- []+-- @+--+-- Once we run that code on the database, the new data set looks like this:+--+-- > items:+-- > +------+-------------+-------+----------++-- > | name | description | price | quantity |+-- > +------+-------------+-------+----------++-- > | foo | very good | 2.50 | 6 |+-- > | bar | even better | 3.99 | 5 |+-- > | yes | wow | | |+-- > +------+-------------+-------+----------++insertManyOnDuplicateKeyUpdate+ :: forall record backend m.+ ( backend ~ PersistEntityBackend record+ , BackendCompatible SqlBackend backend+ , PersistEntity record+ , MonadIO m+ )+ => [record] -- ^ A list of the records you want to insert, or update+ -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.+ -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.+ -> ReaderT backend m ()+insertManyOnDuplicateKeyUpdate [] _ _ = return ()+insertManyOnDuplicateKeyUpdate records fieldValues updates =+ uncurry rawExecute+ $ mkBulkInsertQuery (Left records) fieldValues updates++-- | Combination of 'insertManyOnDuplicateKeyUpdate' and 'insertEntityMany'+-- @since 5.1.0+insertEntityManyOnDuplicateKeyUpdate+ :: forall record backend m.+ ( backend ~ PersistEntityBackend record+ , BackendCompatible SqlBackend backend+ , PersistEntity record+ , MonadIO m+ )+ => [Entity record] -- ^ A list of the records you want to insert, or update+ -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.+ -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.+ -> ReaderT backend m ()+insertEntityManyOnDuplicateKeyUpdate [] _ _ = return ()+insertEntityManyOnDuplicateKeyUpdate entities fieldValues updates =+ uncurry rawExecute+ $ mkBulkInsertQuery (Right entities) fieldValues updates+++-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you+-- provide an empty list of updates to perform, then it will generate+-- a dummy/no-op update using the first field of the record. This avoids+-- duplicate key exceptions.+mkBulkInsertQuery+ :: PersistEntity record+ => Either [record] [Entity record] -- ^ A list of the records you want to insert, or update, possibly with keys+ -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.+ -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.+ -> (Text, [PersistValue])+mkBulkInsertQuery records fieldValues updates =+ (q, recordValues <> updsValues <> copyUnlessValues)+ where+ mfieldDef x = case x of+ CopyField rec -> Right (fieldDbToText (persistFieldDef rec))+ CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val)+ (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues+ fieldDbToText = T.pack . escapeF . fieldDB+ entityDef' = entityDef $ either id (map entityVal) records+ firstField = case entityFieldNames of+ [] -> error "The entity you're trying to insert does not have any fields."+ (field:_) -> field+ entityFieldNames = map fieldDbToText $ case records of+ Left _ -> getEntityFieldsDatabase entityDef'+ Right _ -> NEL.toList (keyAndEntityFields entityDef')+ tableName = T.pack . escapeE . getEntityDBName $ entityDef'+ copyUnlessValues = map snd fieldsToMaybeCopy+ values = either (map $ map toPersistValue . toPersistFields) (map entityValues) records+ recordValues = concat values+ recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?")) values+ mkCondFieldSet n _ = T.concat+ [ n+ , "=COALESCE("+ , "NULLIF("+ , "VALUES(", n, "),"+ , "?"+ , "),"+ , n+ , ")"+ ]+ condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy+ fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames+ upds = map (Util.mkUpdateText' (pack . escapeF) id) updates+ updsValues = map (\(Update _ val _) -> toPersistValue val) updates+ updateText = case fieldSets <> upds <> condFieldSets of+ [] -> T.concat [firstField, "=", firstField]+ xs -> Util.commaSeparated xs+ q = T.concat+ [ "INSERT INTO "+ , tableName+ , " ("+ , Util.commaSeparated entityFieldNames+ , ") "+ , " VALUES "+ , recordPlaceholders+ , " ON DUPLICATE KEY UPDATE "+ , updateText+ ]++putManySql :: EntityDef -> Int -> Text+putManySql ent n = putManySql' fields ent n+ where+ fields = getEntityFields ent++repsertManySql :: EntityDef -> Int -> Text+repsertManySql ent n = putManySql' fields ent n+ where+ fields = NEL.toList $ keyAndEntityFields ent++putManySql' :: [FieldDef] -> EntityDef -> Int -> Text+putManySql' (filter isFieldNotGenerated -> fields) ent n = q+ where+ fieldDbToText = (T.pack . escapeF) . fieldDB+ mkAssignment f = T.concat [f, "=VALUES(", f, ")"]++ table = (T.pack . escapeE) . getEntityDBName $ ent+ columns = Util.commaSeparated $ map fieldDbToText fields+ placeholders = map (const "?") fields+ updates = map (mkAssignment . fieldDbToText) fields++ q = T.concat+ [ "INSERT INTO "+ , table+ , Util.parenWrapped columns+ , " VALUES "+ , Util.commaSeparated . replicate n+ . Util.parenWrapped . Util.commaSeparated $ placeholders+ , " ON DUPLICATE KEY UPDATE "+ , Util.commaSeparated updates+ ]++mysqlMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])+mysqlMkColumns allDefs t = mkColumns allDefs t emptyBackendSpecificOverrides
+ test/CustomConstraintTest.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++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++CustomConstraint3+ -- | This will lead to a constraint with the name custom_constraint3_cc_id1_fkey+ cc_id1 CustomConstraint1Id+ cc_id2 CustomConstraint1Id+ deriving Show+|]++clean :: MonadUnliftIO m => SqlPersistT m ()+clean = do+ rawExecute "drop table custom_constraint3" []+ rawExecute "drop table custom_constraint2" []+ rawExecute "drop table custom_constraint1" []++specs :: (MonadUnliftIO m, MonadFail m) => RunDb SqlBackend m -> Spec+specs runDb = do+ describe "custom constraint used in migration" $ before_ (runDb $ void $ runMigrationSilent customConstraintMigrate) $ after_ (runDb clean) $ do++ it "custom constraint is actually created" $ runDb $ do+ void $ runMigrationSilent 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)++ it "allows multiple constraints on a single column" $ runDb $ do+ -- Here we add another foreign key on the same column where the+ -- default one already exists. In practice, this could be+ -- a compound key with another field.+ rawExecute "ALTER TABLE custom_constraint3 ADD CONSTRAINT extra_constraint FOREIGN KEY(cc_id1) REFERENCES custom_constraint1(id)" []+ -- This is where the error is thrown in `getColumn`+ _ <- getMigration customConstraintMigrate+ pure ()
+ 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/InsertDuplicateUpdate.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE PartialTypeSignatures #-}++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++|]++specs :: Spec+specs = describe "DuplicateKeyUpdate" $ do+ let item1 = Item "item1" "" (Just 3) Nothing+ item2 = Item "item2" "hello world" Nothing (Just 2)+ items = [item1, item2]+ 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])+-- insertEntityOnDuplicateKeyUpdate (Entity ("item1") 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"+ key <- insert item1+ insertEntityOnDuplicateKeyUpdate+ (Entity (key :: _) (Item "item1" "i am inserted description" (Just 1) (Just 2)))+ [ItemDescription =. newDescription]+ Just item <- get (ItemKey "item1")+ item @== item1 { itemDescription = newDescription }++ 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+ let postUpdate = map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ insertManyOnDuplicateKeyUpdate+ items+ []+ [ItemQuantity +=. Just 1]+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort postUpdate+ 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)
+ test/MyInit.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++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+ , 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(..)+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , arbText+ , liftA2+ , LoggingT, ResourceT, UUID(..)+ ) where++import Init+ ( 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 (forM_, liftM, replicateM, void, when)+import Control.Monad.Trans.Reader+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, assertBool, assertFailure, (@=?), (@?=))++import Control.Monad (unless, (>=>))+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++_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++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
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-unused-top-binds #-}++import MyInit++import qualified Data.ByteString as BS+import Data.Fixed+import Data.IntMap (IntMap)+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+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 MaybeFieldDefsTest+import qualified MigrationColumnLengthTest+import qualified MigrationIdempotencyTest+import qualified MigrationOnlyTest+import qualified MpsCustomPrefixTest+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++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 :: (HasCallStack, MonadUnliftIO m) => Migration -> ReaderT SqlBackend m ()+setup migration = do+ printMigration migration+ _ <- runMigrationUnsafe migration+ pure ()++main :: IO ()+main = do+ runConn $ do+ mapM_ setup+ [ PersistentTest.testMigrate+ , PersistentTest.noPrefixMigrate+ , PersistentTest.customPrefixMigrate+ , EmbedTest.embedMigrate+ , EmbedOrderTest.embedOrderMigrate+ , LargeNumberTest.numberMigrate+ , UniqueTest.uniqueMigrate+ , MaxLenTest.maxlenMigrate+ , MaybeFieldDefsTest.maybeFieldDefMigrate+ , 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+ 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+ MaybeFieldDefsTest.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++ 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++roundTime :: TimeOfDay -> TimeOfDay+roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t++roundUTCTime :: UTCTime -> UTCTime+roundUTCTime t =+ posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t