diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -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 " diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -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 @@ -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