diff --git a/Database/Persist/MySQL.hs b/Database/Persist/MySQL.hs --- a/Database/Persist/MySQL.hs +++ b/Database/Persist/MySQL.hs @@ -393,7 +393,7 @@ -- Find out all columns. stmtClmns <- getter "SELECT COLUMN_NAME, \ \IS_NULLABLE, \ - \DATA_TYPE, \ + \COLUMN_TYPE, \ \COLUMN_DEFAULT \ \FROM INFORMATION_SCHEMA.COLUMNS \ \WHERE TABLE_SCHEMA = ? \ @@ -462,9 +462,6 @@ Right t -> return (Just t) _ -> fail $ "Invalid default column: " ++ show default' - -- Column type - type_ <- parseType type' - -- Foreign key (if any) stmt <- lift $ getter "SELECT REFERENCED_TABLE_NAME, \ \CONSTRAINT_NAME, \ @@ -491,7 +488,7 @@ return Column { cName = DBName $ T.decodeUtf8 cname , cNull = null_ == "YES" - , cSqlType = type_ + , cSqlType = parseType type' , cDefault = default_ , cDefaultConstraintName = Nothing , cMaxLen = Nothing -- FIXME: maxLen @@ -504,43 +501,47 @@ -- | Parse the type of column as returned by MySQL's -- @INFORMATION_SCHEMA@ tables. -parseType :: Monad m => ByteString -> m SqlType -parseType "tinyint" = return SqlBool +parseType :: ByteString -> SqlType +parseType "bigint(20)" = SqlInt64 +parseType "decimal(32,20)" = SqlNumeric 32 20 +{- +parseType "tinyint" = SqlBool -- Ints -parseType "int" = return SqlInt32 -parseType "short" = return SqlInt32 -parseType "long" = return SqlInt64 -parseType "longlong" = return SqlInt64 -parseType "mediumint" = return SqlInt32 -parseType "bigint" = return SqlInt64 +parseType "int" = SqlInt32 +--parseType "short" = SqlInt32 +--parseType "long" = SqlInt64 +--parseType "longlong" = SqlInt64 +--parseType "mediumint" = SqlInt32 +parseType "bigint" = SqlInt64 -- Double -parseType "float" = return SqlReal -parseType "double" = return SqlReal -parseType "decimal" = return SqlReal -parseType "newdecimal" = return SqlReal +--parseType "float" = SqlReal +parseType "double" = SqlReal +--parseType "decimal" = SqlReal +--parseType "newdecimal" = SqlReal -- Text -parseType "varchar" = return SqlString -parseType "varstring" = return SqlString -parseType "string" = return SqlString -parseType "text" = return SqlString -parseType "tinytext" = return SqlString -parseType "mediumtext" = return SqlString -parseType "longtext" = return SqlString +parseType "varchar" = SqlString +--parseType "varstring" = SqlString +--parseType "string" = SqlString +parseType "text" = SqlString +--parseType "tinytext" = SqlString +--parseType "mediumtext" = SqlString +--parseType "longtext" = SqlString -- ByteString -parseType "varbinary" = return SqlBlob -parseType "blob" = return SqlBlob -parseType "tinyblob" = return SqlBlob -parseType "mediumblob" = return SqlBlob -parseType "longblob" = return SqlBlob +parseType "varbinary" = SqlBlob +parseType "blob" = SqlBlob +--parseType "tinyblob" = SqlBlob +--parseType "mediumblob" = SqlBlob +--parseType "longblob" = SqlBlob -- Time-related -parseType "time" = return SqlTime -parseType "datetime" = return SqlDayTime -parseType "timestamp" = return SqlDayTime -parseType "date" = return SqlDay -parseType "newdate" = return SqlDay -parseType "year" = return SqlDay +parseType "time" = SqlTime +parseType "datetime" = SqlDayTime +--parseType "timestamp" = SqlDayTime +parseType "date" = SqlDay +--parseType "newdate" = SqlDay +--parseType "year" = SqlDay -- Other -parseType b = return $ SqlOther $ T.decodeUtf8 b +-} +parseType b = SqlOther $ T.decodeUtf8 b ---------------------------------------------------------------------- @@ -587,14 +588,14 @@ -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. findAlters :: Show a => DBName -> [EntityDef a] -> 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 -> ([],[]) + Nothing -> ([(name, Add' col)],[]) 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)] @@ -603,7 +604,7 @@ (False, Just (tname, cname)) -> [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability - modType | type_ == type_' && isNull == isNull' = [] + modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] | otherwise = [(name, Change col)] -- Default value modDef | def == def' = [] @@ -613,6 +614,8 @@ in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) + where + ciEquals x y = T.toCaseFold (T.pack x) == T.toCaseFold (T.pack y) ---------------------------------------------------------------------- @@ -623,7 +626,7 @@ showColumn (Column n nu t def defConstraintName maxLen ref) = concat [ escapeDBName n , " " - , showSqlType t maxLen + , showSqlType t maxLen True , " " , if nu then "NULL" else "NOT NULL" , case def of @@ -638,21 +641,25 @@ -- | Renders an 'SqlType' in MySQL's format. showSqlType :: SqlType -> Maybe Integer -- ^ @maxlen@ + -> Bool -- ^ include character set information? -> String -showSqlType SqlBlob Nothing = "BLOB" -showSqlType SqlBlob (Just i) = "VARBINARY(" ++ show i ++ ")" -showSqlType SqlBool _ = "TINYINT(1)" -showSqlType SqlDay _ = "DATE" -showSqlType SqlDayTime _ = "DATETIME" -showSqlType SqlDayTimeZoned _ = "VARCHAR(50) CHARACTER SET utf8" -showSqlType SqlInt32 _ = "INT" -showSqlType SqlInt64 _ = "BIGINT" -showSqlType SqlReal _ = "DOUBLE PRECISION" -showSqlType (SqlNumeric s prec) _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" -showSqlType SqlString Nothing = "TEXT CHARACTER SET utf8" -showSqlType SqlString (Just i) = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8" -showSqlType SqlTime _ = "TIME" -showSqlType (SqlOther t) _ = T.unpack t +showSqlType SqlBlob Nothing _ = "BLOB" +showSqlType SqlBlob (Just i) _ = "VARBINARY(" ++ show i ++ ")" +showSqlType SqlBool _ _ = "TINYINT(1)" +showSqlType SqlDay _ _ = "DATE" +showSqlType SqlDayTime _ _ = "DATETIME" +showSqlType SqlDayTimeZoned _ True = "VARCHAR(50) CHARACTER SET utf8" +showSqlType SqlDayTimeZoned _ False = "VARCHAR(50)" +showSqlType SqlInt32 _ _ = "INT(11)" +showSqlType SqlInt64 _ _ = "BIGINT" +showSqlType SqlReal _ _ = "DOUBLE" +showSqlType (SqlNumeric s prec) _ _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" +showSqlType SqlString Nothing True = "TEXT CHARACTER SET utf8" +showSqlType SqlString Nothing False = "TEXT" +showSqlType SqlString (Just i) True = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8" +showSqlType SqlString (Just i) False = "VARCHAR(" ++ show i ++ ")" +showSqlType SqlTime _ _ = "TIME" +showSqlType (SqlOther t) _ _ = T.unpack t -- | Render an action that must be done on the database. showAlterDb :: AlterDB -> (Bool, Text) @@ -802,12 +809,16 @@ database <- o .: "database" host <- o .: "host" port <- o .: "port" + path <- o .:? "path" user <- o .: "user" password <- o .: "password" pool <- o .: "poolsize" let ci = MySQL.defaultConnectInfo { MySQL.connectHost = host , MySQL.connectPort = port + , MySQL.connectPath = case path of + Just p -> p + Nothing -> MySQL.connectPath MySQL.defaultConnectInfo , MySQL.connectUser = user , MySQL.connectPassword = password , MySQL.connectDatabase = database @@ -824,12 +835,14 @@ MySQL.ConnectInfo { MySQL.connectHost = host , MySQL.connectPort = port + , MySQL.connectPath = path , MySQL.connectUser = user , MySQL.connectPassword = password , MySQL.connectDatabase = database } -> (myConnInfo conf) { MySQL.connectHost = maybeEnv host "HOST" , MySQL.connectPort = read $ maybeEnv (show port) "PORT" + , MySQL.connectPath = maybeEnv path "PATH" , MySQL.connectUser = maybeEnv user "USER" , MySQL.connectPassword = maybeEnv password "PASSWORD" , MySQL.connectDatabase = maybeEnv database "DATABASE" 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.3.0.2 +version: 1.3.1 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman