diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -16,6 +16,7 @@ import Control.Arrow import Control.Monad (mzero) +import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Error (ErrorT(..)) @@ -28,6 +29,7 @@ import Data.List (find, intercalate, sort, groupBy) import Data.Text (Text, pack) import System.Environment (getEnvironment) +import Data.Acquire (Acquire, mkAcquire, with) import Data.Conduit import qualified Blaze.ByteString.Builder.Char8 as BBB @@ -55,7 +57,7 @@ -- 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 :: MonadIO m => +withMySQLPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => MySQL.ConnectInfo -- ^ Connection information. -> Int @@ -69,7 +71,7 @@ -- | Create a MySQL connection pool. Note that it's your -- responsability to properly close the connection pool when -- unneeded. Use 'withMySQLPool' for automatic resource control. -createMySQLPool :: MonadIO m => +createMySQLPool :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => MySQL.ConnectInfo -- ^ Connection information. -> Int @@ -80,7 +82,7 @@ -- | Same as 'withMySQLPool', but instead of opening a pool -- of connections, only one connection is opened. -withMySQLConn :: (MonadBaseControl IO m, MonadIO m) => +withMySQLConn :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => MySQL.ConnectInfo -- ^ Connection information. -> (Connection -> m a) @@ -91,8 +93,8 @@ -- | Internal function that opens a connection to the MySQL -- server. -open' :: MySQL.ConnectInfo -> IO Connection -open' ci = do +open' :: MySQL.ConnectInfo -> LogFunc -> IO Connection +open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! smap <- newIORef $ Map.empty @@ -111,8 +113,9 @@ -- , connRDBMS = "mysql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" + , connLogFunc = logFunc } - + -- | Prepare a query. We don't support prepared statements, but -- we'll do some client-side preprocessing here. prepare' :: MySQL.Connection -> Text -> IO Statement @@ -127,7 +130,7 @@ -- | SQL code to be executed when inserting an entity. -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = let sql = pack $ concat [ "INSERT INTO " @@ -149,13 +152,14 @@ -- | Execute an statement that does return results. The results -- are fetched all at once and stored into memory. -withStmt' :: MonadResource m +withStmt' :: MonadIO m => MySQL.Connection -> MySQL.Query -> [PersistValue] - -> Source m [PersistValue] -withStmt' conn query vals = - bracketP createResult MySQLBase.freeResult fetchRows >>= CL.sourceList + -> Acquire (Source m [PersistValue]) +withStmt' conn query vals = do + result <- mkAcquire createResult MySQLBase.freeResult + return $ fetchRows result >>= CL.sourceList where createResult = do -- Execute the query @@ -197,7 +201,6 @@ render (P (PersistDay d)) = MySQL.render d render (P (PersistTimeOfDay t)) = MySQL.render t render (P (PersistUTCTime t)) = MySQL.render t - render (P (PersistZonedTime (ZT t))) = MySQL.render $ show t render (P PersistNull) = MySQL.render MySQL.Null render (P (PersistList l)) = MySQL.render $ listToJSON l render (P (PersistMap m)) = MySQL.render $ mapToJSON m @@ -267,11 +270,10 @@ -- | Create the migration plan for the given 'PersistEntity' -- @val@. -migrate' :: Show a - => MySQL.ConnectInfo - -> [EntityDef a] +migrate' :: MySQL.ConnectInfo + -> [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' connectInfo allDefs getter val = do let name = entityDB val @@ -282,7 +284,7 @@ -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ primaryFields pdef, ")"] Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"] let addTable = AddTable $ concat @@ -323,7 +325,7 @@ -- | Find out the type of a column. -findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -335,7 +337,7 @@ -- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] [id_] where id_ = maybe (error $ "Could not find ID of entity " ++ show reftable @@ -373,7 +375,7 @@ -- in the database. getColumns :: MySQL.ConnectInfo -> (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column , [Either Text (Either Column (DBName, [DBName]))] -- everything else ) @@ -387,7 +389,7 @@ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ \AND COLUMN_NAME = ?" - inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries -- Find out all columns. @@ -399,7 +401,7 @@ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ \AND COLUMN_NAME <> ?" - inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries -- Find out the constraints. @@ -413,7 +415,7 @@ \AND REFERENCED_TABLE_SCHEMA IS NULL \ \ORDER BY CONSTRAINT_NAME, \ \COLUMN_NAME" - us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) -- Return both return (ids, cs ++ us) @@ -477,7 +479,7 @@ , PersistText $ unDBName $ tname , PersistByteString cname , PersistText $ pack $ MySQL.connectDatabase connectInfo ] - cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> @@ -539,7 +541,6 @@ parseType "date" = SqlDay --parseType "newdate" = SqlDay --parseType "year" = SqlDay --- Other -} parseType b = SqlOther $ T.decodeUtf8 b @@ -549,8 +550,7 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@. -getAlters :: Show a - => [EntityDef a] +getAlters :: [EntityDef] -> DBName -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) @@ -587,7 +587,7 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName maxLen ref) cols = case filter ((name ==) . cName) cols of -- new fkey that didnt exist before @@ -648,8 +648,6 @@ showSqlType SqlBool _ _ = "TINYINT(1)" showSqlType SqlDay _ _ = "DATE" showSqlType SqlDayTime _ _ = "DATETIME" -showSqlType SqlDayTimeZoned _ True = "VARCHAR(50) CHARACTER SET utf8" -showSqlType SqlDayTimeZoned _ False = "VARCHAR(50)" showSqlType SqlInt32 _ _ = "INT(11)" showSqlType SqlInt64 _ _ = "BIGINT" showSqlType SqlReal _ _ = "DOUBLE" @@ -801,7 +799,7 @@ type PersistConfigPool MySQLConf = ConnectionPool - createPoolConfig (MySQLConf cs size) = createMySQLPool cs size + createPoolConfig (MySQLConf cs size) = runNoLoggingT $ createMySQLPool cs size -- FIXME runPool _ = runSqlPool @@ -809,16 +807,12 @@ database <- o .: "database" host <- o .: "host" port <- o .: "port" - path <- o .:? "path" user <- o .: "user" password <- o .: "password" pool <- o .: "poolsize" let ci = MySQL.defaultConnectInfo { MySQL.connectHost = host , MySQL.connectPort = port - , MySQL.connectPath = case path of - Just p -> p - Nothing -> MySQL.connectPath MySQL.defaultConnectInfo , MySQL.connectUser = user , MySQL.connectPassword = password , MySQL.connectDatabase = database @@ -835,14 +829,12 @@ MySQL.ConnectInfo { MySQL.connectHost = host , MySQL.connectPort = port - , MySQL.connectPath = path , MySQL.connectUser = user , MySQL.connectPassword = password , MySQL.connectDatabase = database } -> (myConnInfo conf) { MySQL.connectHost = maybeEnv host "HOST" , MySQL.connectPort = read $ maybeEnv (show port) "PORT" - , MySQL.connectPath = maybeEnv path "PATH" , MySQL.connectUser = maybeEnv user "USER" , MySQL.connectPassword = maybeEnv password "PASSWORD" , MySQL.connectDatabase = maybeEnv database "DATABASE" diff --git a/persistent-mysql.cabal b/persistent-mysql.cabal --- a/persistent-mysql.cabal +++ b/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 1.3.1 +version: 2.0.0 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -30,14 +30,15 @@ , mysql-simple >= 0.2.2.3 && < 0.3 , mysql >= 0.1.1.3 && < 0.2 , blaze-builder - , persistent >= 1.3 && < 1.4 + , persistent >= 2.0 && < 2.1 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.11.0.6 , monad-control >= 0.2 , aeson >= 0.5 , conduit >= 0.5.3 - , resourcet + , resourcet >= 0.4.10 + , monad-logger exposed-modules: Database.Persist.MySQL ghc-options: -Wall