groundhog-mysql 0.3.0.1 → 0.4.0

raw patch · 2 files changed

+79/−68 lines, 2 filesdep +monad-loggerdep ~groundhogdep ~monad-controldep ~resource-poolPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-logger

Dependency ranges changed: groundhog, monad-control, resource-pool, text, transformers

API changes (from Hackage documentation)

Files

• Database/Groundhog/MySQL.hs +72/−62
• groundhog-mysql.cabal +7/−6

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-} module Database.Groundhog.MySQL     ( withMySQLPool     , withMySQLConn@@ -31,17 +31,18 @@ import qualified Database.MySQL.Base.Types    as MySQLBase  import Control.Arrow ((***))-import Control.Monad (liftM, liftM2)+import Control.Monad (liftM, liftM2, (>=>)) import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger (MonadLogger, logDebugS) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ask) import Data.ByteString.Char8 (ByteString) import Data.Char (toUpper)-import Data.Either (partitionEithers) import Data.Function (on) import Data.Int (Int64)-import Data.List (groupBy, intercalate, partition)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (groupBy, intercalate, intersect, partition, stripPrefix) import Data.Maybe (fromJust, fromMaybe) import Data.Pool @@ -55,8 +56,7 @@ instance SqlDb MySQL where   append a b = Expr $ function "concat" [toExpr a, toExpr b] -instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist MySQL m) where-  {-# SPECIALIZE instance PersistBackend (DbPersist MySQL IO) #-}+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => PersistBackend (DbPersist MySQL m) where   type PhantomDb (DbPersist MySQL m) = MySQL   insert v = insert' v   insert_ v = insert_' v@@ -81,7 +81,7 @@   insertList l = insertList' l   getList k = getList' k -instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist MySQL m) where+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist MySQL m) where   listTables schema = queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,database())" [toPrimitivePersistValue proxy schema] (mapAllRows $ return . fst . fromPurePersistValues proxy)   listTableTriggers schema name = queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,database()) AND event_object_table=?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)   analyzeTable = analyzeTable'@@ -140,8 +140,7 @@ close' :: MySQL -> IO () close' (MySQL conn) = MySQL.close conn -{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist MySQL IO (AutoKey v) #-}-insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist MySQL m (AutoKey v)+insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist MySQL m (AutoKey v) insert' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -165,8 +164,7 @@       executeRaw' cQuery (vals' [])       pureFromPersistValue [rowid] -{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist MySQL IO () #-}-insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist MySQL m ()+insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist MySQL m () insert_' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -186,7 +184,6 @@       let RenderS cQuery vals' = insertIntoConstructorTable True (tableName escapeS e constr) constr (rowid:tail vals)       executeRaw' cQuery (vals' []) --- TODO: In Sqlite we can insert null to the id column. If so, id will be generated automatically. Check performance change from this. insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r insertIntoConstructorTable withId tName c vals = RenderS query vals' where   query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")"@@ -196,7 +193,7 @@   fieldNames   = renderFields escapeS fields   RenderS placeholders vals' = commasJoin $ map renderPersistValue vals -insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist MySQL m Int64+insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist MySQL m Int64 insertList' (l :: [a]) = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   executeRaw' ("INSERT INTO " <> escapeS mainName <> "()VALUES()") []@@ -213,7 +210,7 @@   go 0 l   return $ fromPrimitivePersistValue proxy k   -getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist MySQL m [a]+getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => Int64 -> DbPersist MySQL m [a] getList' k = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   let valuesName = mainName <> delim' <> "values"@@ -221,17 +218,16 @@   let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"   queryRaw' query [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues) -{-# SPECIALIZE getLastInsertId :: DbPersist MySQL IO PersistValue #-}-getLastInsertId :: (MonadBaseControl IO m, MonadIO m) => DbPersist MySQL m PersistValue+getLastInsertId :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => DbPersist MySQL m PersistValue getLastInsertId = do   x <- queryRaw' "SELECT last_insert_id()" [] id   return $ maybe (error "getLastInsertId: Nothing") head x  ---------- -executeRaw' :: MonadIO m => Utf8 -> [PersistValue] -> DbPersist MySQL m ()+executeRaw' :: (MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> DbPersist MySQL m () executeRaw' query vals = do-  --liftIO $ print $ fromUtf8 query ""+  $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals   MySQL conn <- DbPersist ask   let stmt = getStatement query   liftIO $ do@@ -249,34 +245,34 @@ delim' :: Utf8 delim' = fromChar delim -toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist MySQL m [PersistValue]+toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistEntity v) => v -> DbPersist MySQL m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues  --- MIGRATION -migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist MySQL m)+migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist MySQL m) migrate' v = do   x <- lift $ queryRaw' "SELECT database()" [] id   let schema = fst $ fromPurePersistValues proxy $ fromJust x   migrateRecursively (migrateEntity $ migrationPack schema) (migrateList $ migrationPack schema) v -migrationPack :: (MonadBaseControl IO m, MonadIO m) => String -> GM.MigrationPack (DbPersist MySQL m)+migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist MySQL m) migrationPack currentSchema = GM.MigrationPack   compareTypes   (compareRefs currentSchema)   compareUniqs+  compareDefaults   migTriggerOnDelete   migTriggerOnUpdate   GM.defaultMigConstr   escape-  DbInt64   "BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"-  "BIGINT"   mainTableId   defaultPriority   (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))   showColumn   (showAlterDb currentSchema)+  Restrict  showColumn :: Column -> String showColumn (Column n nu t def) = concat@@ -290,7 +286,7 @@         Just s  -> " DEFAULT " ++ s     ] -migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist MySQL m (Bool, [AlterDB])+migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist MySQL m (Bool, [AlterDB]) migTriggerOnDelete schema name deletes = do   let addTrigger = AddTriggerOnDelete schema name schema name (concatMap snd deletes)   x <- analyzeTrigger schema name@@ -306,7 +302,7 @@  -- | Schema name, table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields-migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist MySQL m [(Bool, [AlterDB])]+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist MySQL m [(Bool, [AlterDB])] migTriggerOnUpdate schema name deletes = do   let trigName = name ++ "_ON_UPDATE"       f (fieldName, del) = "IF NOT (NEW." ++ escape fieldName ++ " <=> OLD." ++ escape fieldName ++ ") THEN " ++ del ++ " END IF;"@@ -323,7 +319,7 @@         -- this can happen when an ephemeral field was added or removed.         else [DropTrigger schema trigName schema name, addTrigger])   -analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist MySQL m (Either [String] (Maybe TableInfo))+analyzeTable' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist MySQL m (Maybe TableInfo) analyzeTable' schema name = do   table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, database()) AND table_name = ?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] id   case table of@@ -335,7 +331,6 @@ \  ORDER BY c.ordinal_position"        cols <- queryRaw' colQuery [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy)-      let (col_errs, cols') = partitionEithers cols       -- 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 [toPrimitivePersistValue proxy ("UNIQUE" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)@@ -343,16 +338,14 @@       let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)       let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniquePrimary uniqPrimary       references <- analyzeTableReferences schema name-      return $ case col_errs of-        []   -> Right $ Just $ TableInfo cols' uniqs references-        errs -> Left errs-    Nothing -> return $ Right Nothing+      return $ Just $ TableInfo cols uniqs references+    Nothing -> return Nothing -getColumn :: String -> ((String, String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int)) -> Either String Column-getColumn _ ((column_name, is_nullable, data_type, column_type, d), modifiers) = Right $ Column column_name (is_nullable == "YES") t d where+getColumn :: String -> ((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 -analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist MySQL m [(Maybe String, Reference)]+analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist MySQL m [(Maybe String, Reference)] analyzeTableReferences schema tName = do   let sql = "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)\@@ -468,7 +461,7 @@ showAlterTable _ table (DropReference name) = [(False, defaultPriority,     "ALTER TABLE " ++ table ++ " DROP CONSTRAINT " ++ name)] -readSqlType :: String -> String -> (Maybe Int, Maybe Int, Maybe Int) -> DbType+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@@ -487,22 +480,20 @@   ) where     numAttrs = (numeric_precision, numeric_scale) -showSqlType :: DbType -> String-showSqlType DbString = "TEXT CHARACTER SET utf8"-showSqlType DbInt32 = "INT"-showSqlType DbInt64 = "BIGINT"-showSqlType DbReal = "DOUBLE PRECISION"-showSqlType DbBool = "TINYINT(1)"-showSqlType DbDay = "DATE"-showSqlType DbTime = "TIME"-showSqlType DbDayTime = "DATETIME"-showSqlType DbDayTimeZoned = "VARCHAR(50) CHARACTER SET utf8"-showSqlType DbBlob = "BLOB"-showSqlType (DbOther (OtherTypeDef f)) = f showSqlType-showSqlType (DbMaybe t) = showSqlType t-showSqlType (DbList _ _) = showSqlType DbInt64-showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64-showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t+showSqlType :: DbTypePrimitive -> String+showSqlType t = case t of+  DbString -> "TEXT CHARACTER SET utf8"+  DbInt32 -> "INT"+  DbInt64 -> "BIGINT"+  DbReal -> "DOUBLE PRECISION"+  DbBool -> "TINYINT(1)"+  DbDay -> "DATE"+  DbTime -> "TIME"+  DbDayTime -> "DATETIME"+  DbDayTimeZoned -> "VARCHAR(50) CHARACTER SET utf8"+  DbBlob -> "BLOB"+  DbOther (OtherTypeDef f) -> f showSqlType+  DbAutoKey -> showSqlType DbInt64  compareUniqs :: UniqueDef' -> UniqueDef' -> Bool compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2@@ -519,12 +510,17 @@   && fromMaybe Restrict onUpd1 == fromMaybe Restrict onUpd2 where     unescape name = if head name == '"' && last name == '"' then tail $ init name else name -compareTypes :: DbType -> DbType -> Bool+compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool compareTypes type1 type2 = f type1 == f type2 where   f = map toUpper . showSqlType . hack   hack DbDayTimeZoned = DbOther $ OtherTypeDef $ const "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+ defaultPriority, referencePriority, functionPriority, triggerPriority :: Int defaultPriority = 0 referencePriority = 1@@ -543,24 +539,38 @@ getStatement :: Utf8 -> MySQL.Query getStatement sql = MySQL.Query $ fromUtf8 sql -queryRawTyped' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist MySQL m) -> DbPersist MySQL m a) -> DbPersist MySQL m a+queryRawTyped' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist MySQL m) -> DbPersist MySQL m a) -> DbPersist MySQL m a queryRawTyped' query _ vals f = queryRaw' query vals f -queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist MySQL m) -> DbPersist MySQL m a) -> DbPersist MySQL m a+queryRaw' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist MySQL m) -> DbPersist MySQL m a) -> DbPersist MySQL m a queryRaw' query vals func = do+  $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals   MySQL conn <- DbPersist ask   liftIO $ MySQL.formatQuery conn (getStatement query) (map P vals) >>= MySQLBase.query conn   result <- liftIO $ MySQLBase.storeResult conn   -- Find out the type of the columns   fields <- liftIO $ MySQLBase.fetchFields result-  let getters = [ maybe PersistNull (getGetter (MySQLBase.fieldType f) f . Just) | f <- fields]-  x <- func $ do-    row <- liftIO $ MySQLBase.fetchRow result-    case row of-      [] -> return Nothing -- Do not free the result per sourceIO's docs.-      _  -> return $ Just $ zipWith ($) getters row-  liftIO $ MySQLBase.freeResult result-  return x+  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 <- liftIO $ flip finally (MySQLBase.freeResult result) (go id) >>= newIORef+  func $ do+    rows <- liftIO $ readIORef rowsVar+    case rows of+      [] -> return Nothing+      (x:xs) -> do+        liftIO $ writeIORef rowsVar xs+        return $ Just x  -- | Avoid orphan instances. newtype P = P PersistValue

@@ -1,5 +1,5 @@ name:            groundhog-mysql-version:         0.3.0.1+version:         0.4.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -16,12 +16,13 @@                    , mysql-simple            >= 0.2.2.3   && < 0.3                    , mysql                   >= 0.1.1.3   && < 0.2                    , bytestring              >= 0.9-                   , transformers            >= 0.2.1     && < 0.4-                   , groundhog               >= 0.3.0     && < 0.4.0-                   , monad-control           >= 0.3       && < 0.4+                   , transformers            >= 0.2.1+                   , groundhog               >= 0.4.0     && < 0.5.0+                   , monad-control           >= 0.3+                   , monad-logger            >= 0.3                    , containers              >= 0.2-                   , text                    >= 0.8       && < 0.12-                   , resource-pool           >= 0.2.1     && < 0.3+                   , text                    >= 0.8+                   , resource-pool           >= 0.2.1                    , time                    >= 1.1     exposed-modules: Database.Groundhog.MySQL     ghc-options:     -Wall -fno-warn-unused-do-bind