persistent-mysql 1.2.1 → 1.3.0
raw patch · 2 files changed
+82/−57 lines, 2 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/MySQL.hs +80/−55
- persistent-mysql.cabal +2/−2
Database/Persist/MySQL.hs view
@@ -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 -- <http://dev.mysql.com/doc/refman/5.5/en/select.html> , 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"]- ----------------------------------------------------------------------
persistent-mysql.cabal view
@@ -1,5 +1,5 @@ name: persistent-mysql-version: 1.2.1+version: 1.3.0 license: MIT license-file: LICENSE author: Felipe Lessa <felipe.lessa@gmail.com>, 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