diff --git a/Database/Groundhog/MySQL.hs b/Database/Groundhog/MySQL.hs --- a/Database/Groundhog/MySQL.hs +++ b/Database/Groundhog/MySQL.hs @@ -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" diff --git a/groundhog-mysql.cabal b/groundhog-mysql.cabal --- a/groundhog-mysql.cabal +++ b/groundhog-mysql.cabal @@ -1,5 +1,5 @@ name: groundhog-mysql -version: 0.11 +version: 0.12 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -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