persistent-postgresql 1.3.0 → 1.3.0.1
raw patch · 2 files changed
+81/−85 lines, 2 files
Files
Database/Persist/Postgresql.hs view
@@ -36,7 +36,7 @@ import qualified Data.Map as Map import Data.Either (partitionEithers) import Control.Arrow-import Data.List (find, intercalate, sort, groupBy, nub)+import Data.List (find, intercalate, sort, groupBy) import Data.Function (on) import Data.Conduit import qualified Data.Conduit.List as CL@@ -49,7 +49,7 @@ import qualified Blaze.ByteString.Builder.ByteString as BBS import Data.Time.LocalTime (localTimeToUTC, utc)-import Data.Text (Text, pack)+import Data.Text (Text) import Data.Aeson import Control.Monad (forM, mzero) import System.Environment (getEnvironment)@@ -135,7 +135,7 @@ , stmtExecute = execute' conn query , stmtQuery = withStmt' conn query }- + insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult insertSql' ent vals = let sql = T.concat@@ -320,10 +320,7 @@ -> (Text -> IO Statement) -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)])- -- We nub because there might be duplicate statements generated- -- such as AlterColumn DropReference and AlterTable DropConstraint- -- for the same reference constraint.-migrate' allDefs getter val = fmap (fmap $ nub . map showAlterDb) $ do+migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do let name = entityDB val old <- getColumns getter val case partitionEithers old of@@ -342,23 +339,23 @@ if not exists then do let idtxt = case entityPrimary val of- Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . snd) $ primaryFields pdef, ")"]- Nothing -> concat [T.unpack $ escape $ entityID val+ Just pdef -> T.concat [" PRIMARY KEY (", T.intercalate "," $ map (escape . snd) $ primaryFields pdef, ")"]+ Nothing -> T.concat [escape $ entityID val , " SERIAL PRIMARY KEY UNIQUE"]- let addTable = AddTable $ concat+ let addTable = AddTable $ T.concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE "- , T.unpack $ escape name+ , escape name , "(" , idtxt- , if null newcols then [] else ","- , intercalate "," $ map showColumn newcols+ , if null newcols then "" else ","+ , T.intercalate "," $ map showColumn newcols , ")" ] let uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> getAddReference allDefs name refTblName cname (cReference c)) $ filter (\c -> cReference c /= Nothing) newcols- foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ addTable : uniques ++ references ++ foreignsAlt else do@@ -371,14 +368,14 @@ type SafeToRemove = Bool data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove- | Default String | NoDefault | Update' String+ | Default Text | NoDefault | Update' Text | AddReference DBName [DBName] [DBName] | DropReference DBName type AlterColumn' = (DBName, AlterColumn) data AlterTable = AddUniqueConstraint DBName [DBName] | DropConstraint DBName -data AlterDB = AddTable String+data AlterDB = AddTable Text | AlterColumn DBName AlterColumn' | AlterTable DBName AlterTable @@ -399,14 +396,14 @@ ,"AND table_schema=current_schema() " ,"AND table_name=? " ,"AND column_name <> ?"]- + stmt <- getter sqlv let vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ entityID def ] cs <- runResourceT $ stmtQuery stmt vals $$ helper- let sqlc=concat ["SELECT "+ let sqlc = T.concat ["SELECT " ,"c.constraint_name, " ,"c.column_name " ,"FROM information_schema.key_column_usage c, "@@ -418,13 +415,12 @@ ,"AND c.table_name=? " ,"AND c.table_name=k.table_name " ,"AND c.column_name <> ? "- ,"AND c.ordinal_position=1 " ,"AND c.constraint_name=k.constraint_name "- ,"AND k.constraint_type <> 'PRIMARY KEY' "+ ,"AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " ,"ORDER BY c.constraint_name, c.column_name"] - stmt' <- getter $ pack sqlc- + stmt' <- getter sqlc+ us <- runResourceT $ stmtQuery stmt' vals $$ helperU return $ cs ++ us where@@ -433,7 +429,7 @@ case x of Nothing -> return $ front [] Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col))- Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) + Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) Just o -> error $ "unexpected datatype returned for postgres o="++show o helperU = do rows <- getAll id@@ -515,7 +511,7 @@ } where getRef cname = do- let sql = pack $ concat+ let sql = T.concat [ "SELECT COUNT(*) FROM " , "information_schema.table_constraints " , "WHERE table_catalog=current_database() "@@ -535,7 +531,7 @@ d' = case d of PersistNull -> Right Nothing PersistText t -> Right $ Just t- _ -> Left $ pack $ "Invalid default column: " ++ show d+ _ -> Left $ T.pack $ "Invalid default column: " ++ show d getType "int4" = Right $ SqlInt32 getType "int8" = Right $ SqlInt64 getType "varchar" = Right $ SqlString@@ -551,9 +547,9 @@ getType a = Right $ SqlOther a getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b)- getNumeric a b = Left $ pack $ "Can not get numeric field precision, got: " ++ show a ++ " and " ++ show b ++ " as precision and scale"+ getNumeric a b = Left $ T.pack $ "Can not get numeric field precision, got: " ++ show a ++ " and " ++ show b ++ " as precision and scale" getColumn _ _ x =- return $ Left $ pack $ "Invalid result from information_schema: " ++ show x+ return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show x findAlters :: [EntityDef a] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters defs tablename col@(Column name isNull sqltype def defConstraintName _maxLen ref) cols =@@ -566,7 +562,7 @@ refAdd (Just (tname, a)) = case find ((==tname) . entityDB) defs of Just refdef -> [(tname, AddReference a [name] [entityID refdef])] Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]"- modRef = + modRef = if fmap snd ref == fmap snd ref' then [] else refDrop ref' ++ refAdd ref@@ -575,7 +571,7 @@ (False, True) -> let up = case def of Nothing -> id- Just s -> (:) (name, Update' $ T.unpack s)+ Just s -> (:) (name, Update' s) in up [(name, NotNull)] _ -> [] modType = if sqltype == sqltype' then [] else [(name, Type sqltype)]@@ -584,7 +580,7 @@ then [] else case def of Nothing -> [(name, NoDefault)]- Just s -> [(name, Default $ T.unpack s)]+ Just s -> [(name, Default s)] in (modRef ++ modDef ++ modNull ++ modType, filter (\c -> cName c /= name) cols) @@ -599,145 +595,145 @@ id $ do entDef <- find ((== reftable) . entityDB) allDefs return (entityID entDef)- -showColumn :: Column -> String-showColumn c@(Column n nu sqlType def defConstraintName _maxLen _ref) = concat- [ T.unpack $ escape n++showColumn :: Column -> Text+showColumn c@(Column n nu sqlType def defConstraintName _maxLen _ref) = T.concat+ [ escape n , " " , showSqlType sqlType , " " , if nu then "NULL" else "NOT NULL" , case def of Nothing -> ""- Just s -> " DEFAULT " ++ T.unpack s+ Just s -> " DEFAULT " <> s ] -showSqlType :: SqlType -> String+showSqlType :: SqlType -> Text showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INT4" showSqlType SqlInt64 = "INT8" showSqlType SqlReal = "DOUBLE PRECISION"-showSqlType (SqlNumeric s prec) = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")"+showSqlType (SqlNumeric s prec) = T.concat [ "NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")" ] showSqlType SqlDay = "DATE" showSqlType SqlTime = "TIME" showSqlType SqlDayTime = "TIMESTAMP" showSqlType SqlDayTimeZoned = "TIMESTAMP WITH TIME ZONE" showSqlType SqlBlob = "BYTEA" showSqlType SqlBool = "BOOLEAN"-showSqlType (SqlOther t) = T.unpack t+showSqlType (SqlOther t) = t showAlterDb :: AlterDB -> (Bool, Text)-showAlterDb (AddTable s) = (False, pack s)+showAlterDb (AddTable s) = (False, s) showAlterDb (AlterColumn t (c, ac)) =- (isUnsafe ac, pack $ showAlter t (c, ac))+ (isUnsafe ac, showAlter t (c, ac)) where- isUnsafe (Drop safeToRemove) = not safeToRemove+ isUnsafe (Drop safeRemove) = not safeRemove isUnsafe _ = False-showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at)+showAlterDb (AlterTable t at) = (False, showAlterTable t at) -showAlterTable :: DBName -> AlterTable -> String-showAlterTable table (AddUniqueConstraint cname cols) = concat+showAlterTable :: DBName -> AlterTable -> Text+showAlterTable table (AddUniqueConstraint cname cols) = T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ADD CONSTRAINT "- , T.unpack $ escape cname+ , escape cname , " UNIQUE("- , intercalate "," $ map (T.unpack . escape) cols+ , T.intercalate "," $ map escape cols , ")" ]-showAlterTable table (DropConstraint cname) = concat+showAlterTable table (DropConstraint cname) = T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " DROP CONSTRAINT "- , T.unpack $ escape cname+ , escape cname ] -showAlter :: DBName -> AlterColumn' -> String+showAlter :: DBName -> AlterColumn' -> Text showAlter table (n, Type t) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ALTER COLUMN "- , T.unpack $ escape n+ , escape n , " TYPE " , showSqlType t ] showAlter table (n, IsNull) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ALTER COLUMN "- , T.unpack $ escape n+ , escape n , " DROP NOT NULL" ] showAlter table (n, NotNull) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ALTER COLUMN "- , T.unpack $ escape n+ , escape n , " SET NOT NULL" ] showAlter table (_, Add' col) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ADD COLUMN " , showColumn col ] showAlter table (n, Drop _) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " DROP COLUMN "- , T.unpack $ escape n+ , escape n ] showAlter table (n, Default s) =- concat+ T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ALTER COLUMN "- , T.unpack $ escape n+ , escape n , " SET DEFAULT " , s ]-showAlter table (n, NoDefault) = concat+showAlter table (n, NoDefault) = T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ALTER COLUMN "- , T.unpack $ escape n+ , escape n , " DROP DEFAULT" ]-showAlter table (n, Update' s) = concat+showAlter table (n, Update' s) = T.concat [ "UPDATE "- , T.unpack $ escape table+ , escape table , " SET "- , T.unpack $ escape n+ , escape n , "=" , s , " WHERE "- , T.unpack $ escape n+ , escape n , " IS NULL" ]-showAlter table (reftable, AddReference fkeyname t2 id2) = concat+showAlter table (reftable, AddReference fkeyname t2 id2) = T.concat [ "ALTER TABLE "- , T.unpack $ escape table+ , escape table , " ADD CONSTRAINT "- , T.unpack $ escape fkeyname+ , escape fkeyname , " FOREIGN KEY("- , T.unpack $ T.intercalate "," $ map escape t2+ , T.intercalate "," $ map escape t2 , ") REFERENCES "- , T.unpack $ escape reftable+ , escape reftable , "("- , T.unpack $ T.intercalate "," $ map escape id2+ , T.intercalate "," $ map escape id2 , ")" ]-showAlter table (_, DropReference cname) = concat+showAlter table (_, DropReference cname) = T.concat [ "ALTER TABLE "- , T.unpack (escape table)+ , escape table , " DROP CONSTRAINT "- , T.unpack $ escape cname+ , escape cname ] escape :: DBName -> Text
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 1.3.0+version: 1.3.0.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>