persistent-mysql 2.2 → 2.3
raw patch · 3 files changed
+185/−79 lines, 3 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Database.Persist.MySQL: mockMigration :: Migration -> IO ()
Files
- ChangeLog.md +6/−0
- Database/Persist/MySQL.hs +177/−78
- persistent-mysql.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,9 @@+## 2.3++* Distinguish between binary and non-binary strings in MySQL [451](https://github.com/yesodweb/persistent/pull/451)+ * Previously all string columns (VARCHAR, TEXT, etc.) were being returned from Persistent as `PersistByteString`s (i.e. as binary data). Persistent now checks character set information to determine if the value should be returned as `PersistText` or `PersistByteString`. + * This is a **breaking change** if your code is relying on a `PersistByteString` being returned for string-like MySQL values; persistent-mysql itself had several runtime errors that needed to be fixed because of this patch. High-level code dealing purely with `PersistEntities` should be unaffected.+ ## 2.2 * Update to persistent 2.2
Database/Persist/MySQL.hs view
@@ -12,6 +12,7 @@ , MySQL.defaultConnectInfo , MySQLBase.defaultSSLInfo , MySQLConf(..)+ , mockMigration ) where import Control.Arrow@@ -19,6 +20,8 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Error (ErrorT(..))+import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Trans.Writer (runWriterT) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString)@@ -28,6 +31,7 @@ import Data.IORef import Data.List (find, intercalate, sort, groupBy) import Data.Text (Text, pack)+import qualified Data.Text.IO as T import Text.Read (readMaybe) import System.Environment (getEnvironment) import Data.Acquire (Acquire, mkAcquire, with)@@ -51,7 +55,7 @@ import qualified Database.MySQL.Base as MySQLBase import qualified Database.MySQL.Base.Types as MySQLBase import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResource, runResourceT)+import Control.Monad.Trans.Resource (runResourceT) -- | Create a MySQL connection pool and run the given action.@@ -94,7 +98,7 @@ -- | Internal function that opens a connection to the MySQL -- server.-open' :: MySQL.ConnectInfo -> LogFunc -> IO Connection+open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit!@@ -172,7 +176,7 @@ fetchRows result = liftIO $ do -- Find out the type of the columns fields <- MySQLBase.fetchFields result- let getters = [ maybe PersistNull (getGetter (MySQLBase.fieldType f) f . Just) | f <- fields]+ let getters = [ maybe PersistNull (getGetter f f . Just) | f <- fields] convert = use getters where use (g:gs) (col:cols) = let v = g col@@ -224,49 +228,69 @@ -- | Get the corresponding @'Getter' 'PersistValue'@ depending on -- the type of the column.-getGetter :: MySQLBase.Type -> Getter PersistValue--- Bool-getGetter MySQLBase.Tiny = convertPV PersistBool--- Int64-getGetter MySQLBase.Int24 = convertPV PersistInt64-getGetter MySQLBase.Short = convertPV PersistInt64-getGetter MySQLBase.Long = convertPV PersistInt64-getGetter MySQLBase.LongLong = convertPV PersistInt64--- Double-getGetter MySQLBase.Float = convertPV PersistDouble-getGetter MySQLBase.Double = convertPV PersistDouble-getGetter MySQLBase.Decimal = convertPV PersistDouble-getGetter MySQLBase.NewDecimal = convertPV PersistDouble--- ByteString and Text-getGetter MySQLBase.VarChar = convertPV PersistByteString-getGetter MySQLBase.VarString = convertPV PersistByteString-getGetter MySQLBase.String = convertPV PersistByteString-getGetter MySQLBase.Blob = convertPV PersistByteString-getGetter MySQLBase.TinyBlob = convertPV PersistByteString-getGetter MySQLBase.MediumBlob = convertPV PersistByteString-getGetter MySQLBase.LongBlob = convertPV PersistByteString--- Time-related-getGetter MySQLBase.Time = convertPV PersistTimeOfDay-getGetter MySQLBase.DateTime = convertPV PersistUTCTime-getGetter MySQLBase.Timestamp = convertPV PersistUTCTime-getGetter MySQLBase.Date = convertPV PersistDay-getGetter MySQLBase.NewDate = convertPV PersistDay-getGetter MySQLBase.Year = convertPV PersistDay--- Null-getGetter MySQLBase.Null = \_ _ -> PersistNull--- 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."+getGetter :: MySQLBase.Field -> Getter PersistValue+getGetter field = go (MySQLBase.fieldType field) (MySQLBase.fieldCharSet field)+ where+ -- Bool+ go MySQLBase.Tiny _ = convertPV PersistBool+ -- Int64+ go MySQLBase.Int24 _ = convertPV PersistInt64+ go MySQLBase.Short _ = convertPV PersistInt64+ go MySQLBase.Long _ = convertPV PersistInt64+ go MySQLBase.LongLong _ = convertPV PersistInt64+ -- Double+ go MySQLBase.Float _ = convertPV PersistDouble+ go MySQLBase.Double _ = convertPV PersistDouble+ go MySQLBase.Decimal _ = convertPV PersistDouble+ go MySQLBase.NewDecimal _ = convertPV PersistDouble + -- ByteString and Text + -- The MySQL C client (and by extension the Haskell mysql package) doesn't distinguish between binary and non-binary string data at the type level.+ -- (e.g. both BLOB and TEXT have the MySQLBase.Blob type).+ -- Instead, the character set distinguishes them. Binary data uses character set number 63.+ -- See https://dev.mysql.com/doc/refman/5.6/en/c-api-data-structures.html (Search for "63")+ go MySQLBase.VarChar 63 = convertPV PersistByteString+ go MySQLBase.VarString 63 = convertPV PersistByteString+ go MySQLBase.String 63 = convertPV PersistByteString++ go MySQLBase.VarChar _ = convertPV PersistText+ go MySQLBase.VarString _ = convertPV PersistText+ go MySQLBase.String _ = convertPV PersistText+ + go MySQLBase.Blob 63 = convertPV PersistByteString+ go MySQLBase.TinyBlob 63 = convertPV PersistByteString+ go MySQLBase.MediumBlob 63 = convertPV PersistByteString+ go MySQLBase.LongBlob 63 = convertPV PersistByteString++ go MySQLBase.Blob _ = convertPV PersistText+ go MySQLBase.TinyBlob _ = convertPV PersistText+ go MySQLBase.MediumBlob _ = convertPV PersistText+ go MySQLBase.LongBlob _ = convertPV PersistText++ -- Time-related+ go MySQLBase.Time _ = convertPV PersistTimeOfDay+ go MySQLBase.DateTime _ = convertPV PersistUTCTime+ go MySQLBase.Timestamp _ = convertPV PersistUTCTime+ go MySQLBase.Date _ = convertPV PersistDay+ go MySQLBase.NewDate _ = convertPV PersistDay+ go MySQLBase.Year _ = convertPV PersistDay+ -- Null+ go MySQLBase.Null _ = \_ _ -> PersistNull+ -- Controversial conversions+ go MySQLBase.Set _ = convertPV PersistText+ go MySQLBase.Enum _ = convertPV PersistText+ -- Conversion using PersistDbSpecific+ go MySQLBase.Geometry _ = \_ m ->+ case m of+ Just g -> PersistDbSpecific g+ Nothing -> error "Unexpected null in database specific value"+ -- Unsupported+ go other _ = error $ "MySQL.getGetter: type " +++ show other ++ " not supported."+++ ---------------------------------------------------------------------- @@ -285,32 +309,18 @@ 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 . fieldDB) $ compositeFields pdef, ")"]- Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"]-- let addTable = AddTable $ concat- -- Lower case e: see Database.Persist.Sql.Migration- [ "CREATe TABLE "- , escapeDBName name- , "("- , idtxt- , if null newcols then [] else ","- , intercalate "," $ map showColumn newcols- , ")"- ] let uniques = flip concatMap udspair $ \(uname, ucols) -> [ AlterTable name $ AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do- Column { cName=cname, cReference=Just (refTblName, a) } <- newcols+ 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+ return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt -- No errors and something found, migrate (_, _, ([], old')) -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of@@ -330,6 +340,22 @@ (_, ml) = findMaxLenOfColumn allDefs tblName col in (col', ty, ml) +addTable :: [Column] -> EntityDef -> AlterDB+addTable cols entity = AddTable $ concat+ -- Lower case e: see Database.Persist.Sql.Migration+ [ "CREATe TABLE "+ , escapeDBName name+ , "("+ , idtxt+ , if null cols then [] else ","+ , intercalate "," $ map showColumn cols+ , ")"+ ]+ where+ name = entityDB entity+ idtxt = case entityPrimary entity of+ Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"]+ Nothing -> concat [escapeDBName $ fieldDB $ entityId entity, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"] -- | Find out the type of a column. findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType)@@ -447,9 +473,8 @@ getColumn connectInfo getter (entityDB def) helperCntrs = do- let check [ PersistByteString cntrName- , PersistByteString clmnName] = return ( T.decodeUtf8 cntrName- , T.decodeUtf8 clmnName )+ let check [ PersistText cntrName+ , PersistText clmnName] = return ( cntrName, clmnName ) check other = fail $ "helperCntrs: unexpected " ++ show other rows <- mapM check =<< CL.consume return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))@@ -462,9 +487,9 @@ -> DBName -> [PersistValue] -> IO (Either Text Column)-getColumn connectInfo getter tname [ PersistByteString cname- , PersistByteString null_- , PersistByteString type'+getColumn connectInfo getter tname [ PersistText cname+ , PersistText null_+ , PersistText type' , default'] = fmap (either (Left . pack) Right) $ runErrorT $ do@@ -493,18 +518,18 @@ \COLUMN_NAME" let vars = [ PersistText $ pack $ MySQL.connectDatabase connectInfo , PersistText $ unDBName $ tname- , PersistByteString cname+ , PersistText cname , PersistText $ pack $ MySQL.connectDatabase connectInfo ] cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing- [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] ->- return $ if pos == 1 then Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) else Nothing+ [[PersistText tab, PersistText ref, PersistInt64 pos]] ->+ return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing _ -> fail "MySQL.getColumn/getRef: never here" -- Okay! return Column- { cName = DBName $ T.decodeUtf8 cname+ { cName = DBName $ cname , cNull = null_ == "YES" , cSqlType = parseType type' , cDefault = default_@@ -519,7 +544,7 @@ -- | Parse the type of column as returned by MySQL's -- @INFORMATION_SCHEMA@ tables.-parseType :: ByteString -> SqlType+parseType :: Text -> SqlType parseType "bigint(20)" = SqlInt64 parseType "decimal(32,20)" = SqlNumeric 32 20 {-@@ -558,7 +583,7 @@ --parseType "newdate" = SqlDay --parseType "year" = SqlDay -}-parseType b = SqlOther $ T.decodeUtf8 b+parseType b = SqlOther b ----------------------------------------------------------------------@@ -606,20 +631,20 @@ -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column])-findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName maxLen ref) cols =+findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols = case filter ((name ==) . cName) cols of -- new fkey that didnt exist before [] -> case ref of Nothing -> ([(name, Add' col)],[])- Just (tname, b) -> let cnstr = [addReference allDefs (refName tblName name) tname name]+ 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':_ ->+ 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, cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)]+ (False, Just (tname, _cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = []@@ -641,7 +666,7 @@ -- | Prints the part of a @CREATE TABLE@ statement about a given -- column. showColumn :: Column -> String-showColumn (Column n nu t def defConstraintName maxLen ref) = concat+showColumn (Column n nu t def _defConstraintName maxLen ref) = concat [ escapeDBName n , " " , showSqlType t maxLen True@@ -812,7 +837,7 @@ } deriving Show instance FromJSON MySQLConf where- parseJSON v = modifyFailure ("Persistent: error loadomg MySQL conf: " ++) $+ parseJSON v = modifyFailure ("Persistent: error loading MySQL conf: " ++) $ flip (withObject "MySQLConf") v $ \o -> do database <- o .: "database" host <- o .: "host"@@ -866,3 +891,77 @@ , MySQL.connectDatabase = maybeEnv database "DATABASE" } }++mockMigrate :: MySQL.ConnectInfo+ -> [EntityDef]+ -> (Text -> IO Statement)+ -> EntityDef+ -> IO (Either [Text] [(Bool, Text)])+mockMigrate _connectInfo allDefs _getter val = do+ let name = entityDB val+ let (newcols, udefs, fdefs) = mkColumns allDefs val+ let udspair = map udToPair udefs+ case ([], [], partitionEithers []) of+ -- Nothing found, create everything+ ([], [], _) -> do+ let uniques = flip concatMap udspair $ \(uname, ucols) ->+ [ AlterTable name $+ AddUniqueConstraint uname $+ map (findTypeAndMaxLen name) ucols ]+ let foreigns = do+ 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 newcols val): uniques ++ foreigns ++ foreignsAlt+ -- No errors and something found, migrate+ (_, _, ([], old')) -> do+ 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'+ -- Errors+ (_, _, (errs, _)) -> return $ Left errs++ where+ findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col+ (_, ml) = findMaxLenOfColumn allDefs tblName col+ in (col', ty, ml)+++-- | Mock a migration even when the database is not present.+-- This function will mock the migration for a database even when +-- the actual database isn't already present in the system.+mockMigration :: Migration -> IO ()+mockMigration mig = do+ smap <- newIORef $ Map.empty+ let sqlbackend = SqlBackend { connPrepare = \_ -> do+ return Statement+ { stmtFinalize = return ()+ , stmtReset = return ()+ , stmtExecute = undefined+ , stmtQuery = \_ -> return $ return ()+ },+ connInsertManySql = Nothing,+ connInsertSql = undefined,+ connStmtMap = smap,+ connClose = undefined,+ connMigrateSql = mockMigrate undefined,+ connBegin = undefined,+ connCommit = undefined,+ connRollback = undefined,+ connEscapeName = undefined,+ connNoLimit = undefined,+ connRDBMS = undefined,+ connLimitOffset = undefined,+ connLogFunc = undefined}+ result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend+ mapM_ T.putStrLn $ map snd $ snd resp
persistent-mysql.cabal view
@@ -1,5 +1,5 @@ name: persistent-mysql-version: 2.2+version: 2.3 license: MIT license-file: LICENSE author: Felipe Lessa <felipe.lessa@gmail.com>, Michael Snoyman@@ -18,6 +18,7 @@ . This package supports only MySQL 5.1 and above. However, it has been tested only on MySQL 5.5.+ Only the InnoDB storage engine is officially supported. . Known problems: .