persistent-postgresql 1.2.1.1 → 1.2.1.2
raw patch · 2 files changed
+63/−158 lines, 2 filesdep ~postgresql-simple
Dependency ranges changed: postgresql-simple
Files
- Database/Persist/Postgresql.hs +61/−156
- persistent-postgresql.cabal +2/−2
Database/Persist/Postgresql.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-} -- | A postgresql backend for persistent. module Database.Persist.Postgresql@@ -17,6 +16,7 @@ ) where import Database.Persist.Sql+import Data.Maybe (mapMaybe, fromMaybe) 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.Typeable+import Data.List (intercalate) import Data.IORef import qualified Data.Map as Map import Data.Either (partitionEithers) import Control.Arrow-import Data.List (find, intercalate, sort, groupBy, nub)+import Data.List (sort, groupBy) import Data.Function (on) import Data.Conduit import qualified Data.Conduit.List as CL@@ -46,16 +46,14 @@ 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@@ -123,7 +121,6 @@ , connEscapeName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql"- , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" } prepare' :: PG.Connection -> Text -> IO Statement@@ -135,22 +132,19 @@ , stmtExecute = execute' conn query , stmtQuery = withStmt' conn query }- -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)) +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'+ ]+ execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 execute' conn query vals = PG.execute conn query (map P vals) @@ -192,10 +186,10 @@ getters <- forM [0..cols-1] $ \col -> do oid <- LibPQ.ftype ret col case PG.oid2builtin oid of- Nothing -> return $ \bs->- case bs of- Nothing -> fail $ "Unexpected null value in backend specific value"- Just a -> return $ PersistDbSpecific a+ Nothing -> fail $ "Postgresql.withStmt': could not " +++ "recognize Oid of column " +++ show (let LibPQ.Col i = col in i) +++ " (counting from zero)" Just bt -> return $ getGetter bt $ PG.Field ret col oid -- Ready to go!@@ -246,22 +240,9 @@ 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@@ -293,76 +274,43 @@ 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)])- -- 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 ([], old'') -> do let old' = partitionEithers 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+ let new = first (filter $ not . safeToRemove val . cName)+ $ second (map udToPair)+ $ mkColumns allDefs val+ if null old 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.Persist.Sql.Migration+ -- Lower case e: see Database.Persistent.GenericSql.Migration [ "CREATe TABLE " , T.unpack $ escape name , "("- , idtxt- , if null newcols then [] else ","- , intercalate "," $ map showColumn newcols+ , T.unpack $ escape $ entityID val+ , " SERIAL PRIMARY KEY UNIQUE"+ , concatMap (\x -> ',' : showColumn x) $ fst new , ")" ]- let uniques = flip concatMap udspair $ \(uname, ucols) ->+ let uniques = flip concatMap (snd new) $ \(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)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs- return $ Right $ addTable : uniques ++ references ++ foreignsAlt+ references = mapMaybe (getAddReference name) $ fst new+ return $ Right $ addTable : uniques ++ references else do- let (acs, ats) = getAlters allDefs val (newcols, udspair) old'+ let (acs, ats) = getAlters val new old' let acs' = map (AlterColumn name) acs let ats' = map (AlterTable name) ats return $ Right $ acs' ++ ats'@@ -372,7 +320,7 @@ data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove | Default String | NoDefault | Update' String- | AddReference DBName [DBName] [DBName] | DropReference DBName+ | AddReference DBName | DropReference DBName type AlterColumn' = (DBName, AlterColumn) data AlterTable = AddUniqueConstraint DBName [DBName]@@ -387,44 +335,14 @@ -> EntityDef a -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def = do- 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+ 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 vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ entityID def ] cs <- runResourceT $ stmtQuery stmt vals $$ helper- 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- + 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" us <- runResourceT $ stmtQuery stmt' vals $$ helperU return $ cs ++ us where@@ -432,9 +350,9 @@ x <- CL.head 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 o -> error $ "unexpected datatype returned for postgres o="++show o+ Just [PersistText con, PersistText col] ->+ getAll (front . (:) (con, col))+ Just _ -> getAll front -- FIXME error message? helperU = do rows <- getAll id return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))@@ -459,17 +377,16 @@ $ filter ((== (DBName colName)) . fieldDB) $ entityFields def -getAlters :: [EntityDef a]- -> EntityDef SqlType+getAlters :: EntityDef a -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable])-getAlters defs def (c1, u1) (c2, u2) =+getAlters 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 defs (entityDB def) new old+ let (alters, old') = findAlters new old in alters ++ getAltersC news old' getAltersU :: [(DBName, [DBName])]@@ -506,8 +423,9 @@ { cName = cname , cNull = y == "YES" , cSqlType = t- , cDefault = d''- , cDefaultConstraintName = Nothing+ , cDefault = fmap+ (\x -> fromMaybe x $ T.stripSuffix "::character varying" x)+ d'' , cMaxLen = Nothing , cReference = ref }@@ -516,9 +434,7 @@ let sql = pack $ concat [ "SELECT COUNT(*) FROM " , "information_schema.table_constraints "- , "WHERE table_catalog=current_database() "- , "AND table_schema=current_schema() "- , "AND table_name=? "+ , "WHERE table_name=? " , "AND constraint_type='FOREIGN KEY' " , "AND constraint_name=?" ]@@ -553,18 +469,16 @@ getColumn _ _ x = return $ Left $ 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 =+findAlters :: Column -> [Column] -> ([AlterColumn'], [Column])+findAlters col@(Column name isNull sqltype def _maxLen ref) cols = case filter (\c -> cName c == name) cols of [] -> ([(name, Add' col)], cols)- Column _ isNull' sqltype' def' defConstraintName' _maxLen' ref':_ ->+ Column _ isNull' sqltype' def' _maxLen' ref':_ -> let refDrop Nothing = [] refDrop (Just (_, cname)) = [(name, DropReference cname)] refAdd Nothing = []- 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 = + refAdd (Just (tname, _)) = [(name, AddReference tname)]+ modRef = if fmap snd ref == fmap snd ref' then [] else refDrop ref' ++ refAdd ref@@ -587,20 +501,14 @@ filter (\c -> cName c /= name) cols) -- | Get the references to be added to a table for the given column.-getAddReference :: [EntityDef a] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB-getAddReference allDefs table reftable cname ref =+getAddReference :: DBName -> Column -> Maybe AlterDB+getAddReference table (Column n _nu _ _def _maxLen ref) = case ref of Nothing -> Nothing- 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)- + Just (s, _) -> Just $ AlterColumn table (n, AddReference s) showColumn :: Column -> String-showColumn c@(Column n nu sqlType def defConstraintName _maxLen _ref) = concat+showColumn (Column n nu sqlType def _maxLen _ref) = concat [ T.unpack $ escape n , " " , showSqlType sqlType@@ -718,18 +626,15 @@ , T.unpack $ escape n , " IS NULL" ]-showAlter table (reftable, AddReference fkeyname t2 id2) = concat+showAlter table (n, AddReference t2) = concat [ "ALTER TABLE " , T.unpack $ escape table , " ADD CONSTRAINT "- , T.unpack $ escape fkeyname+ , T.unpack $ escape $ refName table n , " FOREIGN KEY("- , T.unpack $ T.intercalate "," $ map escape t2+ , T.unpack $ escape n , ") REFERENCES "- , T.unpack $ escape reftable- , "("- , T.unpack $ T.intercalate "," $ map escape id2- , ")"+ , T.unpack $ escape t2 ] showAlter table (_, DropReference cname) = concat [ "ALTER TABLE "
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 1.2.1.1+version: 1.2.1.2 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.5+ , postgresql-simple >= 0.3 && < 0.4 , postgresql-libpq >= 0.6.1 && < 0.9 , persistent >= 1.2 && < 1.3 , containers >= 0.2