diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -20,7 +20,7 @@ import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (runWriterT) import Data.Monoid ((<>)) @@ -124,6 +124,7 @@ , connRDBMS = "mysql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" , connLogFunc = logFunc + , connMaxParams = Nothing } -- | Prepare a query. We don't support prepared statements, but @@ -456,7 +457,7 @@ stmtIdClmn <- getter "SELECT COLUMN_NAME, \ \IS_NULLABLE, \ \DATA_TYPE, \ - \COLUMN_DEFAULT \ + \IF(IS_NULLABLE='YES', COALESCE(COLUMN_DEFAULT, 'NULL'), COLUMN_DEFAULT) \ \FROM INFORMATION_SCHEMA.COLUMNS \ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ @@ -467,8 +468,12 @@ -- Find out all columns. stmtClmns <- getter "SELECT COLUMN_NAME, \ \IS_NULLABLE, \ + \DATA_TYPE, \ \COLUMN_TYPE, \ - \COLUMN_DEFAULT \ + \CHARACTER_MAXIMUM_LENGTH, \ + \NUMERIC_PRECISION, \ + \NUMERIC_SCALE, \ + \IF(IS_NULLABLE='YES', COALESCE(COLUMN_DEFAULT, 'NULL'), COLUMN_DEFAULT) \ \FROM INFORMATION_SCHEMA.COLUMNS \ \WHERE TABLE_SCHEMA = ? \ \AND TABLE_NAME = ? \ @@ -519,10 +524,14 @@ -> IO (Either Text Column) getColumn connectInfo getter tname [ PersistText cname , PersistText null_ - , PersistText type' + , PersistText dataType + , PersistText colType + , colMaxLen + , colPrecision + , colScale , default'] = fmap (either (Left . pack) Right) $ - runErrorT $ do + runExceptT $ do -- Default value default_ <- case default' of PersistNull -> return Nothing @@ -557,65 +566,67 @@ return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing _ -> fail "MySQL.getColumn/getRef: never here" + let colMaxLen' = case colMaxLen of + PersistInt64 l -> Just (fromIntegral l) + _ -> Nothing + ci = ColumnInfo + { ciColumnType = colType + , ciMaxLength = colMaxLen' + , ciNumericPrecision = colPrecision + , ciNumericScale = colScale + } + (typ, maxLen) <- parseColumnType dataType ci -- Okay! return Column { cName = DBName $ cname , cNull = null_ == "YES" - , cSqlType = parseType type' + , cSqlType = typ , cDefault = default_ , cDefaultConstraintName = Nothing - , cMaxLen = Nothing -- FIXME: maxLen + , cMaxLen = maxLen , cReference = ref } getColumn _ _ _ x = return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x +-- | Extra column information from MySQL schema +data ColumnInfo = ColumnInfo + { ciColumnType :: Text + , ciMaxLength :: Maybe Integer + , ciNumericPrecision :: PersistValue + , ciNumericScale :: PersistValue + } -- | Parse the type of column as returned by MySQL's -- @INFORMATION_SCHEMA@ tables. -parseType :: Text -> SqlType -parseType "bigint(20)" = SqlInt64 -parseType "decimal(32,20)" = SqlNumeric 32 20 -{- -parseType "tinyint" = SqlBool +parseColumnType :: Monad m => Text -> ColumnInfo -> m (SqlType, Maybe Integer) -- Ints -parseType "int" = SqlInt32 ---parseType "short" = SqlInt32 ---parseType "long" = SqlInt64 ---parseType "longlong" = SqlInt64 ---parseType "mediumint" = SqlInt32 -parseType "bigint" = SqlInt64 +parseColumnType "tinyint" ci | ciColumnType ci == "tinyint(1)" = return (SqlBool, Nothing) +parseColumnType "int" ci | ciColumnType ci == "int(11)" = return (SqlInt32, Nothing) +parseColumnType "bigint" ci | ciColumnType ci == "bigint(20)" = return (SqlInt64, Nothing) -- Double ---parseType "float" = SqlReal -parseType "double" = SqlReal ---parseType "decimal" = SqlReal ---parseType "newdecimal" = SqlReal +parseColumnType "double" _ = return (SqlReal, Nothing) +parseColumnType "decimal" ci = + case (ciNumericPrecision ci, ciNumericScale ci) of + (PersistInt64 p, PersistInt64 s) -> + return (SqlNumeric (fromIntegral p) (fromIntegral s), Nothing) + _ -> + fail "missing DECIMAL precision in DB schema" -- Text -parseType "varchar" = SqlString ---parseType "varstring" = SqlString ---parseType "string" = SqlString -parseType "text" = SqlString ---parseType "tinytext" = SqlString ---parseType "mediumtext" = SqlString ---parseType "longtext" = SqlString +parseColumnType "varchar" ci = return (SqlString, ciMaxLength ci) +parseColumnType "text" _ = return (SqlString, Nothing) -- ByteString -parseType "varbinary" = SqlBlob -parseType "blob" = SqlBlob ---parseType "tinyblob" = SqlBlob ---parseType "mediumblob" = SqlBlob ---parseType "longblob" = SqlBlob +parseColumnType "varbinary" ci = return (SqlBlob, ciMaxLength ci) +parseColumnType "blob" _ = return (SqlBlob, Nothing) -- Time-related -parseType "time" = SqlTime -parseType "datetime" = SqlDayTime ---parseType "timestamp" = SqlDayTime -parseType "date" = SqlDay ---parseType "newdate" = SqlDay ---parseType "year" = SqlDay --} -parseType b = SqlOther b +parseColumnType "time" _ = return (SqlTime, Nothing) +parseColumnType "datetime" _ = return (SqlDayTime, Nothing) +parseColumnType "date" _ = return (SqlDay, Nothing) +parseColumnType _ ci = return (SqlOther (ciColumnType ci), Nothing) + ---------------------------------------------------------------------- @@ -931,9 +942,9 @@ let name = entityDB val let (newcols, udefs, fdefs) = mkColumns allDefs val let udspair = map udToPair udefs - case ([], [], partitionEithers []) of + case () of -- Nothing found, create everything - ([], [], _) -> do + () -> do let uniques = flip concatMap udspair $ \(uname, ucols) -> [ AlterTable name $ AddUniqueConstraint uname $ @@ -941,11 +952,12 @@ 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)) + + 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 + {- FIXME redundant, why is this here? The whole case expression is weird -- No errors and something found, migrate (_, _, ([], old')) -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of @@ -959,6 +971,7 @@ return $ Right $ map showAlterDb $ acs' ++ ats' -- Errors (_, _, (errs, _)) -> return $ Left errs + -} where findTypeAndMaxLen tblName col = let (col', ty) = findTypeOfColumn allDefs tblName col @@ -991,7 +1004,9 @@ connNoLimit = undefined, connRDBMS = undefined, connLimitOffset = undefined, - connLogFunc = undefined} + connLogFunc = undefined, + connUpsertSql = undefined, + connMaxParams = Nothing} 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.6 +version: 2.6.0.1 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman @@ -29,10 +29,10 @@ library build-depends: base >= 4.6 && < 5 , transformers >= 0.2.1 - , mysql-simple >= 0.2.2.3 && < 0.3 + , mysql-simple >= 0.2.2.3 && < 0.5 , mysql >= 0.1.1.3 && < 0.2 , blaze-builder - , persistent >= 2.6 && < 3 + , persistent >= 2.6.1 && < 3 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.11.0.6