diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -31,6 +31,7 @@ import Data.Conduit import qualified Blaze.ByteString.Builder.Char8 as BBB +import qualified Blaze.ByteString.Builder.ByteString as BBS import qualified Data.Conduit.List as CL import qualified Data.Map as Map import qualified Data.Text as T @@ -48,7 +49,6 @@ import qualified Database.MySQL.Base.Types as MySQLBase - -- | Create a MySQL connection pool and run the given action. -- The pool is properly released after the action finishes using -- it. Note that you should not use the given 'ConnectionPool' @@ -108,8 +108,9 @@ -- This noLimit is suggested by MySQL's own docs, see -- , connRDBMS = "mysql" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" } - + -- | Prepare a query. We don't support prepared statements, but -- we'll do some client-side preprocessing here. prepare' :: MySQL.Connection -> Text -> IO Statement @@ -124,19 +125,20 @@ -- | SQL code to be executed when inserting an entity. -insertSql' :: DBName -> [DBName] -> DBName -> InsertSqlResult -insertSql' t cols _ = ISRInsertGet doInsert "SELECT LAST_INSERT_ID()" - where - doInsert = pack $ concat - [ "INSERT INTO " - , escapeDBName t - , "(" - , intercalate "," $ map escapeDBName cols - , ") VALUES(" - , intercalate "," (map (const "?") cols) - , ")" - ] - +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + let sql = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + in case entityPrimary ent of + Just _ -> ISRManyKeys sql vals + Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()" -- | Execute an statement that doesn't return any results. execute' :: MySQL.Connection -> MySQL.Query -> [PersistValue] -> IO Int64 @@ -200,6 +202,7 @@ render (P (PersistRational r)) = MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field + render (P (PersistDbSpecific s)) = MySQL.Plain $ BBS.fromByteString s render (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a MySQL value" @@ -247,6 +250,11 @@ -- Controversial conversions getGetter MySQLBase.Set = convertPV PersistText getGetter MySQLBase.Enum = convertPV PersistText +-- Conversion using PersistDbSpecific +getGetter MySQLBase.Geometry = \_ m -> + case m of + Just g -> PersistDbSpecific g + Nothing -> error "Unexpected null in database specific value" -- Unsupported getGetter other = error $ "MySQL.getGetter: type " ++ show other ++ " not supported." @@ -266,30 +274,45 @@ migrate' connectInfo allDefs getter val = do let name = entityDB val (idClmn, old) <- getColumns connectInfo getter val - let new = second (map udToPair) $ mkColumns allDefs val + let (newcols, udefs, fdefs) = mkColumns allDefs val + let udspair = map udToPair udefs case (idClmn, old, partitionEithers old) of -- Nothing found, create everything ([], [], _) -> do + let idtxt = case entityPrimary val of + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] + Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"] + let addTable = AddTable $ concat - [ "CREATE TABLE " + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " , escapeDBName name , "(" - , escapeDBName $ entityID val - , " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY" - , concatMap (\x -> ',' : showColumn x) $ fst new + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols , ")" ] - let uniques = flip concatMap (snd new) $ \(uname, ucols) -> + let uniques = flip concatMap udspair $ \(uname, ucols) -> [ AlterTable name $ AddUniqueConstraint uname $ map (findTypeOfColumn allDefs name) ucols ] let foreigns = do - Column cname _ _ _ _ (Just (refTblName, _)) <- fst new - return $ AlterColumn name (cname, addReference allDefs refTblName) - return $ Right $ map showAlterDb $ addTable : uniques ++ foreigns + Column { cName=cname, cReference=Just (refTblName, a) } <- newcols + return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) + + let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + + return $ Right $ map showAlterDb $ addTable : uniques ++ foreigns ++ foreignsAlt -- No errors and something found, migrate (_, _, ([], old')) -> do - let (acs, ats) = getAlters allDefs name new $ partitionEithers old' + let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of + Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of + Just _ -> c { cReference = Nothing } + Nothing -> c + Nothing -> c) xs,ys) + (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old' acs' = map (AlterColumn name) acs ats' = map (AlterTable name) ats return $ Right $ map showAlterDb $ acs' ++ ats' @@ -310,13 +333,13 @@ -- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> AlterColumn -addReference allDefs name = AddReference name id_ +addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference allDefs fkeyname reftable cname = AddReference reftable fkeyname [cname] [id_] where - id_ = maybe (error $ "Could not find ID of entity " ++ show name + id_ = maybe (error $ "Could not find ID of entity " ++ show reftable ++ " (allDefs = " ++ show allDefs ++ ")") id $ do - entDef <- find ((== name) . entityDB) allDefs + entDef <- find ((== reftable) . entityDB) allDefs return (entityID entDef) data AlterColumn = Change Column @@ -325,7 +348,7 @@ | Default String | NoDefault | Update' String - | AddReference DBName DBName + | AddReference DBName DBName [DBName] [DBName] | DropReference DBName type AlterColumn' = (DBName, AlterColumn) @@ -341,7 +364,6 @@ udToPair :: UniqueDef -> (DBName, [DBName]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) - ---------------------------------------------------------------------- @@ -385,13 +407,14 @@ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ \AND COLUMN_NAME <> ? \ + \AND CONSTRAINT_NAME <> 'PRIMARY' \ \AND REFERENCED_TABLE_SCHEMA IS NULL \ \ORDER BY CONSTRAINT_NAME, \ \COLUMN_NAME" us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs -- Return both - return $ (ids, cs ++ us) + return (ids, cs ++ us) where vals = [ PersistText $ pack $ MySQL.connectDatabase connectInfo , PersistText $ unDBName $ entityDB def @@ -442,7 +465,8 @@ -- Foreign key (if any) stmt <- lift $ getter "SELECT REFERENCED_TABLE_NAME, \ - \CONSTRAINT_NAME \ + \CONSTRAINT_NAME, \ + \ORDINAL_POSITION \ \FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE \ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ @@ -457,8 +481,8 @@ cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume ref <- case cntrs of [] -> return Nothing - [[PersistByteString tab, PersistByteString ref]] -> - return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> + return $ if pos == 1 then Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) else Nothing _ -> fail "MySQL.getColumn/getRef: never here" -- Okay! @@ -467,6 +491,7 @@ , cNull = null_ == "YES" , cSqlType = type_ , cDefault = default_ + , cDefaultConstraintName = Nothing , cMaxLen = Nothing -- FIXME: maxLen , cReference = ref } @@ -512,9 +537,8 @@ parseType "date" = return SqlDay parseType "newdate" = return SqlDay parseType "year" = return SqlDay --- Unsupported -parseType other = fail $ "MySQL.parseType: type " ++ - show other ++ " not supported." +-- Other +parseType b = return $ SqlOther $ T.decodeUtf8 b ---------------------------------------------------------------------- @@ -533,7 +557,7 @@ where getAltersC [] old = concatMap dropColumn old getAltersC (new:news) old = - let (alters, old') = findAlters allDefs new old + let (alters, old') = findAlters tblName allDefs new old in alters ++ getAltersC news old' dropColumn col = @@ -560,19 +584,21 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters allDefs col@(Column name isNull type_ def _maxLen ref) cols = +findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = case filter ((name ==) . cName) cols of - [] -> ( let cnstr = [addReference allDefs tname | Just (tname, _) <- [ref]] - in map ((,) name) (Add' col : cnstr) - , cols ) - Column _ isNull' type_' def' _maxLen' ref':_ -> + -- new fkey that didnt exist before + [] -> case ref of + Nothing -> ([],[]) + Just (tname, b) -> let cnstr = [addReference allDefs (refName tblName name) tname name] + in (map ((,) tname) (Add' col : cnstr), cols) + Column _ isNull' type_' def' defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of (False, Just (_, cname)) -> [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, _)) -> [(name, addReference allDefs tname)] + (False, Just (tname, cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability modType | type_ == type_' && isNull == isNull' = [] @@ -592,7 +618,7 @@ -- | Prints the part of a @CREATE TABLE@ statement about a given -- column. showColumn :: Column -> String -showColumn (Column n nu t def maxLen ref) = concat +showColumn (Column n nu t def defConstraintName maxLen ref) = concat [ escapeDBName n , " " , showSqlType t maxLen @@ -663,14 +689,14 @@ -- | Render an action that must be done on a column. showAlter :: DBName -> AlterColumn' -> String -showAlter table (oldName, Change (Column n nu t def maxLen _ref)) = +showAlter table (oldName, Change (Column n nu t def defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table , " CHANGE " , escapeDBName oldName , " " - , showColumn (Column n nu t def maxLen Nothing) + , showColumn (Column n nu t def defConstraintName maxLen Nothing) ] showAlter table (_, Add' col) = concat @@ -715,17 +741,17 @@ , escapeDBName n , " IS NULL" ] -showAlter table (n, AddReference t2 id2) = concat +showAlter table (_, AddReference reftable fkeyname t2 id2) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " - , escapeDBName $ refName table n + , escapeDBName fkeyname , " FOREIGN KEY(" - , escapeDBName n + , intercalate "," $ map escapeDBName t2 , ") REFERENCES " - , escapeDBName t2 + , escapeDBName reftable , "(" - , escapeDBName id2 + , intercalate "," $ map escapeDBName id2 , ")" ] showAlter table (_, DropReference cname) = concat @@ -738,7 +764,6 @@ refName :: DBName -> DBName -> DBName refName (DBName table) (DBName column) = DBName $ T.concat [table, "_", column, "_fkey"] - ---------------------------------------------------------------------- diff --git a/persistent-mysql.cabal b/persistent-mysql.cabal --- a/persistent-mysql.cabal +++ b/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 1.2.1 +version: 1.3.0 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -29,7 +29,7 @@ , mysql-simple >= 0.2.2.3 && < 0.3 , mysql >= 0.1.1.3 && < 0.2 , blaze-builder - , persistent >= 1.2 && < 1.3 + , persistent >= 1.3 && < 1.4 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.11.0.6