groundhog-mysql 0.11 → 0.12
raw patch · 2 files changed
+472/−368 lines, 2 filesdep ~groundhog
Dependency ranges changed: groundhog
Files
- Database/Groundhog/MySQL.hs +468/−365
- groundhog-mysql.cabal +4/−3
Database/Groundhog/MySQL.hs view
@@ -1,58 +1,61 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-}-module Database.Groundhog.MySQL- ( withMySQLPool- , withMySQLConn- , createMySQLPool- , runDbConn- , MySQL(..)- , module Database.Groundhog- , module Database.Groundhog.Generic.Sql.Functions- , MySQL.ConnectInfo(..)- , MySQLBase.SSLInfo(..)- , MySQL.defaultConnectInfo- , MySQLBase.defaultSSLInfo- ) where--import Database.Groundhog-import Database.Groundhog.Core-import Database.Groundhog.Expression-import Database.Groundhog.Generic-import Database.Groundhog.Generic.Migration hiding (MigrationPack(..))-import qualified Database.Groundhog.Generic.Migration as GM-import Database.Groundhog.Generic.Sql-import Database.Groundhog.Generic.Sql.Functions-import qualified Database.Groundhog.Generic.PersistBackendHelpers as H--import qualified Database.MySQL.Simple as MySQL-import qualified Database.MySQL.Simple.Param as MySQL-import qualified Database.MySQL.Simple.Result as MySQL-import qualified Database.MySQL.Simple.Types as MySQL+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -import qualified Database.MySQL.Base as MySQLBase-import qualified Database.MySQL.Base.Types as MySQLBase+module Database.Groundhog.MySQL+ ( withMySQLPool,+ withMySQLConn,+ createMySQLPool,+ runDbConn,+ MySQL (..),+ module Database.Groundhog,+ module Database.Groundhog.Generic.Sql.Functions,+ MySQL.ConnectInfo (..),+ MySQLBase.SSLInfo (..),+ MySQL.defaultConnectInfo,+ MySQLBase.defaultSSLInfo,+ )+where import Control.Applicative ((<|>)) import Control.Arrow (first, second, (***))-import Control.Monad (liftM, liftM2, (>=>))-import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (liftM2, (>=>))+import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.State (mapStateT) import Data.Acquire (mkAcquire)+-- work around for no Semigroup instance of MySQL.Query prior to+-- mysql-simple 0.4.5+import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) import Data.Char (toUpper) import Data.Function (on)-import Data.Int (Int64) import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Int (Int64) import Data.List (groupBy, intercalate, intersect, isInfixOf, partition, stripPrefix) import Data.Maybe (fromJust, fromMaybe, isJust)-import Data.Monoid hiding ((<>)) import Data.Pool---- work around for no Semigroup instance of MySQL.Query prior to--- mysql-simple 0.4.5-import qualified Data.ByteString as B+import Database.Groundhog+import Database.Groundhog.Core+import Database.Groundhog.Expression+import Database.Groundhog.Generic+import Database.Groundhog.Generic.Migration hiding (MigrationPack (..))+import qualified Database.Groundhog.Generic.Migration as GM+import qualified Database.Groundhog.Generic.PersistBackendHelpers as H+import Database.Groundhog.Generic.Sql+import Database.Groundhog.Generic.Sql.Functions+import qualified Database.MySQL.Base as MySQLBase+import qualified Database.MySQL.Base.Types as MySQLBase+import qualified Database.MySQL.Simple as MySQL+import qualified Database.MySQL.Simple.Param as MySQL+import qualified Database.MySQL.Simple.Result as MySQL+import qualified Database.MySQL.Simple.Types as MySQL newtype MySQL = MySQL MySQL.Connection @@ -102,43 +105,49 @@ getList k = runDb' $ getList' k instance SchemaAnalyzer MySQL where- schemaExists schema = runDb' $ queryRaw' "SELECT 1 FROM information_schema.schemata WHERE schema_name=?" [toPrimitivePersistValue schema] >>= firstRow >>= return . isJust- getCurrentSchema = runDb' $ queryRaw' "SELECT database()" [] >>= firstRow >>= return . (>>= fst . fromPurePersistValues)- listTables schema = runDb' $ queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,database())" [toPrimitivePersistValue schema] >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- listTableTriggers name = runDb' $ queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,database()) AND event_object_table=?" (toPurePersistValues name []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList+ schemaExists schema = runDb' $ queryRaw' "SELECT 1 FROM information_schema.schemata WHERE schema_name=?" [toPrimitivePersistValue schema] >>= firstRow >>= pure . isJust+ getCurrentSchema = runDb' $ queryRaw' "SELECT database()" [] >>= firstRow >>= pure . (>>= fst . fromPurePersistValues)+ listTables schema = runDb' $ queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,database())" [toPrimitivePersistValue schema] >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ listTableTriggers name = runDb' $ queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,database()) AND event_object_table=?" (toPurePersistValues name []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList analyzeTable = runDb' . analyzeTable' analyzeTrigger name = runDb' $ do x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_schema=coalesce(?,database()) AND trigger_name=?" (toPurePersistValues name []) >>= firstRow- return $ case x of- Nothing -> Nothing+ pure $ case x of+ Nothing -> Nothing Just src -> fst $ fromPurePersistValues src analyzeFunction name = runDb' $ do result <- queryRaw' "SELECT param_list, returns, body_utf8 from mysql.proc WHERE db = coalesce(?, database()) AND name = ?" (toPurePersistValues name []) >>= firstRow let read' typ = readSqlType typ typ (Nothing, Nothing, Nothing)- return $ case result of- Nothing -> Nothing+ pure $ case result of+ Nothing -> Nothing -- TODO: parse param_list- Just result' -> Just (Just [DbOther (OtherTypeDef [Left param_list])], if ret == "" then Nothing else Just $ read' ret, src) where- (param_list, ret, src) = fst . fromPurePersistValues $ result'- getMigrationPack = liftM (migrationPack . fromJust) getCurrentSchema+ Just result' -> Just (Just [DbOther (OtherTypeDef [Left param_list])], if ret == "" then Nothing else Just $ read' ret, src)+ where+ (param_list, ret, src) = fst . fromPurePersistValues $ result'+ getMigrationPack = fmap (migrationPack . fromJust) getCurrentSchema -withMySQLPool :: (MonadBaseControl IO m, MonadIO m)- => MySQL.ConnectInfo- -> Int -- ^ number of connections to open- -> (Pool MySQL -> m a)- -> m a+withMySQLPool ::+ (MonadBaseControl IO m, MonadIO m) =>+ MySQL.ConnectInfo ->+ -- | number of connections to open+ Int ->+ (Pool MySQL -> m a) ->+ m a withMySQLPool s connCount f = createMySQLPool s connCount >>= f -createMySQLPool :: MonadIO m- => MySQL.ConnectInfo- -> Int -- ^ number of connections to open- -> m (Pool MySQL)+createMySQLPool ::+ MonadIO m =>+ MySQL.ConnectInfo ->+ -- | number of connections to open+ Int ->+ m (Pool MySQL) createMySQLPool s connCount = liftIO $ createPool (open' s) close' 1 20 connCount -withMySQLConn :: (MonadBaseControl IO m, MonadIO m)- => MySQL.ConnectInfo- -> (MySQL -> m a)- -> m a+withMySQLConn ::+ (MonadBaseControl IO m, MonadIO m) =>+ MySQL.ConnectInfo ->+ (MySQL -> m a) ->+ m a withMySQLConn s = bracket (liftIO $ open' s) (liftIO . close') -- As with the postgresql backend, it's not obvious to me how best to@@ -149,30 +158,30 @@ combine :: MySQL.Query -> MySQL.Query -> MySQL.Query -- combine = (<>) combine (MySQL.Query a) (MySQL.Query b) = MySQL.Query (B.append a b)- + instance Savepoint MySQL where withConnSavepoint name m (MySQL c) = do let name' = fromString name- liftIO $ MySQL.execute_ c $ "SAVEPOINT " `combine` name'+ _ <- liftIO $ MySQL.execute_ c $ "SAVEPOINT " `combine` name' x <- onException m (liftIO $ MySQL.execute_ c $ "ROLLBACK TO SAVEPOINT " `combine` name')- liftIO $ MySQL.execute_ c $ "RELEASE SAVEPOINT" `combine` name'- return x+ _ <- liftIO $ MySQL.execute_ c $ "RELEASE SAVEPOINT" `combine` name'+ pure x instance ConnectionManager MySQL where withConn f conn@(MySQL c) = do- liftIO $ MySQL.execute_ c "start transaction"+ _ <- liftIO $ MySQL.execute_ c "start transaction" x <- onException (f conn) (liftIO $ MySQL.rollback c) liftIO $ MySQL.commit c- return x+ pure x instance TryConnectionManager MySQL where tryWithConn f g conn@(MySQL c) = do- liftIO $ MySQL.execute_ c "start transaction"+ _ <- liftIO $ MySQL.execute_ c "start transaction" x <- g (f conn) case x of Left _ -> liftIO $ MySQL.rollback c Right _ -> liftIO $ MySQL.commit c- return x+ pure x instance ExtractConnection MySQL MySQL where extractConn f conn = f conn@@ -184,7 +193,7 @@ open' ci = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit!- return $ MySQL conn+ pure $ MySQL conn close' :: MySQL -> IO () close' (MySQL conn) = MySQL.close conn@@ -196,22 +205,23 @@ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue (head vals) - liftM fst $ if isSimple (constructors e)- then do- let constr = head $ constructors e- let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)- executeRaw' query (vals' [])- case constrAutoKeyName constr of- Nothing -> pureFromPersistValue []- Just _ -> getLastInsertId >>= \rowid -> pureFromPersistValue [rowid]- else do- let constr = constructors e !! constructorNum- let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"- executeRaw' query $ take 1 vals- rowid <- getLastInsertId- let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals)- executeRaw' cQuery (vals' [])- pureFromPersistValue [rowid]+ fmap fst $+ if isSimple (constructors e)+ then do+ let constr = head $ constructors e+ let RenderS query vals' = insertIntoConstructorTable False (tableName escapeS e constr) constr (tail vals)+ executeRaw' query (vals' [])+ case constrAutoKeyName constr of+ Nothing -> pureFromPersistValue []+ Just _ -> getLastInsertId >>= \rowid -> pureFromPersistValue [rowid]+ else do+ let constr = constructors e !! constructorNum+ let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)"+ executeRaw' query $ take 1 vals+ rowid <- getLastInsertId+ let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid : tail vals)+ executeRaw' cQuery (vals' [])+ pureFromPersistValue [rowid] insert_' :: PersistEntity v => v -> Action MySQL () insert_' v = do@@ -230,19 +240,20 @@ let query = "INSERT INTO " <> mainTableName escapeS e <> "(discr)VALUES(?)" executeRaw' query $ take 1 vals rowid <- getLastInsertId- let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals)+ let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid : tail vals) executeRaw' cQuery (vals' []) insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r-insertIntoConstructorTable withId tName c vals = RenderS query vals' where- query = "INSERT INTO " <> tName <> columnsValues- fields = case constrAutoKeyName c of- Just idName | withId -> (idName, dbType proxy (0 :: Int64)):constrParams c- _ -> constrParams c- columnsValues = case foldr (flatten escapeS) [] fields of- [] -> "() VALUES ()"- xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")"- RenderS placeholders vals' = commasJoin $ map renderPersistValue vals+insertIntoConstructorTable withId tName c vals = RenderS query vals'+ where+ query = "INSERT INTO " <> tName <> columnsValues+ fields = case constrAutoKeyName c of+ Just idName | withId -> (idName, dbType proxy (0 :: Int64)) : constrParams c+ _ -> constrParams c+ columnsValues = case foldr (flatten escapeS) [] fields of+ [] -> "() VALUES ()"+ xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")"+ RenderS placeholders vals' = commasJoin $ map renderPersistValue vals insertList' :: forall a. PersistField a => [a] -> Action MySQL Int64 insertList' (l :: [a]) = do@@ -253,42 +264,43 @@ let fields = [("ord", dbType proxy (0 :: Int)), ("value", dbType proxy (undefined :: a))] let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")" let go :: Int -> [a] -> Action MySQL ()- go n (x:xs) = do- x' <- toPersistValues x- executeRaw' query $ (k:) . (toPrimitivePersistValue n:) . x' $ []- go (n + 1) xs- go _ [] = return ()+ go n (x : xs) = do+ x' <- toPersistValues x+ executeRaw' query $ (k :) . (toPrimitivePersistValue n :) . x' $ []+ go (n + 1) xs+ go _ [] = pure () go 0 l- return $ fromPrimitivePersistValue k- -getList' :: forall a . PersistField a => Int64 -> Action MySQL [a]+ pure $ fromPrimitivePersistValue k++getList' :: forall a. PersistField a => Int64 -> Action MySQL [a] getList' k = do let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a)) let valuesName = mainName <> delim' <> "values" let value = ("value", dbType proxy (undefined :: a)) let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"- queryRaw' query [toPrimitivePersistValue k] >>= mapStream (liftM fst . fromPersistValues) >>= streamToList+ queryRaw' query [toPrimitivePersistValue k] >>= mapStream (fmap fst . fromPersistValues) >>= streamToList getLastInsertId :: Action MySQL PersistValue getLastInsertId = do x <- queryRaw' "SELECT last_insert_id()" [] >>= firstRow- return $ maybe (error "getLastInsertId: Nothing") head x+ pure $ maybe (error "getLastInsertId: Nothing") head x ---------- executeRaw' :: Utf8 -> [PersistValue] -> Action MySQL () executeRaw' query vals = do--- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals+ -- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals MySQL conn <- ask let stmt = getStatement query liftIO $ do _ <- MySQL.execute conn stmt (map P vals)- return ()+ pure () renderConfig :: RenderConfig-renderConfig = RenderConfig {- esc = escapeS-}+renderConfig =+ RenderConfig+ { esc = escapeS+ } escapeS :: Utf8 -> Utf8 escapeS a = let q = fromChar '`' in q <> a <> q@@ -297,7 +309,7 @@ delim' = fromChar delim toEntityPersistValues' :: PersistEntity v => v -> Action MySQL [PersistValue]-toEntityPersistValues' = liftM ($ []) . toEntityPersistValues+toEntityPersistValues' = fmap ($ []) . toEntityPersistValues --- MIGRATION @@ -307,51 +319,58 @@ migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v migrationPack :: String -> GM.MigrationPack MySQL-migrationPack currentSchema = m where- m = GM.MigrationPack- compareTypes- (compareRefs currentSchema)- compareUniqs- compareDefaults- migTriggerOnDelete- migTriggerOnUpdate- (GM.defaultMigConstr m)- escape- "BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"- mainTableId- defaultPriority- (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))- showSqlType- showColumn- (showAlterDb currentSchema)- Restrict- Restrict+migrationPack currentSchema = m+ where+ m =+ GM.MigrationPack+ compareTypes+ (compareRefs currentSchema)+ compareUniqs+ compareDefaults+ migTriggerOnDelete+ migTriggerOnUpdate+ (GM.defaultMigConstr m)+ escape+ "BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"+ mainTableId+ defaultPriority+ (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))+ showSqlType+ showColumn+ (showAlterDb currentSchema)+ Restrict+ Restrict showColumn :: Column -> String-showColumn (Column n nu t def) = concat- [ escape n- , " "- , showSqlType t- , " "- , if nu then "NULL" else "NOT NULL"- , case def of+showColumn (Column n nu t def) =+ concat+ [ escape n,+ " ",+ showSqlType t,+ " ",+ if nu then "NULL" else "NOT NULL",+ case def of Nothing -> ""- Just s -> " DEFAULT " ++ s+ Just s -> " DEFAULT " ++ s ] migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action MySQL (Bool, [AlterDB]) migTriggerOnDelete name deletes = do let addTrigger = AddTriggerOnDelete name name (concatMap snd deletes) x <- analyzeTrigger name- return $ case x of+ pure $ case x of Nothing | null deletes -> (False, []) Nothing -> (False, [addTrigger])- Just sql -> (True, if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types- then [DropTrigger name name]- else if sql == "BEGIN " ++ concatMap snd deletes ++ "END"- then []- -- this can happen when an ephemeral field was added or removed.- else [DropTrigger name name, addTrigger])+ Just sql ->+ ( True,+ if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types+ then [DropTrigger name name]+ else+ if sql == "BEGIN " ++ concatMap snd deletes ++ "END"+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropTrigger name name, addTrigger]+ ) -- | Schema name, table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields@@ -362,59 +381,75 @@ trigBody = concatMap f deletes let addTrigger = AddTriggerOnUpdate trigName tName Nothing trigBody x <- analyzeTrigger trigName- return $ return $ case x of- Nothing | null deletes -> (False, [])- Nothing -> (False, [addTrigger])- Just sql -> (True, if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types- then [DropTrigger trigName tName]- else if sql == "BEGIN " ++ trigBody ++ "END"- then []- -- this can happen when an ephemeral field was added or removed.- else [DropTrigger trigName tName, addTrigger])- + pure $+ pure $ case x of+ Nothing | null deletes -> (False, [])+ Nothing -> (False, [addTrigger])+ Just sql ->+ ( True,+ if null deletes -- remove old trigger if a datatype earlier had fields of ephemeral types+ then [DropTrigger trigName tName]+ else+ if sql == "BEGIN " ++ trigBody ++ "END"+ then []+ else -- this can happen when an ephemeral field was added or removed.+ [DropTrigger trigName tName, addTrigger]+ )+ analyzeTable' :: QualifiedName -> Action MySQL (Maybe TableInfo) analyzeTable' name = do table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, database()) AND table_name = ?" (toPurePersistValues name []) >>= firstRow case table of Just _ -> do- let colQuery = "SELECT c.column_name, c.is_nullable, c.data_type, c.column_type, c.column_default, c.character_maximum_length, c.numeric_precision, c.numeric_scale, c.extra\-\ FROM information_schema.columns c\-\ WHERE c.table_schema = coalesce(?, database()) AND c.table_name=?\-\ ORDER BY c.ordinal_position"+ let colQuery =+ "SELECT c.column_name, c.is_nullable, c.data_type, c.column_type, c.column_default, c.character_maximum_length, c.numeric_precision, c.numeric_scale, c.extra\+ \ FROM information_schema.columns c\+ \ WHERE c.table_schema = coalesce(?, database()) AND c.table_name=?\+ \ ORDER BY c.ordinal_position" - cols <- queryRaw' colQuery (toPurePersistValues name []) >>= mapStream (return . first getColumn . fst . fromPurePersistValues) >>= streamToList+ cols <- queryRaw' colQuery (toPurePersistValues name []) >>= mapStream (pure . first getColumn . fst . fromPurePersistValues) >>= streamToList -- MySQL has no difference between unique keys and indexes let constraintQuery = "SELECT u.constraint_name, u.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.key_column_usage u USING (constraint_catalog, constraint_schema, constraint_name, table_schema, table_name) WHERE tc.constraint_type=? AND tc.table_schema=coalesce(?,database()) AND u.table_name=? ORDER BY u.constraint_name, u.column_name"- uniqConstraints <- queryRaw' constraintQuery (toPurePersistValues ("UNIQUE" :: String, name) []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList- uniqPrimary <- queryRaw' constraintQuery (toPurePersistValues ("PRIMARY KEY" :: String, name) []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList+ uniqConstraints <- queryRaw' constraintQuery (toPurePersistValues ("UNIQUE" :: String, name) []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList+ uniqPrimary <- queryRaw' constraintQuery (toPurePersistValues ("PRIMARY KEY" :: String, name) []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList let mkUniqs typ = map (\us -> UniqueDef (fst $ head us) typ (map (Left . snd) us)) . groupBy ((==) `on` fst) isAutoincremented = case filter (\c -> colName (fst c) `elem` map snd uniqPrimary) cols of- [(c, extra)] -> colType c `elem` [DbInt32, DbInt64] && "auto_increment" `isInfixOf` (extra :: String)- _ -> False+ [(c, extra)] -> colType c `elem` [DbInt32, DbInt64] && "auto_increment" `isInfixOf` (extra :: String)+ _ -> False uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs (UniquePrimary isAutoincremented) uniqPrimary references <- analyzeTableReferences name- return $ Just $ TableInfo (map fst cols) uniqs references- Nothing -> return Nothing+ pure $ Just $ TableInfo (map fst cols) uniqs references+ Nothing -> pure Nothing getColumn :: ((String, String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int)) -> Column-getColumn ((column_name, is_nullable, data_type, column_type, d), modifiers) = Column column_name (is_nullable == "YES") t d where- t = readSqlType data_type column_type modifiers+getColumn ((column_name, is_nullable, data_type, column_type, def), modifiers) =+ Column+ { colName = column_name,+ colNull = is_nullable == "YES",+ colType = readSqlType data_type column_type modifiers,+ colDefault = case def of+ Nothing -> Nothing+ Just "NULL" -> Nothing+ Just d -> Just d+ } analyzeTableReferences :: QualifiedName -> Action MySQL [(Maybe String, Reference)] analyzeTableReferences name = do- let query = "SELECT tc.constraint_name, u.referenced_table_schema, u.referenced_table_name, rc.delete_rule, rc.update_rule, u.column_name, u.referenced_column_name FROM information_schema.table_constraints tc\-\ INNER JOIN information_schema.key_column_usage u USING (constraint_catalog, constraint_schema, constraint_name, table_schema, table_name)\-\ INNER JOIN information_schema.referential_constraints rc USING (constraint_catalog, constraint_schema, constraint_name)\-\ WHERE tc.constraint_type='FOREIGN KEY' AND tc.table_schema=coalesce(?, database()) AND tc.table_name=?\-\ ORDER BY tc.constraint_name"- x <- queryRaw' query (toPurePersistValues name []) >>= mapStream (return . fst . fromPurePersistValues) >>= streamToList+ let query =+ "SELECT tc.constraint_name, u.referenced_table_schema, u.referenced_table_name, rc.delete_rule, rc.update_rule, u.column_name, u.referenced_column_name FROM information_schema.table_constraints tc\+ \ INNER JOIN information_schema.key_column_usage u USING (constraint_catalog, constraint_schema, constraint_name, table_schema, table_name)\+ \ INNER JOIN information_schema.referential_constraints rc USING (constraint_catalog, constraint_schema, constraint_name)\+ \ WHERE tc.constraint_type='FOREIGN KEY' AND tc.table_schema=coalesce(?, database()) AND tc.table_name=?\+ \ ORDER BY tc.constraint_name"+ x <- queryRaw' query (toPurePersistValues name []) >>= mapStream (pure . fst . fromPurePersistValues) >>= streamToList -- (refName, ((parentTableSchema, parentTable, onDelete, onUpdate), (childColumn, parentColumn)))- let mkReference xs = (Just refName, Reference parentTable pairs (mkAction onDelete) (mkAction onUpdate)) where- pairs = map (snd . snd) xs- (refName, ((parentTable, onDelete, onUpdate), _)) = head xs- mkAction c = Just $ fromMaybe (error $ "unknown reference action type: " ++ c) $ readReferenceAction c+ let mkReference xs = (Just refName, Reference parentTable pairs (mkAction onDelete) (mkAction onUpdate))+ where+ pairs = map (snd . snd) xs+ (refName, ((parentTable, onDelete, onUpdate), _)) = head xs+ mkAction c = Just $ fromMaybe (error $ "unknown reference action type: " ++ c) $ readReferenceAction c references = map mkReference $ groupBy ((==) `on` fst) x- return references+ pure references showAlterDb :: String -> AlterDB -> SingleMigration showAlterDb _ (AddTable s) = Right [(False, defaultPriority, s)]@@ -424,117 +459,176 @@ showAlterDb _ (AddTriggerOnUpdate trigName tName _ body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ withSchema trigName ++ " AFTER UPDATE ON " ++ withSchema tName ++ " FOR EACH ROW BEGIN " ++ body ++ "END")] showAlterDb _ (CreateOrReplaceFunction s) = Right [(False, functionPriority, s)] showAlterDb _ (DropFunction funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ withSchema funcName ++ "()")]-showAlterDb _ (CreateSchema sch ifNotExists) = Right [(False, schemaPriority, "CREATE DATABASE " ++ ifNotExists' ++ escape sch)] where- ifNotExists' = if ifNotExists then "IF NOT EXISTS " else ""+showAlterDb _ (CreateSchema sch ifNotExists) = Right [(False, schemaPriority, "CREATE DATABASE " ++ ifNotExists' ++ escape sch)]+ where+ ifNotExists' = if ifNotExists then "IF NOT EXISTS " else "" showAlterTable :: String -> String -> AlterTable -> [(Bool, Int, String)]-showAlterTable _ table (AddColumn col) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ADD COLUMN "- , showColumn col- ])]-showAlterTable _ table (DropColumn name) = [(True, defaultPriority, concat- [ "ALTER TABLE "- , table- , " DROP COLUMN "- , escape name- ])]-showAlterTable _ table (AlterColumn col alts) = change ++ updates' where- change = if null other then [] else [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " CHANGE "- , escape $ colName col- , " "- , showColumn col- ])]- updates' = concatMap f updates where- f (UpdateValue s) = [(False, defaultPriority, concat- [ "UPDATE "- , table- , " SET "- , escape $ colName col- , "="- , s- , " WHERE "- , escape $ colName col- , " IS NULL"- ])]- f _ = []- (updates, other) = partition (\a -> case a of UpdateValue _ -> True; _ -> False) alts-showAlterTable _ table (AddUnique (UniqueDef uName UniqueConstraint cols)) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ADD"- , maybe "" ((" CONSTRAINT " ++) . escape) uName- , " UNIQUE("- , intercalate "," $ map (either escape id) cols- , ")"- ])]-showAlterTable _ table (AddUnique (UniqueDef uName UniqueIndex cols)) = [(False, defaultPriority, concat- [ "CREATE UNIQUE INDEX "- , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName- , " ON "- , table- , "("- , intercalate "," $ map (either escape id) cols- , ")"- ])]-showAlterTable _ table (AddUnique (UniqueDef uName (UniquePrimary _) cols)) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " ADD"- , maybe "" ((" CONSTRAINT " ++) . escape) uName- , " PRIMARY KEY("- , intercalate "," $ map (either escape id) cols- , ")"- ])]-showAlterTable _ table (DropConstraint uName) = [(False, defaultPriority, concat- [ "ALTER TABLE "- , table- , " DROP KEY "- , escape uName- ])]-showAlterTable _ _ (DropIndex uName) = [(False, defaultPriority, concat- [ "DROP INDEX "- , escape uName- ])]-showAlterTable currentSchema table (AddReference (Reference tName columns onDelete onUpdate)) = [(False, referencePriority, concat- [ "ALTER TABLE "- , table- , " ADD FOREIGN KEY("- , our- , ") REFERENCES "- , withSchema $ first (<|> Just currentSchema) tName- , "("- , foreign- , ")"- , maybe "" ((" ON DELETE " ++) . showReferenceAction) onDelete- , maybe "" ((" ON UPDATE " ++) . showReferenceAction) onUpdate- ])] where- (our, foreign) = f *** f $ unzip columns- f = intercalate ", " . map escape-showAlterTable _ table (DropReference name) = [(False, defaultPriority,- "ALTER TABLE " ++ table ++ " DROP CONSTRAINT " ++ name)]+showAlterTable _ table (AddColumn col) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD COLUMN ",+ showColumn col+ ]+ )+ ]+showAlterTable _ table (DropColumn name) =+ [ ( True,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " DROP COLUMN ",+ escape name+ ]+ )+ ]+showAlterTable _ table (AlterColumn col alts) = change ++ updates'+ where+ change =+ if null other+ then []+ else+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " CHANGE ",+ escape $ colName col,+ " ",+ showColumn col+ ]+ )+ ]+ updates' = concatMap f updates+ where+ f (UpdateValue s) =+ [ ( False,+ defaultPriority,+ concat+ [ "UPDATE ",+ table,+ " SET ",+ escape $ colName col,+ "=",+ s,+ " WHERE ",+ escape $ colName col,+ " IS NULL"+ ]+ )+ ]+ f _ = []+ (updates, other) = partition (\case UpdateValue _ -> True; _ -> False) alts+showAlterTable _ table (AddUnique (UniqueDef uName UniqueConstraint cols)) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD",+ maybe "" ((" CONSTRAINT " ++) . escape) uName,+ " UNIQUE(",+ intercalate "," $ map (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable _ table (AddUnique (UniqueDef uName UniqueIndex cols)) =+ [ ( False,+ defaultPriority,+ concat+ [ "CREATE UNIQUE INDEX ",+ maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName,+ " ON ",+ table,+ "(",+ intercalate "," $ map (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable _ table (AddUnique (UniqueDef uName (UniquePrimary _) cols)) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD",+ maybe "" ((" CONSTRAINT " ++) . escape) uName,+ " PRIMARY KEY(",+ intercalate "," $ map (either escape id) cols,+ ")"+ ]+ )+ ]+showAlterTable _ table (DropConstraint uName) =+ [ ( False,+ defaultPriority,+ concat+ [ "ALTER TABLE ",+ table,+ " DROP KEY ",+ escape uName+ ]+ )+ ]+showAlterTable _ _ (DropIndex uName) =+ [ ( False,+ defaultPriority,+ "DROP INDEX " ++ escape uName+ )+ ]+showAlterTable currentSchema table (AddReference (Reference tName columns onDelete onUpdate)) =+ [ ( False,+ referencePriority,+ concat+ [ "ALTER TABLE ",+ table,+ " ADD FOREIGN KEY(",+ ourKey,+ ") REFERENCES ",+ withSchema $ first (<|> Just currentSchema) tName,+ "(",+ foreignKey,+ ")",+ maybe "" ((" ON DELETE " ++) . showReferenceAction) onDelete,+ maybe "" ((" ON UPDATE " ++) . showReferenceAction) onUpdate+ ]+ )+ ]+ where+ (ourKey, foreignKey) = f *** f $ unzip columns+ f = intercalate ", " . map escape+showAlterTable _ table (DropReference name) =+ [ ( False,+ defaultPriority,+ "ALTER TABLE " ++ table ++ " DROP CONSTRAINT " ++ name+ )+ ] readSqlType :: String -> String -> (Maybe Int, Maybe Int, Maybe Int) -> DbTypePrimitive-readSqlType typ colTyp (_, numeric_precision, numeric_scale) = (case typ of- _ | typ `elem` ["int", "short", "mediumint"] -> DbInt32- _ | typ `elem` ["long", "longlong", "bigint"] -> DbInt64- "float" | numAttrs == (Just 12, Nothing) -> DbReal- "double" | numAttrs == (Just 22, Nothing) -> DbReal- "decimal" | numAttrs == (Just 10, Just 0) -> DbReal- "newdecimal" | numAttrs == (Just 10, Just 0) -> DbReal- -- varchar, varstring, string always have length, so skip to colTyp- _ | typ `elem` ["text", "tinytext", "mediumtext", "longtext"] -> DbString- -- skip varbinary- _ | typ `elem` ["blob", "tinyblob", "mediumblob", "longblob"] -> DbBlob- "time" -> DbTime- _ | typ `elem` ["datetime", "timestamp"] -> DbDayTime- _ | typ `elem` ["date", "newdate", "year"] -> DbDay- _ -> DbOther $ OtherTypeDef [Left colTyp]- ) where+readSqlType typ colTyp (_, numeric_precision, numeric_scale) =+ case typ of+ _ | typ `elem` ["int", "short", "mediumint"] -> DbInt32+ _ | typ `elem` ["long", "longlong", "bigint"] -> DbInt64+ "float" | numAttrs == (Just 12, Nothing) -> DbReal+ "double" | numAttrs == (Just 22, Nothing) -> DbReal+ "decimal" | numAttrs == (Just 10, Just 0) -> DbReal+ "newdecimal" | numAttrs == (Just 10, Just 0) -> DbReal+ -- varchar, varstring, string always have length, so skip to colTyp+ _ | typ `elem` ["text", "tinytext", "mediumtext", "longtext"] -> DbString+ -- skip varbinary+ _ | typ `elem` ["blob", "tinyblob", "mediumblob", "longblob"] -> DbBlob+ "time" -> DbTime+ _ | typ `elem` ["datetime", "timestamp"] -> DbDayTime+ _ | typ `elem` ["date", "newdate", "year"] -> DbDay+ _ -> DbOther $ OtherTypeDef [Left colTyp]+ where numAttrs = (numeric_precision, numeric_scale) showSqlType :: DbTypePrimitive -> String@@ -553,27 +647,30 @@ compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2-compareUniqs (UniqueDef name1 _ cols1) (UniqueDef name2 _ cols2) = fromMaybe True (liftM2 (==) name1 name2) && haveSameElems (==) cols1 cols2+compareUniqs (UniqueDef name1 _ cols1) (UniqueDef name2 _ cols2) = (Just False /= liftM2 (==) name1 name2) && haveSameElems (==) cols1 cols2 compareRefs :: String -> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool compareRefs currentSchema (_, Reference (sch1, tbl1) pairs1 onDel1 onUpd1) (_, Reference (sch2, tbl2) pairs2 onDel2 onUpd2) =- fromMaybe currentSchema sch1 == fromMaybe currentSchema sch2- && unescape tbl1 == unescape tbl2- && haveSameElems (==) pairs1 pairs2- && fromMaybe Restrict onDel1 == fromMaybe Restrict onDel2- && fromMaybe Restrict onUpd1 == fromMaybe Restrict onUpd2 where+ fromMaybe currentSchema sch1 == fromMaybe currentSchema sch2+ && unescape tbl1 == unescape tbl2+ && haveSameElems (==) pairs1 pairs2+ && fromMaybe Restrict onDel1 == fromMaybe Restrict onDel2+ && fromMaybe Restrict onUpd1 == fromMaybe Restrict onUpd2+ where unescape name = if head name == '"' && last name == '"' then tail $ init name else name compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool-compareTypes type1 type2 = f type1 == f type2 where- f = map toUpper . showSqlType . hack- hack DbDayTimeZoned = DbOther $ OtherTypeDef [Left "VARCHAR(50)"]- hack t = t+compareTypes type1 type2 = f type1 == f type2+ where+ f = map toUpper . showSqlType . hack+ hack DbDayTimeZoned = DbOther $ OtherTypeDef [Left "VARCHAR(50)"]+ hack t = t compareDefaults :: String -> String -> Bool-compareDefaults def1 def2 = not . null $ f def1 `intersect` f def2 where- f def = [Just def, stripQuotes def]- stripQuotes = stripPrefix "'" >=> fmap reverse . stripPrefix "'" . reverse+compareDefaults def1 def2 = not . null $ f def1 `intersect` f def2+ where+ f def = [Just def, stripQuotes def]+ stripQuotes = stripPrefix "'" >=> fmap reverse . stripPrefix "'" . reverse defaultPriority, schemaPriority, referencePriority, functionPriority, triggerPriority :: Int defaultPriority = 1@@ -590,58 +687,61 @@ -- It is used to escape table names and columns, which can include only symbols allowed in Haskell datatypes and '$' delimiter. We need it mostly to support names that coincide with SQL keywords escape :: String -> String escape s = '`' : s ++ "`"- + getStatement :: Utf8 -> MySQL.Query getStatement sql = MySQL.Query $ fromUtf8 sql queryRaw' :: Utf8 -> [PersistValue] -> Action MySQL (RowStream [PersistValue]) queryRaw' query vals = do--- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals+ -- $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals MySQL conn <- ask let open = do- MySQL.formatQuery conn (getStatement query) (map P vals) >>= MySQLBase.query conn- result <- MySQLBase.storeResult conn- -- Find out the type of the columns- fields <- MySQLBase.fetchFields result- let getters = [maybe PersistNull (getGetter (MySQLBase.fieldType f) f . Just) | f <- fields]- convert = use getters where- use (g:gs) (col:cols) = v `seq` vs `seq` (v:vs) where- v = g col- vs = use gs cols- use _ _ = []- let go acc = do- row <- MySQLBase.fetchRow result- case row of- [] -> return (acc [])- _ -> let converted = convert row- in converted `seq` go (acc . (converted:))- -- TODO: this variable is ugly. Switching to pipes or conduit might help- rowsVar <- flip finally (MySQLBase.freeResult result) (go id) >>= newIORef- return $ do- rows <- readIORef rowsVar- case rows of- [] -> return Nothing- (x:xs) -> do- writeIORef rowsVar xs- return $ Just x- return $ mkAcquire open (const $ return ())+ MySQL.formatQuery conn (getStatement query) (map P vals) >>= MySQLBase.query conn+ result <- MySQLBase.storeResult conn+ -- Find out the type of the columns+ fields <- MySQLBase.fetchFields result+ let getters = [maybe PersistNull (getGetter (MySQLBase.fieldType f) f . Just) | f <- fields]+ convert = use getters+ where+ use (g : gs) (col : cols) = v `seq` vs `seq` (v : vs)+ where+ v = g col+ vs = use gs cols+ use _ _ = []+ let go acc = do+ row <- MySQLBase.fetchRow result+ case row of+ [] -> pure (acc [])+ _ ->+ let converted = convert row+ in converted `seq` go (acc . (converted :))+ -- TODO: this variable is ugly. Switching to pipes or conduit might help+ rowsVar <- finally (go id) (MySQLBase.freeResult result) >>= newIORef+ pure $ do+ rows <- readIORef rowsVar+ case rows of+ [] -> pure Nothing+ (x : xs) -> do+ writeIORef rowsVar xs+ pure $ Just x+ pure $ mkAcquire open (const $ pure ()) -- | Avoid orphan instances. newtype P = P PersistValue instance MySQL.Param P where- render (P (PersistString t)) = MySQL.render t- render (P (PersistText t)) = MySQL.render t+ render (P (PersistString t)) = MySQL.render t+ render (P (PersistText t)) = MySQL.render t render (P (PersistByteString bs)) = MySQL.render bs- render (P (PersistInt64 i)) = MySQL.render i- render (P (PersistDouble d)) = MySQL.render d- render (P (PersistBool b)) = MySQL.render b- render (P (PersistDay d)) = MySQL.render d- render (P (PersistTimeOfDay t)) = MySQL.render t- render (P (PersistUTCTime t)) = MySQL.render t+ render (P (PersistInt64 i)) = MySQL.render i+ render (P (PersistDouble d)) = MySQL.render d+ render (P (PersistBool b)) = MySQL.render b+ 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 (PersistCustom _ _)) = error "toField: unexpected PersistCustom"+ render (P PersistNull) = MySQL.render MySQL.Null+ render (P (PersistCustom _ _)) = error "toField: unexpected PersistCustom" type Getter a = MySQLBase.Field -> Maybe ByteString -> a @@ -650,40 +750,43 @@ getGetter :: MySQLBase.Type -> Getter PersistValue -- Bool-getGetter MySQLBase.Tiny = convertPV PersistBool+getGetter MySQLBase.Tiny = convertPV PersistBool -- Int64-getGetter MySQLBase.Int24 = convertPV PersistInt64-getGetter MySQLBase.Short = convertPV PersistInt64-getGetter MySQLBase.Long = convertPV PersistInt64-getGetter MySQLBase.LongLong = convertPV PersistInt64+getGetter MySQLBase.Int24 = convertPV PersistInt64+getGetter MySQLBase.Short = convertPV PersistInt64+getGetter MySQLBase.Long = convertPV PersistInt64+getGetter MySQLBase.LongLong = convertPV PersistInt64 -- Double-getGetter MySQLBase.Float = convertPV PersistDouble-getGetter MySQLBase.Double = convertPV PersistDouble-getGetter MySQLBase.Decimal = convertPV PersistDouble+getGetter MySQLBase.Float = convertPV PersistDouble+getGetter MySQLBase.Double = convertPV PersistDouble+getGetter MySQLBase.Decimal = convertPV PersistDouble getGetter MySQLBase.NewDecimal = convertPV PersistDouble -- ByteString and Text-getGetter MySQLBase.VarChar = convertPV PersistByteString-getGetter MySQLBase.VarString = convertPV PersistByteString-getGetter MySQLBase.String = convertPV PersistByteString-getGetter MySQLBase.Blob = convertPV PersistByteString-getGetter MySQLBase.TinyBlob = convertPV PersistByteString+getGetter MySQLBase.VarChar = convertPV PersistByteString+getGetter MySQLBase.VarString = convertPV PersistByteString+getGetter MySQLBase.String = convertPV PersistByteString+getGetter MySQLBase.Blob = convertPV PersistByteString+getGetter MySQLBase.TinyBlob = convertPV PersistByteString getGetter MySQLBase.MediumBlob = convertPV PersistByteString-getGetter MySQLBase.LongBlob = convertPV PersistByteString+getGetter MySQLBase.LongBlob = convertPV PersistByteString -- Time-related-getGetter MySQLBase.Time = convertPV PersistTimeOfDay-getGetter MySQLBase.DateTime = convertPV PersistUTCTime-getGetter MySQLBase.Timestamp = convertPV PersistUTCTime-getGetter MySQLBase.Date = convertPV PersistDay-getGetter MySQLBase.NewDate = convertPV PersistDay-getGetter MySQLBase.Year = convertPV PersistDay+getGetter MySQLBase.Time = convertPV PersistTimeOfDay+getGetter MySQLBase.DateTime = convertPV PersistUTCTime+getGetter MySQLBase.Timestamp = convertPV PersistUTCTime+getGetter MySQLBase.Date = convertPV PersistDay+getGetter MySQLBase.NewDate = convertPV PersistDay+getGetter MySQLBase.Year = convertPV PersistDay -- Null-getGetter MySQLBase.Null = \_ _ -> PersistNull+getGetter MySQLBase.Null = \_ _ -> PersistNull -- Controversial conversions-getGetter MySQLBase.Set = convertPV PersistText-getGetter MySQLBase.Enum = convertPV PersistText+getGetter MySQLBase.Set = convertPV PersistText+getGetter MySQLBase.Enum = convertPV PersistText -- Unsupported-getGetter other = error $ "MySQL.getGetter: type " ++- show other ++ " not supported."+getGetter other =+ error $+ "MySQL.getGetter: type "+ ++ show other+ ++ " not supported." proxy :: proxy MySQL proxy = error "proxy MySQL"
groundhog-mysql.cabal view
@@ -1,5 +1,5 @@ name: groundhog-mysql-version: 0.11+version: 0.12 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -8,7 +8,7 @@ description: This package uses mysql-simple and mysql category: Database stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple extra-source-files:@@ -20,7 +20,7 @@ , mysql >= 0.1.1.3 && < 0.2 , bytestring >= 0.9 , transformers >= 0.2.1 && < 0.6- , groundhog >= 0.11 && < 0.12+ , groundhog >= 0.12 && < 0.13 , monad-control >= 0.3 && < 1.1 , monad-logger >= 0.3 && < 0.4 , containers >= 0.2@@ -30,3 +30,4 @@ , resourcet >= 1.1.2 exposed-modules: Database.Groundhog.MySQL ghc-options: -Wall -fno-warn-unused-do-bind+ default-language: Haskell2010