diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -44,6 +44,7 @@ import Data.Function (on) import Data.Conduit import qualified Data.Conduit.List as CL +import Control.Monad.Logger (MonadLogger, runNoLoggingT) import qualified Data.IntMap as I @@ -57,6 +58,7 @@ import Data.Text (Text) import Data.Aeson import Control.Monad (forM, mzero) +import Data.Acquire (Acquire, mkAcquire, with) import System.Environment (getEnvironment) import Data.Int (Int64) import Data.Monoid ((<>)) @@ -74,7 +76,7 @@ -- finishes using it. Note that you should not use the given -- 'ConnectionPool' outside the action since it may be already -- been released. -withPostgresqlPool :: MonadIO m +withPostgresqlPool :: (MonadBaseControl IO m, MonadLogger m, MonadIO m) => ConnectionString -- ^ Connection string to the database. -> Int @@ -91,7 +93,7 @@ -- responsability to properly close the connection pool when -- unneeded. Use 'withPostgresqlPool' for an automatic resource -- control. -createPostgresqlPool :: MonadIO m +createPostgresqlPool :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => ConnectionString -- ^ Connection string to the database. -> Int @@ -103,17 +105,17 @@ -- | Same as 'withPostgresqlPool', but instead of opening a pool -- of connections, only one connection is opened. -withPostgresqlConn :: (MonadIO m, MonadBaseControl IO m) +withPostgresqlConn :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => ConnectionString -> (Connection -> m a) -> m a withPostgresqlConn = withSqlConn . open' -open' :: ConnectionString -> IO Connection -open' cstr = PG.connectPostgreSQL cstr >>= openSimpleConn +open' :: ConnectionString -> LogFunc -> IO Connection +open' cstr logFunc = PG.connectPostgreSQL cstr >>= openSimpleConn logFunc -- | Generate a 'Connection' from a 'PG.Connection' -openSimpleConn :: PG.Connection -> IO Connection -openSimpleConn conn = do - smap <- newIORef Map.empty +openSimpleConn :: LogFunc -> PG.Connection -> IO Connection +openSimpleConn logFunc conn = do + smap <- newIORef $ Map.empty return Connection { connPrepare = prepare' conn , connStmtMap = smap @@ -127,6 +129,7 @@ , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" + , connLogFunc = logFunc } prepare' :: PG.Connection -> Text -> IO Statement @@ -139,7 +142,7 @@ , stmtQuery = withStmt' conn query } -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = let sql = T.concat [ "INSERT INTO " @@ -161,13 +164,13 @@ execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 execute' conn query vals = PG.execute conn query (map P vals) -withStmt' :: MonadResource m +withStmt' :: MonadIO m => PG.Connection -> PG.Query -> [PersistValue] - -> Source m [PersistValue] + -> Acquire (Source m [PersistValue]) withStmt' conn query vals = - bracketP openS closeS pull + pull `fmap` mkAcquire openS closeS where openS = do -- Construct raw query @@ -245,7 +248,6 @@ toField (P (PersistDay d)) = PGTF.toField d toField (P (PersistTimeOfDay t)) = PGTF.toField t toField (P (PersistUTCTime t)) = PGTF.toField t - toField (P (PersistZonedTime (ZT t))) = PGTF.toField t toField (P PersistNull) = PGTF.toField PG.Null toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m @@ -290,8 +292,8 @@ , (k PS.varchar, convertPV PersistText) , (k PS.date, convertPV PersistDay) , (k PS.time, convertPV PersistTimeOfDay) - , (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc)) - , (k PS.timestamptz, convertPV (PersistZonedTime . ZT)) + , (k PS.timestamp, convertPV PersistUTCTime) + , (k PS.timestamptz, convertPV PersistUTCTime) , (k PS.bit, convertPV PersistInt64) , (k PS.varbit, convertPV PersistInt64) , (k PS.numeric, convertPV PersistRational) @@ -299,12 +301,7 @@ , (k PS.uuid, convertPV (PersistDbSpecific . unUnknown)) , (k PS.json, convertPV (PersistByteString . unUnknown)) , (k PS.unknown, convertPV (PersistByteString . unUnknown)) - -- add Inet and Cidr types - , (k PS.inet, convertPV (PersistDbSpecific . unUnknown)) - , (k PS.cidr, convertPV (PersistDbSpecific . unUnknown)) - - -- array types: same order as above , (1000, listOf PersistBool) , (1001, listOf (PersistByteString . unBinary)) @@ -324,8 +321,8 @@ , (1015, listOf PersistText) , (1182, listOf PersistDay) , (1183, listOf PersistTimeOfDay) - , (1115, listOf (PersistUTCTime . localTimeToUTC utc)) - , (1185, listOf (PersistZonedTime . ZT)) + , (1115, listOf PersistUTCTime) + , (1185, listOf PersistUTCTime) , (1561, listOf PersistInt64) , (1563, listOf PersistInt64) , (1231, listOf PersistRational) @@ -361,7 +358,7 @@ -> IO Bool doesTableExist getter (DBName name) = do stmt <- getter sql - runResourceT $ stmtQuery stmt vals $$ start + with (stmtQuery stmt vals) ($$ start) where sql = "SELECT COUNT(*) FROM information_schema.tables WHERE table_name=?" vals = [PersistText name] @@ -372,9 +369,9 @@ 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] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do let name = entityDB val @@ -395,7 +392,7 @@ if not exists then do let idtxt = case entityPrimary val of - Just pdef -> T.concat [" PRIMARY KEY (", T.intercalate "," $ map (escape . snd) $ primaryFields pdef, ")"] + Just pdef -> T.concat [" PRIMARY KEY (", T.intercalate "," $ map (escape . fieldDB) $ primaryFields pdef, ")"] Nothing -> T.concat [escape $ entityID val , " SERIAL PRIMARY KEY UNIQUE"] let addTable = AddTable $ T.concat @@ -423,7 +420,8 @@ type SafeToRemove = Bool -data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove +data AlterColumn = Type SqlType Text + | IsNull | NotNull | Add' Column | Drop SafeToRemove | Default Text | NoDefault | Update' Text | AddReference DBName [DBName] [DBName] | DropReference DBName type AlterColumn' = (DBName, AlterColumn) @@ -437,7 +435,7 @@ -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def = do let sqlv=T.concat ["SELECT " @@ -458,7 +456,7 @@ [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ entityID def ] - cs <- runResourceT $ stmtQuery stmt vals $$ helper + cs <- with (stmtQuery stmt vals) ($$ helper) let sqlc = T.concat ["SELECT " ,"c.constraint_name, " ,"c.column_name " @@ -477,7 +475,7 @@ stmt' <- getter sqlc - us <- runResourceT $ stmtQuery stmt' vals $$ helperU + us <- with (stmtQuery stmt' vals) ($$ helperU) return $ cs ++ us where getAll front = do @@ -505,14 +503,14 @@ -- | Check if a column name is listed as the "safe to remove" in the entity -- list. -safeToRemove :: EntityDef a -> DBName -> Bool +safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) = any (elem "SafeToRemove" . fieldAttrs) $ filter ((== DBName colName) . fieldDB) $ entityFields def -getAlters :: [EntityDef a] - -> EntityDef SqlType +getAlters :: [EntityDef] + -> EntityDef -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable]) @@ -587,12 +585,12 @@ ] let ref = refName tname cname stmt <- getter sql - runResourceT $ stmtQuery stmt + with (stmtQuery stmt [ PersistText $ unDBName tname , PersistText $ unDBName ref - ] $$ do + ]) ($$ do Just [PersistInt64 i] <- CL.head - return $ if i == 0 then Nothing else Just (DBName "", ref) + return $ if i == 0 then Nothing else Just (DBName "", ref)) d' = case d of PersistNull -> Right Nothing PersistText t -> Right $ Just t @@ -602,8 +600,7 @@ getType "varchar" = Right SqlString getType "date" = Right SqlDay getType "bool" = Right SqlBool - getType "timestamp" = Right SqlDayTime - getType "timestamptz" = Right SqlDayTimeZoned + getType "timestamptz" = Right SqlDayTime getType "float4" = Right SqlReal getType "float8" = Right SqlReal getType "bytea" = Right SqlBlob @@ -621,7 +618,7 @@ sqlTypeEq x y = T.toCaseFold (showSqlType x) == T.toCaseFold (showSqlType y) -findAlters :: [EntityDef a] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: [EntityDef] -> 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) @@ -644,7 +641,18 @@ Just s -> (:) (name, Update' s) in up [(name, NotNull)] _ -> [] - modType = if sqlTypeEq sqltype sqltype' then [] else [(name, Type sqltype)] + modType + | sqlTypeEq sqltype sqltype' = [] + -- When converting from Persistent pre-2.0 databases, we + -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is + -- treated as UTC. + | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" = + [(name, Type sqltype $ T.concat + [ " USING " + , escape name + , " AT TIME ZONE 'UTC'" + ])] + | otherwise = [(name, Type sqltype "")] modDef = if def == def' then [] @@ -655,7 +663,7 @@ 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 :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing @@ -687,8 +695,7 @@ 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 SqlDayTime = "TIMESTAMP WITH TIME ZONE" showSqlType SqlBlob = "BYTEA" showSqlType SqlBool = "BOOLEAN" @@ -724,7 +731,7 @@ ] showAlter :: DBName -> AlterColumn' -> Text -showAlter table (n, Type t) = +showAlter table (n, Type t extra) = T.concat [ "ALTER TABLE " , escape table @@ -732,6 +739,7 @@ , escape n , " TYPE " , showSqlType t + , extra ] showAlter table (n, IsNull) = T.concat @@ -831,7 +839,7 @@ instance PersistConfig PostgresConf where type PersistConfigBackend PostgresConf = SqlPersistT type PersistConfigPool PostgresConf = ConnectionPool - createPoolConfig (PostgresConf cs size) = createPostgresqlPool cs size + createPoolConfig (PostgresConf cs size) = runNoLoggingT $ createPostgresqlPool cs size -- FIXME runPool _ = runSqlPool loadConfig (Object o) = do database <- o .: "database" 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.3.1.3 +version: 2.0.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,9 +16,9 @@ library build-depends: base >= 4 && < 5 , transformers >= 0.2.1 - , postgresql-simple >= 0.4.0 && < 0.5 + , postgresql-simple >= 0.3.10 && < 0.5 , postgresql-libpq >= 0.6.1 && < 0.10 - , persistent >= 1.3 && < 1.4 + , persistent >= 2.0 && < 2.1 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.7 @@ -27,7 +27,8 @@ , time >= 1.1 , aeson >= 0.5 , conduit >= 0.5.3 - , resourcet + , resourcet >= 1.1 + , monad-logger >= 0.3.4 exposed-modules: Database.Persist.Postgresql ghc-options: -Wall