groundhog-mysql 0.5.0 → 0.5.1
raw patch · 3 files changed
+42/−33 lines, 3 filesdep ~monad-controldep ~monad-loggerdep ~transformersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: monad-control, monad-logger, transformers
API changes (from Hackage documentation)
Files
- Database/Groundhog/MySQL.hs +26/−20
- changelog +3/−0
- groundhog-mysql.cabal +13/−13
Database/Groundhog/MySQL.hs view
@@ -31,7 +31,7 @@ import qualified Database.MySQL.Base as MySQLBase import qualified Database.MySQL.Base.Types as MySQLBase -import Control.Arrow ((***))+import Control.Arrow (first, (***)) import Control.Monad (liftM, liftM2, (>=>)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Logger (MonadLogger, logDebugS)@@ -43,8 +43,9 @@ import Data.Function (on) import Data.Int (Int64) import Data.IORef (newIORef, readIORef, writeIORef)-import Data.List (groupBy, intercalate, intersect, partition, stripPrefix)+import Data.List (groupBy, intercalate, intersect, isInfixOf, partition, stripPrefix) import Data.Maybe (fromJust, fromMaybe, isJust)+import Data.Monoid import Data.Pool newtype MySQL = MySQL MySQL.Connection@@ -73,7 +74,7 @@ insertByAll v = H.insertByAll renderConfig queryRaw' True v replace k v = H.replace renderConfig queryRaw' executeRaw' insertIntoConstructorTable k v replaceBy k v = H.replaceBy renderConfig executeRaw' k v- select options = H.select renderConfig queryRaw' noLimit options+ select options = H.select renderConfig queryRaw' preColumns noLimit options selectAll = H.selectAll renderConfig queryRaw' get k = H.get renderConfig queryRaw' k getBy k = H.getBy renderConfig queryRaw' k@@ -83,7 +84,7 @@ deleteAll v = H.deleteAll renderConfig executeRaw' v count cond = H.count renderConfig queryRaw' cond countAll fakeV = H.countAll renderConfig queryRaw' fakeV- project p options = H.project renderConfig queryRaw' noLimit p options+ project p options = H.project renderConfig queryRaw' preColumns noLimit p options migrate fakeV = migrate' fakeV executeRaw _ query ps = executeRaw' (fromString query) ps@@ -94,6 +95,7 @@ instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist MySQL m) where schemaExists schema = queryRaw' "SELECT 1 FROM information_schema.schemata WHERE schema_name=?" [toPrimitivePersistValue proxy schema] (fmap isJust)+ getCurrentSchema = queryRaw' "SELECT database()" [] (fmap (>>= fst . fromPurePersistValues proxy)) 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'@@ -204,11 +206,13 @@ insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r insertIntoConstructorTable withId tName c vals = RenderS query vals' where- query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")"+ query = "INSERT INTO " <> tName <> columnsValues fields = case constrAutoKeyName c of Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c _ -> constrParams c- fieldNames = renderFields escapeS fields+ columnsValues = case foldr (flatten escapeS) [] fields of+ [] -> "() VALUES ()"+ xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")" RenderS placeholders vals' = commasJoin $ map renderPersistValue vals insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist MySQL m Int64@@ -270,9 +274,8 @@ 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- migPack = migrationPack schema+ schema <- lift getCurrentSchema+ let migPack = migrationPack $ fromJust schema migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist MySQL m)@@ -343,25 +346,27 @@ 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 Just _ -> do- -- omit primary keys- 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\+ 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 [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy)+ cols <- queryRaw' colQuery [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . first getColumn . fst . fromPurePersistValues proxy) -- 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) uniqPrimary <- queryRaw' constraintQuery [toPrimitivePersistValue proxy ("PRIMARY KEY" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy) let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)- let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniquePrimary uniqPrimary+ 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+ uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs (UniquePrimary isAutoincremented) uniqPrimary references <- analyzeTableReferences schema name- return $ Just $ TableInfo cols uniqs references+ return $ Just $ TableInfo (map fst cols) uniqs references Nothing -> return Nothing -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+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 analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist MySQL m [(Maybe String, Reference)]@@ -445,7 +450,7 @@ , intercalate "," $ map escape cols , ")" ])]-showAlterTable _ table (AddUnique (UniqueDef' uName UniquePrimary cols)) = [(False, defaultPriority, concat+showAlterTable _ table (AddUnique (UniqueDef' uName (UniquePrimary _) cols)) = [(False, defaultPriority, concat [ "ALTER TABLE " , table , " ADD"@@ -517,9 +522,7 @@ DbAutoKey -> showSqlType DbInt64 compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2--- only one of the uniques is primary-compareUniqs (UniqueDef' _ type1 _) (UniqueDef' _ type2 _) | UniquePrimary `elem` [type1, type2] = False+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 compareRefs :: String -> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool@@ -657,3 +660,6 @@ withSchema :: Maybe String -> String -> String withSchema sch name = maybe "" (\x -> escape x ++ ".") sch ++ escape name++preColumns :: HasSelectOptions opts db r => opts -> RenderS db r+preColumns _ = mempty
changelog view
@@ -1,3 +1,6 @@+0.5.1+* Add getCurrentSchema function into SchemaAnalyzer+ 0.5.0 * Compatibility with GHC 7.8
groundhog-mysql.cabal view
@@ -1,5 +1,5 @@ name: groundhog-mysql-version: 0.5.0+version: 0.5.1 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -15,17 +15,17 @@ changelog library- build-depends: base >= 4 && < 5- , mysql-simple >= 0.2.2.3 && < 0.3- , mysql >= 0.1.1.3 && < 0.2- , bytestring >= 0.9- , transformers >= 0.2.1- , groundhog >= 0.5.0 && < 0.6.0- , monad-control >= 0.3- , monad-logger >= 0.3- , containers >= 0.2- , text >= 0.8- , resource-pool >= 0.2.1- , time >= 1.1+ build-depends: base >= 4 && < 5+ , mysql-simple >= 0.2.2.3 && < 0.3+ , mysql >= 0.1.1.3 && < 0.2+ , bytestring >= 0.9+ , transformers >= 0.2.1 && < 0.5+ , groundhog >= 0.5.0 && < 0.6.0+ , monad-control >= 0.3 && < 0.4+ , monad-logger >= 0.3 && < 0.4+ , containers >= 0.2+ , text >= 0.8+ , resource-pool >= 0.2.1+ , time >= 1.1 exposed-modules: Database.Groundhog.MySQL ghc-options: -Wall -fno-warn-unused-do-bind