diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -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 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: 2.2 +version: 2.3 license: MIT license-file: LICENSE author: Felipe Lessa , 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: .