persistent-postgresql 1.2.1 → 1.2.1.1
raw patch · 2 files changed
+157/−60 lines, 2 filesdep ~postgresql-simple
Dependency ranges changed: postgresql-simple
Files
- Database/Persist/Postgresql.hs +155/−58
- persistent-postgresql.cabal +2/−2
Database/Persist/Postgresql.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | A postgresql backend for persistent. module Database.Persist.Postgresql@@ -16,7 +17,6 @@ ) where import Database.Persist.Sql-import Data.Maybe (mapMaybe) import Data.Fixed (Pico) import qualified Database.PostgreSQL.Simple as PG@@ -31,12 +31,12 @@ import Control.Exception (throw) import Control.Monad.IO.Class (MonadIO (..))-import Data.List (intercalate)+import Data.Typeable import Data.IORef import qualified Data.Map as Map import Data.Either (partitionEithers) import Control.Arrow-import Data.List (sort, groupBy)+import Data.List (find, intercalate, sort, groupBy, nub) import Data.Function (on) import Data.Conduit import qualified Data.Conduit.List as CL@@ -46,14 +46,16 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Blaze.ByteString.Builder.Char8 as BBB+import qualified Blaze.ByteString.Builder.ByteString as BBS+ import Data.Time.LocalTime (localTimeToUTC, utc) import Data.Text (Text, pack) import Data.Aeson import Control.Monad (forM, mzero) import System.Environment (getEnvironment) import Data.Int (Int64)--+import Data.Maybe (mapMaybe, fromJust, isJust)+import Data.Monoid ((<>)) -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test -- dbname=test password=test\"@. Please read libpq's@@ -121,6 +123,7 @@ , connEscapeName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql"+ , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" } prepare' :: PG.Connection -> Text -> IO Statement@@ -132,18 +135,21 @@ , stmtExecute = execute' conn query , stmtQuery = withStmt' conn query }--insertSql' :: DBName -> [DBName] -> DBName -> InsertSqlResult-insertSql' t cols id' = ISRSingle $ pack $ concat- [ "INSERT INTO "- , T.unpack $ escape t- , "("- , intercalate "," $ map (T.unpack . escape) cols- , ") VALUES("- , intercalate "," (map (const "?") cols)- , ") RETURNING "- , T.unpack $ escape id'- ]+ +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult+insertSql' ent vals =+ let sql = T.concat+ [ "INSERT INTO "+ , escape $ entityDB ent+ , "("+ , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent+ , ") VALUES("+ , T.intercalate "," (map (const "?") $ entityFields ent)+ , ")"+ ]+ in case entityPrimary ent of+ Just pdef -> ISRManyKeys sql vals+ Nothing -> ISRSingle (sql <> " RETURNING " <> escape (entityID ent)) execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 execute' conn query vals = PG.execute conn query (map P vals)@@ -186,10 +192,10 @@ getters <- forM [0..cols-1] $ \col -> do oid <- LibPQ.ftype ret col case PG.oid2builtin oid of- Nothing -> fail $ "Postgresql.withStmt': could not " ++- "recognize Oid of column " ++- show (let LibPQ.Col i = col in i) ++- " (counting from zero)"+ Nothing -> return $ \bs->+ case bs of+ Nothing -> fail $ "Unexpected null value in backend specific value"+ Just a -> return $ PersistDbSpecific a Just bt -> return $ getGetter bt $ PG.Field ret col oid -- Ready to go!@@ -240,9 +246,22 @@ toField (P PersistNull) = PGTF.toField PG.Null toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m+ toField (P (PersistDbSpecific s)) = PGTF.toField (Unknown s) toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" +newtype Unknown = Unknown { unUnknown :: ByteString }+ deriving (Eq, Show, Read, Ord, Typeable)++instance PGFF.FromField Unknown where+ fromField f mdata =+ case mdata of+ Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""+ Just dat -> return (Unknown dat)++instance PGTF.ToField Unknown where+ toField (Unknown a) = PGTF.Escape a+ type Getter a = PGFF.FieldParser a convertPV :: PGFF.FromField a => (a -> b) -> Getter b@@ -274,43 +293,76 @@ getGetter PG.VarBit = convertPV PersistInt64 getGetter PG.Numeric = convertPV PersistRational getGetter PG.Void = \_ _ -> return PersistNull+getGetter PG.UUID = convertPV (PersistDbSpecific . unUnknown) getGetter other = error $ "Postgresql.getGetter: type " ++ show other ++ " not supported." unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x +doesTableExist :: (Text -> IO Statement)+ -> DBName -- ^ table name+ -> IO Bool+doesTableExist getter (DBName name) = do+ stmt <- getter sql+ runResourceT $ stmtQuery stmt vals $$ start+ where+ sql = "SELECT COUNT(*) FROM information_schema.tables WHERE table_name=?"+ vals = [PersistText name]++ start = await >>= maybe (error "No results when checking doesTableExist") start'+ start' [PersistInt64 0] = finish False+ start' [PersistInt64 1] = finish True+ start' res = error $ "doesTableExist returned unexpected result: " ++ show res+ finish x = await >>= maybe (return x) (error "Too many rows returned in doesTableExist")+ migrate' :: [EntityDef a] -> (Text -> IO Statement) -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)])-migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do+ -- 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 let name = entityDB val old <- getColumns getter val case partitionEithers old of ([], old'') -> do let old' = partitionEithers old''- let new = first (filter $ not . safeToRemove val . cName)- $ second (map udToPair)- $ mkColumns allDefs val- if null old+ let (newcols', udefs, fdefs) = mkColumns allDefs val+ let newcols = filter (not . safeToRemove val . cName) newcols'+ let udspair = map udToPair udefs+ -- Check for table existence if there are no columns, workaround+ -- for https://github.com/yesodweb/persistent/issues/152+ exists <-+ if null old+ then doesTableExist getter name+ else return True++ 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+ , " SERIAL PRIMARY KEY UNIQUE"] let addTable = AddTable $ concat- -- Lower case e: see Database.Persistent.GenericSql.Migration+ -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " , T.unpack $ escape name , "("- , T.unpack $ escape $ entityID val- , " SERIAL PRIMARY KEY UNIQUE"- , concatMap (\x -> ',' : showColumn x) $ fst new+ , idtxt+ , if null newcols then [] else ","+ , intercalate "," $ map showColumn newcols , ")" ]- let uniques = flip concatMap (snd new) $ \(uname, ucols) ->+ let uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols]- references = mapMaybe (getAddReference name) $ fst new- return $ Right $ addTable : uniques ++ references+ 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)) + in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs+ return $ Right $ addTable : uniques ++ references ++ foreignsAlt else do- let (acs, ats) = getAlters val new old'+ let (acs, ats) = getAlters allDefs val (newcols, udspair) old' let acs' = map (AlterColumn name) acs let ats' = map (AlterTable name) ats return $ Right $ acs' ++ ats'@@ -320,7 +372,7 @@ data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove | Default String | NoDefault | Update' String- | AddReference DBName | DropReference DBName+ | AddReference DBName [DBName] [DBName] | DropReference DBName type AlterColumn' = (DBName, AlterColumn) data AlterTable = AddUniqueConstraint DBName [DBName]@@ -335,14 +387,44 @@ -> EntityDef a -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def = do- stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default,numeric_precision,numeric_scale FROM information_schema.columns WHERE table_name=? AND column_name <> ?"+ let sqlv=T.concat ["SELECT "+ ,"column_name "+ ,",is_nullable "+ ,",udt_name "+ ,",column_default "+ ,",numeric_precision "+ ,",numeric_scale "+ ,"FROM information_schema.columns "+ ,"WHERE table_catalog=current_database() "+ ,"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- stmt' <- getter- "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> ? ORDER BY constraint_name, column_name"+ let sqlc=concat ["SELECT "+ ,"c.constraint_name, "+ ,"c.column_name "+ ,"FROM information_schema.key_column_usage c, "+ ,"information_schema.table_constraints k "+ ,"WHERE c.table_catalog=current_database() "+ ,"AND c.table_catalog=k.table_catalog "+ ,"AND c.table_schema=current_schema() "+ ,"AND c.table_schema=k.table_schema "+ ,"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' "+ ,"ORDER BY c.constraint_name, c.column_name"]++ stmt' <- getter $ pack sqlc+ us <- runResourceT $ stmtQuery stmt' vals $$ helperU return $ cs ++ us where@@ -350,9 +432,9 @@ x <- CL.head case x of Nothing -> return $ front []- Just [PersistText con, PersistText col] ->- getAll (front . (:) (con, col))- Just _ -> getAll front -- FIXME error message?+ Just [PersistText con, PersistText col] -> getAll (front . (:) (con, 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 return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))@@ -377,16 +459,17 @@ $ filter ((== (DBName colName)) . fieldDB) $ entityFields def -getAlters :: EntityDef a+getAlters :: [EntityDef a]+ -> EntityDef SqlType -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable])-getAlters def (c1, u1) (c2, u2) =+getAlters defs def (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where getAltersC [] old = map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old getAltersC (new:news) old =- let (alters, old') = findAlters new old+ let (alters, old') = findAlters defs (entityDB def) new old in alters ++ getAltersC news old' getAltersU :: [(DBName, [DBName])]@@ -424,6 +507,7 @@ , cNull = y == "YES" , cSqlType = t , cDefault = d''+ , cDefaultConstraintName = Nothing , cMaxLen = Nothing , cReference = ref }@@ -432,7 +516,9 @@ let sql = pack $ concat [ "SELECT COUNT(*) FROM " , "information_schema.table_constraints "- , "WHERE table_name=? "+ , "WHERE table_catalog=current_database() "+ , "AND table_schema=current_schema() "+ , "AND table_name=? " , "AND constraint_type='FOREIGN KEY' " , "AND constraint_name=?" ]@@ -467,16 +553,18 @@ getColumn _ _ x = return $ Left $ pack $ "Invalid result from information_schema: " ++ show x -findAlters :: Column -> [Column] -> ([AlterColumn'], [Column])-findAlters col@(Column name isNull sqltype def _maxLen ref) cols =+findAlters :: [EntityDef a] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column])+findAlters defs tablename col@(Column name isNull sqltype def defConstraintName _maxLen ref) cols = case filter (\c -> cName c == name) cols of [] -> ([(name, Add' col)], cols)- Column _ isNull' sqltype' def' _maxLen' ref':_ ->+ Column _ isNull' sqltype' def' defConstraintName' _maxLen' ref':_ -> let refDrop Nothing = [] refDrop (Just (_, cname)) = [(name, DropReference cname)] refAdd Nothing = []- refAdd (Just (tname, _)) = [(name, AddReference tname)]- modRef =+ 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 = if fmap snd ref == fmap snd ref' then [] else refDrop ref' ++ refAdd ref@@ -499,14 +587,20 @@ filter (\c -> cName c /= name) cols) -- | Get the references to be added to a table for the given column.-getAddReference :: DBName -> Column -> Maybe AlterDB-getAddReference table (Column n _nu _ _def _maxLen ref) =+getAddReference :: [EntityDef a] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB+getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing- Just (s, _) -> Just $ AlterColumn table (n, AddReference s)+ Just (s, z) -> Just $ AlterColumn table (s, AddReference (refName table cname) [cname] [id_])+ where+ id_ = maybe (error $ "Could not find ID of entity " ++ show reftable)+ id $ do+ entDef <- find ((== reftable) . entityDB) allDefs+ return (entityID entDef)+ showColumn :: Column -> String-showColumn (Column n nu sqlType def _maxLen _ref) = concat+showColumn c@(Column n nu sqlType def defConstraintName _maxLen _ref) = concat [ T.unpack $ escape n , " " , showSqlType sqlType@@ -624,15 +718,18 @@ , T.unpack $ escape n , " IS NULL" ]-showAlter table (n, AddReference t2) = concat+showAlter table (reftable, AddReference fkeyname t2 id2) = concat [ "ALTER TABLE " , T.unpack $ escape table , " ADD CONSTRAINT "- , T.unpack $ escape $ refName table n+ , T.unpack $ escape fkeyname , " FOREIGN KEY("- , T.unpack $ escape n+ , T.unpack $ T.intercalate "," $ map escape t2 , ") REFERENCES "- , T.unpack $ escape t2+ , T.unpack $ escape reftable+ , "("+ , T.unpack $ T.intercalate "," $ map escape id2+ , ")" ] showAlter table (_, DropReference cname) = concat [ "ALTER TABLE "
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 1.2.1+version: 1.2.1.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>@@ -15,7 +15,7 @@ library build-depends: base >= 4 && < 5 , transformers >= 0.2.1- , postgresql-simple >= 0.3 && < 0.4+ , postgresql-simple >= 0.3 && < 0.5 , postgresql-libpq >= 0.6.1 && < 0.9 , persistent >= 1.2 && < 1.3 , containers >= 0.2