groundhog-mysql 0.5.1 → 0.6.0
raw patch · 3 files changed
+28/−23 lines, 3 filesdep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: groundhog
API changes (from Hackage documentation)
Files
- Database/Groundhog/MySQL.hs +22/−21
- changelog +4/−0
- groundhog-mysql.cabal +2/−2
Database/Groundhog/MySQL.hs view
@@ -109,6 +109,7 @@ case x of Nothing -> return Nothing Just src -> return (fst $ fromPurePersistValues proxy src)+ getMigrationPack = fmap (migrationPack . fromJust) getCurrentSchema withMySQLPool :: (MonadBaseControl IO m, MonadIO m) => MySQL.ConnectInfo@@ -164,7 +165,7 @@ insert' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v- let e = entityDef v+ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue proxy (head vals) liftM fst $ if isSimple (constructors e)@@ -188,7 +189,7 @@ insert_' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v- let e = entityDef v+ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue proxy (head vals) if isSimple (constructors e)@@ -208,7 +209,7 @@ insertIntoConstructorTable withId tName c vals = RenderS query vals' where query = "INSERT INTO " <> tName <> columnsValues fields = case constrAutoKeyName c of- Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c+ Just idName | withId -> (idName, dbType proxy (0 :: Int64)):constrParams c _ -> constrParams c columnsValues = case foldr (flatten escapeS) [] fields of [] -> "() VALUES ()"@@ -221,7 +222,7 @@ executeRaw' ("INSERT INTO " <> escapeS mainName <> "()VALUES()") [] k <- getLastInsertId let valuesName = mainName <> delim' <> "values"- let fields = [("ord", dbType (0 :: Int)), ("value", dbType (undefined :: a))]+ 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] -> DbPersist MySQL m () go n (x:xs) = do@@ -236,7 +237,7 @@ getList' k = do let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a)) let valuesName = mainName <> delim' <> "values"- let value = ("value", dbType (undefined :: a))+ let value = ("value", dbType proxy (undefined :: a)) let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord" queryRaw' query [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues) @@ -274,8 +275,7 @@ migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist MySQL m) migrate' v = do- schema <- lift getCurrentSchema- let migPack = migrationPack $ fromJust schema+ migPack <- lift getMigrationPack migrateRecursively (migrateSchema migPack) (migrateEntity migPack) (migrateList migPack) v migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist MySQL m)@@ -292,9 +292,11 @@ 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@@ -356,7 +358,7 @@ 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 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@@ -432,31 +434,31 @@ ])] f _ = [] (updates, other) = partition (\a -> case a of UpdateValue _ -> True; _ -> False) alts-showAlterTable _ table (AddUnique (UniqueDef' uName UniqueConstraint cols)) = [(False, defaultPriority, concat+showAlterTable _ table (AddUnique (UniqueDef uName UniqueConstraint cols)) = [(False, defaultPriority, concat [ "ALTER TABLE " , table , " ADD" , maybe "" ((" CONSTRAINT " ++) . escape) uName , " UNIQUE("- , intercalate "," $ map escape cols+ , intercalate "," $ map (either escape id) cols , ")" ])]-showAlterTable _ table (AddUnique (UniqueDef' uName UniqueIndex cols)) = [(False, defaultPriority, concat+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 escape cols+ , intercalate "," $ map (either escape id) 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" , maybe "" ((" CONSTRAINT " ++) . escape) uName , " PRIMARY KEY("- , intercalate "," $ map escape cols+ , intercalate "," $ map (either escape id) cols , ")" ])] showAlterTable _ table (DropConstraint uName) = [(False, defaultPriority, concat@@ -502,7 +504,7 @@ "time" -> DbTime _ | typ `elem` ["datetime", "timestamp"] -> DbDayTime _ | typ `elem` ["date", "newdate", "year"] -> DbDay- _ -> DbOther $ OtherTypeDef $ const colTyp+ _ -> DbOther $ OtherTypeDef [Left colTyp] ) where numAttrs = (numeric_precision, numeric_scale) @@ -518,12 +520,11 @@ DbDayTime -> "DATETIME" DbDayTimeZoned -> "VARCHAR(50) CHARACTER SET utf8" DbBlob -> "BLOB"- DbOther (OtherTypeDef f) -> f showSqlType- DbAutoKey -> showSqlType DbInt64+ DbOther (OtherTypeDef ts) -> concatMap (either id showSqlType) ts -compareUniqs :: UniqueDef' -> UniqueDef' -> 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 :: 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 compareRefs :: String -> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool compareRefs currentSchema (_, Reference sch1 tbl1 pairs1 onDel1 onUpd1) (_, Reference sch2 tbl2 pairs2 onDel2 onUpd2) =@@ -537,7 +538,7 @@ 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 DbDayTimeZoned = DbOther $ OtherTypeDef [Left "VARCHAR(50)"] hack t = t compareDefaults :: String -> String -> Bool
changelog view
@@ -1,3 +1,7 @@+0.6.0+* Entity and fields descriptions are parameterized so that they can be promoted+* Entity and fields descriptions are dependent on database proxy. It allows to use different types depending on a database, for example, the same type can be array[] in PostgreSQL and varchar elsewhere+ 0.5.1 * Add getCurrentSchema function into SchemaAnalyzer
groundhog-mysql.cabal view
@@ -1,5 +1,5 @@ name: groundhog-mysql-version: 0.5.1+version: 0.6.0 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -20,7 +20,7 @@ , mysql >= 0.1.1.3 && < 0.2 , bytestring >= 0.9 , transformers >= 0.2.1 && < 0.5- , groundhog >= 0.5.0 && < 0.6.0+ , groundhog >= 0.6 && < 0.7 , monad-control >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4 , containers >= 0.2