diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,16 @@ +## 0.3.3 +- Port from `mysql-haskell`: MySQL on duplicate key update [#674](https://github.com/yesodweb/persistent/pull/674). + +## 0.3.2.1 +- Port from `mysql-haskell`: 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. diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -1,8 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -- | A MySQL backend for @persistent@. module Database.Persist.MySQL @@ -17,6 +17,9 @@ , MySQLConf , mkMySQLConf , mockMigration + , insertOnDuplicateKeyUpdate + , insertManyOnDuplicateKeyUpdate + , SomeField(..) -- * TLS configuration , setMySQLConnectInfoTLS , MySQLTLS.TrustedCAStore(..) @@ -56,6 +59,7 @@ import Database.Persist.Sql import Database.Persist.Sql.Types.Internal (mkPersistBackend) +import Database.Persist.MySQLConnectInfoShowInstance () import Data.Int (Int64) import qualified Database.MySQL.Base as MySQL @@ -479,7 +483,7 @@ stmtIdClmn <- getter "SELECT COLUMN_NAME, \ \IS_NULLABLE, \ \DATA_TYPE, \ - \IF(IS_NULLABLE='YES', COALESCE(COLUMN_DEFAULT, 'NULL'), COLUMN_DEFAULT) \ + \COLUMN_DEFAULT \ \FROM INFORMATION_SCHEMA.COLUMNS \ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ @@ -495,7 +499,7 @@ \CHARACTER_MAXIMUM_LENGTH, \ \NUMERIC_PRECISION, \ \NUMERIC_SCALE, \ - \IF(IS_NULLABLE='YES', COALESCE(COLUMN_DEFAULT, 'NULL'), COLUMN_DEFAULT) \ + \COLUMN_DEFAULT \ \FROM INFORMATION_SCHEMA.COLUMNS \ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ @@ -713,10 +717,12 @@ modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] | otherwise = [(name, Change col)] -- Default value + -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields modDef | def == def' = [] | otherwise = case def of Nothing -> [(name, NoDefault)] - Just s -> [(name, Default $ T.unpack s)] + Just s -> if T.toUpper s == "NULL" then [] + else [(name, Default $ T.unpack s)] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) @@ -737,7 +743,9 @@ , if nu then "NULL" else "NOT NULL" , case def of Nothing -> "" - Just s -> " DEFAULT " ++ T.unpack s + 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 (s, _) -> " REFERENCES " ++ escapeDBName s @@ -893,12 +901,16 @@ -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withMySQLPool'. data MySQLConf = MySQLConf - { myConnInfo :: MySQLConnectInfo - -- ^ The connection information. - , myPoolSize :: Int - -- ^ How many connections should be held on the connection pool. - } deriving Show + MySQLConnectInfo -- ^ The connection information. + Int -- ^ How many connections should be held on the connection pool. + deriving Show +myConnInfo :: MySQLConf -> MySQLConnectInfo +myConnInfo (MySQLConf c _) = c + +setMyConnInfo :: MySQLConnectInfo -> MySQLConf -> MySQLConf +setMyConnInfo c (MySQLConf _ p) = MySQLConf c p + -- | Public constructor for @MySQLConf@. mkMySQLConf :: MySQLConnectInfo -- ^ The connection information. @@ -953,9 +965,6 @@ setMySQLConnectInfoTLS tls ci = ci {innerConnTLS = Just tls} --- TODO: submit a PR to mysql-haskell to add SHOW instance -deriving instance Show MySQL.ConnectInfo - instance FromJSON MySQLConf where parseJSON v = modifyFailure ("Persistent: error loading MySQL conf: " ++) $ flip (withObject "MySQLConf") v $ \o -> do @@ -1004,7 +1013,7 @@ , MySQL.ciPassword = maybeEnv password "PASSWORD" , MySQL.ciDatabase = maybeEnv database "DATABASE" } - return conf { myConnInfo = MySQLConnectInfo innerCiNew Nothing } + return $ setMyConnInfo (MySQLConnectInfo innerCiNew Nothing) conf mockMigrate :: MySQL.ConnectInfo -> [EntityDef] @@ -1080,6 +1089,116 @@ connLogFunc = undefined, connUpsertSql = undefined, connMaxParams = Nothing} - result = runReaderT . runWriterT . runWriterT $ mig + 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. +insertOnDuplicateKeyUpdate + :: ( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record + , MonadIO m + , PersistStore backend + , backend ~ SqlBackend + ) + => record + -> [Update record] + -> SqlPersistT m () +insertOnDuplicateKeyUpdate record = + insertManyOnDuplicateKeyUpdate [record] [] + +-- | This wraps values of an Entity's 'EntityField', making them have the same +-- type. This allows them to be put in lists. +data SomeField record where + SomeField :: EntityField record typ -> SomeField record + +-- | 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 that, when a collision occurs, you'll just update +-- the value in the database with the field values that you inserted. +-- +-- 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. +-- +-- Example: +-- > insertManyOnDuplicateKeyUpdate +-- [ {- a big ol' list of records you want to insert/update -} ] +-- [ SomeField UserName, SomeField UserEmail ] -- this copies the values that are being inserted to existing records +-- [ UserModified =. now, UserEncounted +=. 1 ] -- this update is performed for any field that matches the inserted records +insertManyOnDuplicateKeyUpdate + :: ( PersistEntityBackend record ~ SqlBackend + , PersistEntity record + , MonadIO m + ) + => [record] -- ^ A list of the records you want to insert, or update + -> [SomeField 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. + -> SqlPersistT m () +insertManyOnDuplicateKeyUpdate [] _ _ = return () +insertManyOnDuplicateKeyUpdate records [] [] = insertMany_ records +insertManyOnDuplicateKeyUpdate records fieldValues updates = + uncurry rawExecute $ mkBulkInsertQuery records fieldValues updates + +-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. It will give +-- garbage results if you don't provide a list of either fields to copy or +-- fields to update. +mkBulkInsertQuery + :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) + => [record] -- ^ A list of the records you want to insert, or update + -> [SomeField 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) + where + fieldDefs = map (\x -> case x of SomeField rec -> persistFieldDef rec) fieldValues + updateFieldNames = map (T.pack . escapeDBName . fieldDB) fieldDefs + entityDef' = entityDef records + entityFieldNames = map (T.pack . escapeDBName . fieldDB) (entityFields entityDef') + tableName = T.pack . escapeDBName . entityDB $ entityDef' + recordValues = concatMap (map toPersistValue . toPersistFields) records + recordPlaceholders = commaSeparated $ map (parenWrapped . commaSeparated . map (const "?") . toPersistFields) records + fieldSets = map (\n -> T.concat [n, "=VALUES(", n, ")"]) updateFieldNames + upds = map mkUpdateText updates + updsValues = map (\(Update _ val _) -> toPersistValue val) updates + q = T.concat + [ "INSERT INTO " + , tableName + , " (" + , commaSeparated entityFieldNames + , ") " + , " VALUES " + , recordPlaceholders + , " ON DUPLICATE KEY UPDATE " + , commaSeparated (fieldSets <> upds) + ] + +-- | Vendored from @persistent@. +mkUpdateText :: PersistEntity record => Update record -> Text +mkUpdateText x = + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=", n, "+?"] + Subtract -> T.concat [n, "=", n, "-?"] + Multiply -> T.concat [n, "=", n, "*?"] + Divide -> T.concat [n, "=", n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ "BackendSpecificUpdate " <> up <> " not supported" + where + n = T.pack . escapeDBName . fieldDB . updateFieldDef $ x + +commaSeparated :: [Text] -> Text +commaSeparated = T.intercalate ", " + +parenWrapped :: Text -> Text +parenWrapped t = T.concat ["(", t, ")"] + +-- | Gets the 'FieldDef' for an 'Update'. Vendored from @persistent@. +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f +updateFieldDef BackendUpdate {} = error "updateFieldDef did not expect BackendUpdate" diff --git a/Database/Persist/MySQLConnectInfoShowInstance.hs b/Database/Persist/MySQLConnectInfoShowInstance.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/MySQLConnectInfoShowInstance.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_mysql_haskell(0,8,1) +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif + +{-| +Module : Database.Persist.MySQLConnectInfoShowInstance +Description : Conditionally adding Show instance for mysql-haskell's ConnectInfo + +As of mysql_haskell-0.8.1.0, mysql-haskell's ConnectInfo ships _with_ a Show instance. +However, for earlier versions, we must supply our own instance. +We have a stand-alone package since CPP flags do not like multi-line string literals (widely used in sibling module). +-} + +module Database.Persist.MySQLConnectInfoShowInstance where + +#if !MIN_VERSION_mysql_haskell(0,8,1) +import qualified Database.MySQL.Base as MySQL +deriving instance Show MySQL.ConnectInfo +#endif diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,12 @@ # persistent-mysql-haskell -![hackage version](https://img.shields.io/hackage/v/persistent-mysql-haskell.svg) +[![hackage version](https://img.shields.io/hackage/v/persistent-mysql-haskell.svg)](https://hackage.haskell.org/package/persistent-mysql-haskell) +[![Build Status](https://travis-ci.org/naushadh/persistent.svg?branch=persistent-mysql-haskell)](https://travis-ci.org/naushadh/persistent) A pure haskell backend for [persistent](https://github.com/yesodweb/persistent) using the MySQL database server. Internally it uses the [mysql-haskell](https://github.com/winterland1989/mysql-haskell) driver in order to access the database. -See [example/Main.hs](example/Main.hs) for how this MySQL backend can be used with Persistent. +See [example/Main.hs](https://github.com/naushadh/persistent/blob/persistent-mysql-haskell/persistent-mysql-haskell/example/Main.hs) for how this MySQL backend can be used with Persistent. ### Motivation @@ -56,6 +57,21 @@ ``` +- `mysql-haskell` and `mysql` have different APIs/mechanisms for securing the +connection to MySQL. `persistent-mysql-haskell` exposes an API to utilize +[TLS client params](https://hackage.haskell.org/package/mysql-haskell/docs/Database-MySQL-TLS.html) +that ships with `mysql-haskell`. + + ```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-haskell 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-haskell#diff-028f5df7b2b9c5c8b0fa670fc8c69bff). ### FAQs @@ -75,6 +91,9 @@ - It does! :) `persistent-test` is fully re-used with an additional flag to specifically test persistent-mysql-haskell. + - [CI/Travis](https://travis-ci.org/naushadh/persistent), see [.travis.yml](../.travis.yml). + + - Local, ```bash stack test persistent-test --flag persistent-test:mysql_haskell ``` diff --git a/persistent-mysql-haskell.cabal b/persistent-mysql-haskell.cabal --- a/persistent-mysql-haskell.cabal +++ b/persistent-mysql-haskell.cabal @@ -1,5 +1,5 @@ name: persistent-mysql-haskell -version: 0.3.0.0 +version: 0.3.3 license: MIT license-file: LICENSE author: Naushadh , Felipe Lessa , Michael Snoyman @@ -44,6 +44,7 @@ , network >= 2.3 && < 3.0 , tls >= 1.3.5 && < 1.4 exposed-modules: Database.Persist.MySQL + other-modules: Database.Persist.MySQLConnectInfoShowInstance ghc-options: -Wall executable persistent-mysql-haskell-example