diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,170 @@ +# persistent-mysql-pure + +[![hackage version](https://img.shields.io/hackage/v/persistent-mysql-pure.svg)](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 + ``` diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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] diff --git a/persistent-mysql-pure.cabal b/persistent-mysql-pure.cabal new file mode 100644 --- /dev/null +++ b/persistent-mysql-pure.cabal @@ -0,0 +1,113 @@ +cabal-version: 2.2 +name: persistent-mysql-pure +version: 1.0.0 +license: MIT +license-file: LICENSE +author: + Naushadh , Felipe Lessa , Michael Snoyman + +maintainer: Jappie +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 diff --git a/src/Database/Persist/MySQL.hs b/src/Database/Persist/MySQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/MySQL.hs @@ -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 + -- + , 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 diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs new file mode 100644 --- /dev/null +++ b/test/CustomConstraintTest.hs @@ -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 () diff --git a/test/ImplicitUuidSpec.hs b/test/ImplicitUuidSpec.hs new file mode 100644 --- /dev/null +++ b/test/ImplicitUuidSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ImplicitUuidSpec where + +import MyInit + +import Data.Proxy +import Database.Persist.MySQL + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +share + [ mkPersist (sqlSettingsUuid "UUID()") + , mkEntityDefList "entities" + ] + [persistLowerCase| + +WithDefUuid + name Text + + deriving Eq Show Ord + +|] + +implicitUuidMigrate :: Migration +implicitUuidMigrate = do + migrateModels entities + +wipe :: IO () +wipe = db $ do + rawExecute "DROP TABLE IF EXISTS with_def_uuid;" [] + void $ runMigrationSilent implicitUuidMigrate + +itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb msg action = it msg $ db $ void action + +pass :: IO () +pass = pure () + +spec :: Spec +spec = describe "ImplicitUuidSpec" $ before_ wipe $ do + describe "WithDefUuidKey" $ do + it "works on UUIDs" $ do + let withDefUuidKey = WithDefUuidKey (UUID "Hello") + pass + describe "getEntityId" $ do + let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) + it "has a SqlString SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlString + it "is an implicit ID column" $ asIO $ do + fieldIsImplicitIdColumn idField `shouldBe` True + + describe "insert" $ do + itDb "successfully has a default" $ do + let matt = WithDefUuid + { withDefUuidName = + "Matt" + } + k <- insert matt + mrec <- get k + uuids <- selectList @WithDefUuid [] [] + liftIO $ do + -- MySQL's insert functionality is currently broken. The @k@ + -- here is derived from @SELECT LAST_INSERT_ID()@ which only + -- works on auto incrementing IDs. + -- + -- See #1251 for more details. + mrec `shouldBe` Nothing + + map entityVal uuids `shouldSatisfy` (matt `elem`) diff --git a/test/InsertDuplicateUpdate.hs b/test/InsertDuplicateUpdate.hs new file mode 100644 --- /dev/null +++ b/test/InsertDuplicateUpdate.hs @@ -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) diff --git a/test/MyInit.hs b/test/MyInit.hs new file mode 100644 --- /dev/null +++ b/test/MyInit.hs @@ -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 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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