diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -6,19 +6,29 @@ module Database.Persist.Postgresql ( withPostgresqlPool , withPostgresqlConn + , createPostgresqlPool , module Database.Persist , module Database.Persist.GenericSql + , ConnectionString , PostgresConf (..) ) where -import Database.Persist hiding (Update) -import Database.Persist.Base hiding (Add, Update) +import Database.Persist hiding (Entity (..)) +import Database.Persist.Store import Database.Persist.GenericSql hiding (Key(..)) import Database.Persist.GenericSql.Internal +import Database.Persist.EntityDef -import qualified Database.HDBC as H -import qualified Database.HDBC.PostgreSQL as H +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG +import qualified Database.PostgreSQL.Simple.Internal as PG +import qualified Database.PostgreSQL.Simple.Param as PG +import qualified Database.PostgreSQL.Simple.Result as PG +import qualified Database.PostgreSQL.Simple.Types as PG +import qualified Database.PostgreSQL.LibPQ as LibPQ + +import Control.Exception (SomeException, throw) import Control.Monad.IO.Class (MonadIO (..)) import Data.List (intercalate) import Data.IORef @@ -27,136 +37,240 @@ import Control.Arrow import Data.List (sort, groupBy) import Data.Function (on) -#if MIN_VERSION_monad_control(0, 3, 0) -import Control.Monad.Trans.Control (MonadBaseControl) -#define MBCIO MonadBaseControl IO -#else -import Control.Monad.IO.Control (MonadControlIO) -#define MBCIO MonadControlIO -#endif +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import Data.Time.LocalTime (localTimeToUTC, utc) -import Data.Text (Text, pack, unpack) -import Data.Object -import Control.Monad (forM) -import Data.Neither (meither, MEither (..)) +-- import Data.Time.LocalTime (localTimeToUTC, utc) +import Data.Text (Text, pack) +import Data.Aeson +import Control.Monad (forM, mzero) +import System.Environment (getEnvironment) -withPostgresqlPool :: (MBCIO m, MonadIO m) - => T.Text - -> Int -- ^ number of connections to open - -> (ConnectionPool -> m a) -> m a -withPostgresqlPool s = withSqlPool $ open' s -withPostgresqlConn :: (MBCIO m, MonadIO m) => T.Text -> (Connection -> m a) -> m a +-- | 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 +-- documentation at +-- +-- for more details on how to create such strings. +type ConnectionString = ByteString + + +-- | Create a PostgreSQL connection pool and run the given +-- action. The pool is properly released after the action +-- 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 + => ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open in + -- the pool. + -> (ConnectionPool -> m a) + -- ^ Action to be executed that uses the + -- connection pool. + -> m a +withPostgresqlPool ci = withSqlPool $ open' ci + + +-- | Create a PostgreSQL connection pool. Note that it's your +-- responsability to properly close the connection pool when +-- unneeded. Use 'withPostgresqlPool' for an automatic resource +-- control. +createPostgresqlPool :: MonadIO m + => ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open + -- in the pool. + -> m ConnectionPool +createPostgresqlPool ci = createSqlPool $ open' ci + + +-- | Same as 'withPostgresqlPool', but instead of opening a pool +-- of connections, only one connection is opened. +withPostgresqlConn :: C.ResourceIO m => ConnectionString -> (Connection -> m a) -> m a withPostgresqlConn = withSqlConn . open' -open' :: T.Text -> IO Connection -open' s = do - conn <- H.connectPostgreSQL $ T.unpack s +open' :: ConnectionString -> IO Connection +open' cstr = do + conn <- PG.connectPostgreSQL cstr smap <- newIORef $ Map.empty return Connection - { prepare = prepare' conn - , stmtMap = smap - , insertSql = insertSql' - , close = H.disconnect conn + { prepare = prepare' conn + , stmtMap = smap + , insertSql = insertSql' + , close = PG.close conn , migrateSql = migrate' - , begin = const $ return () - , commitC = const $ H.commit conn - , rollbackC = const $ H.rollback conn + , begin = const $ PG.begin conn + , commitC = const $ PG.commit conn + , rollbackC = const $ PG.rollback conn , escapeName = escape - , noLimit = "LIMIT ALL" + , noLimit = "LIMIT ALL" } -prepare' :: H.Connection -> Text -> IO Statement +prepare' :: PG.Connection -> Text -> IO Statement prepare' conn sql = do - stmt <- H.prepare conn $ unpack sql + let query = PG.Query (T.encodeUtf8 sql) return Statement { finalize = return () , reset = return () - , execute = execute' stmt - , withStmt = withStmt' stmt + , execute = execute' conn query + , withStmt = withStmt' conn query } -insertSql' :: RawName -> [RawName] -> Either Text (Text, Text) +insertSql' :: DBName -> [DBName] -> Either Text (Text, Text) insertSql' t cols = Left $ pack $ concat [ "INSERT INTO " - , escape t + , T.unpack $ escape t , "(" - , intercalate "," $ map escape cols + , intercalate "," $ map (T.unpack . escape) cols , ") VALUES(" , intercalate "," (map (const "?") cols) , ") RETURNING id" ] -execute' :: H.Statement -> [PersistValue] -> IO () -execute' stmt vals = do - _ <- H.execute stmt $ map pToSql vals +execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO () +execute' conn query vals = do + _ <- PG.execute conn query (map P vals) return () -withStmt' - :: (MBCIO m, MonadIO m) - => H.Statement +withStmt' :: C.ResourceIO m + => PG.Connection + -> PG.Query -> [PersistValue] - -> (RowPopper m -> m a) - -> m a -withStmt' stmt vals f = do - _ <- liftIO $ H.execute stmt $ map pToSql vals - f $ liftIO $ (fmap . fmap) (map pFromSql) $ H.fetchRow stmt + -> C.Source m [PersistValue] +withStmt' conn query vals = C.sourceIO (liftIO openS ) + (liftIO . closeS) + (liftIO . pullS ) + where + openS = do + -- Construct raw query + rawquery <- PG.formatQuery conn query (map P vals) -pToSql :: PersistValue -> H.SqlValue -pToSql (PersistText t) = H.SqlString $ unpack t -pToSql (PersistByteString bs) = H.SqlByteString bs -pToSql (PersistInt64 i) = H.SqlInt64 i -pToSql (PersistDouble d) = H.SqlDouble d -pToSql (PersistBool b) = H.SqlBool b -pToSql (PersistDay d) = H.SqlLocalDate d -pToSql (PersistTimeOfDay t) = H.SqlLocalTimeOfDay t -pToSql (PersistUTCTime t) = H.SqlUTCTime t -pToSql PersistNull = H.SqlNull -pToSql (PersistList _) = error "Refusing to serialize a PersistList to a PostgreSQL value" -pToSql (PersistMap _) = error "Refusing to serialize a PersistMap to a PostgreSQL value" -pToSql (PersistObjectId _) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" + -- Take raw connection + PG.withConnection conn $ \rawconn -> do + -- Execute query + mret <- LibPQ.exec rawconn rawquery + case mret of + Nothing -> do + merr <- LibPQ.errorMessage rawconn + fail $ case merr of + Nothing -> "Postgresql.withStmt': unknown error" + Just e -> "Postgresql.withStmt': " ++ B8.unpack e + Just ret -> do + -- Get number and type of columns + cols <- LibPQ.nfields ret + 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)" + Just bt -> return $ getGetter bt $ + PG.Field ret col $ + PG.builtin2typname bt + -- Ready to go! + rowRef <- newIORef (LibPQ.Row 0) + rowCount <- LibPQ.ntuples ret + return (ret, rowRef, rowCount, getters) -pFromSql :: H.SqlValue -> PersistValue -pFromSql (H.SqlString s) = PersistText $ pack s -pFromSql (H.SqlByteString bs) = PersistByteString bs -pFromSql (H.SqlWord32 i) = PersistInt64 $ fromIntegral i -pFromSql (H.SqlWord64 i) = PersistInt64 $ fromIntegral i -pFromSql (H.SqlInt32 i) = PersistInt64 $ fromIntegral i -pFromSql (H.SqlInt64 i) = PersistInt64 $ fromIntegral i -pFromSql (H.SqlInteger i) = PersistInt64 $ fromIntegral i -pFromSql (H.SqlChar c) = PersistInt64 $ fromIntegral $ fromEnum c -pFromSql (H.SqlBool b) = PersistBool b -pFromSql (H.SqlDouble b) = PersistDouble b -pFromSql (H.SqlRational b) = PersistDouble $ fromRational b -pFromSql (H.SqlLocalDate d) = PersistDay d -pFromSql (H.SqlLocalTimeOfDay d) = PersistTimeOfDay d -pFromSql (H.SqlUTCTime d) = PersistUTCTime d -pFromSql H.SqlNull = PersistNull -pFromSql (H.SqlLocalTime d) = PersistUTCTime $ localTimeToUTC utc d -pFromSql x = PersistText $ pack $ H.fromSql x -- FIXME + closeS (ret, _, _, _) = LibPQ.unsafeFreeResult ret + pullS (ret, rowRef, rowCount, getters) = do + row <- atomicModifyIORef rowRef (\r -> (r+1, r)) + if row == rowCount + then return C.Closed + else fmap C.Open $ forM (zip getters [0..]) $ \(getter, col) -> do + mbs <- LibPQ.getvalue' ret row col + case mbs of + Nothing -> return PersistNull + Just bs -> bs `seq` case getter mbs of + Left exc -> throw exc + Right v -> return v + +-- | Avoid orphan instances. +newtype P = P PersistValue + +instance PG.Param P where + render (P (PersistText t)) = PG.render t + render (P (PersistByteString bs)) = PG.render (PG.Binary bs) + render (P (PersistInt64 i)) = PG.render i + render (P (PersistDouble d)) = PG.render d + render (P (PersistBool b)) = PG.render b + render (P (PersistDay d)) = PG.render d + render (P (PersistTimeOfDay t)) = PG.render t + render (P (PersistUTCTime t)) = PG.render t + render (P PersistNull) = PG.render PG.Null + render (P (PersistList _)) = + error "Refusing to serialize a PersistList to a PostgreSQL value" + render (P (PersistMap _)) = + error "Refusing to serialize a PersistMap to a PostgreSQL value" + render (P (PersistObjectId _)) = + error "Refusing to serialize a PersistObjectId to a PostgreSQL value" + +type Getter a = PG.Field -> Maybe ByteString -> Either SomeException a + +convertPV :: PG.Result a => (a -> b) -> Getter b +convertPV f = (fmap f .) . PG.convert + +-- FIXME: check if those are correct and complete. +getGetter :: PG.BuiltinType -> Getter PersistValue +getGetter PG.Bool = convertPV PersistBool +getGetter PG.Bytea = convertPV (PersistByteString . unBinary) +getGetter PG.Char = convertPV PersistText +getGetter PG.Name = convertPV PersistText +getGetter PG.Int8 = convertPV PersistInt64 +getGetter PG.Int2 = convertPV PersistInt64 +getGetter PG.Int4 = convertPV PersistInt64 +getGetter PG.Text = convertPV PersistText +getGetter PG.Xml = convertPV PersistText +getGetter PG.Float4 = convertPV PersistDouble +getGetter PG.Float8 = convertPV PersistDouble +getGetter PG.Abstime = convertPV PersistUTCTime +getGetter PG.Reltime = convertPV PersistUTCTime +getGetter PG.Money = convertPV PersistDouble +getGetter PG.Bpchar = convertPV PersistText +getGetter PG.Varchar = convertPV PersistText +getGetter PG.Date = convertPV PersistDay +getGetter PG.Time = convertPV PersistTimeOfDay +getGetter PG.Timestamp = convertPV PersistUTCTime +getGetter PG.Bit = convertPV PersistInt64 +getGetter PG.Varbit = convertPV PersistInt64 +getGetter PG.Numeric = convertPV PersistInt64 +getGetter PG.Void = \_ _ -> Right PersistNull +getGetter other = error $ "Postgresql.getGetter: type " ++ + show other ++ " not supported." + +unBinary :: PG.Binary a -> a +unBinary (PG.Binary x) = x + migrate' :: PersistEntity val - => (Text -> IO Statement) + => [EntityDef] + -> (Text -> IO Statement) -> val -> IO (Either [Text] [(Bool, Text)]) -migrate' getter val = do - let name = rawTableName $ entityDef val - old <- getColumns getter name +migrate' allDefs getter val = do + let name = entityDB $ entityDef val + old <- getColumns getter $ entityDef val case partitionEithers old of ([], old'') -> do let old' = partitionEithers old'' - let new = mkColumns val + let new = second (map udToPair) $ mkColumns allDefs val if null old then do let addTable = AddTable $ concat [ "CREATE TABLE " - , escape name - , "(id SERIAL PRIMARY KEY UNIQUE" + , T.unpack $ escape name + , "(" + , T.unpack $ escape $ entityID $ entityDef val + , " SERIAL PRIMARY KEY UNIQUE" , concatMap (\x -> ',' : showColumn x) $ fst new , ")" ] @@ -172,52 +286,57 @@ data AlterColumn = Type SqlType | IsNull | NotNull | Add Column | Drop | Default String | NoDefault | Update String - | AddReference RawName | DropReference RawName -type AlterColumn' = (RawName, AlterColumn) + | AddReference DBName | DropReference DBName +type AlterColumn' = (DBName, AlterColumn) -data AlterTable = AddUniqueConstraint RawName [RawName] - | DropConstraint RawName +data AlterTable = AddUniqueConstraint DBName [DBName] + | DropConstraint DBName data AlterDB = AddTable String - | AlterColumn RawName AlterColumn' - | AlterTable RawName AlterTable + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) - -> RawName -> IO [Either Text (Either Column UniqueDef')] -getColumns getter name = do - stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> 'id'" - cs <- withStmt stmt [PersistText $ pack $ unRawName name] helper + -> EntityDef + -> IO [Either Text (Either Column (DBName, [DBName]))] +getColumns getter def = do + stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> ?" + let vals = + [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def + ] + cs <- C.runResourceT $ withStmt stmt vals C.$$ helper stmt' <- getter - "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> 'id' ORDER BY constraint_name, column_name" - us <- withStmt stmt' [PersistText $ pack $ unRawName name] helperU + "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> ? ORDER BY constraint_name, column_name" + us <- C.runResourceT $ withStmt stmt' vals C.$$ helperU return $ cs ++ us where - getAll pop front = do - x <- pop + getAll front = do + x <- CL.head case x of Nothing -> return $ front [] - Just [PersistByteString con, PersistByteString col] -> - getAll pop (front . (:) (bsToChars con, bsToChars col)) - Just _ -> getAll pop front -- FIXME error message? - helperU pop = do - rows <- getAll pop id - return $ map (Right . Right . (RawName . fst . head &&& map (RawName . snd))) + 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))) $ groupBy ((==) `on` fst) rows - helper pop = do - x <- pop + helper = do + x <- CL.head case x of Nothing -> return [] Just x' -> do - col <- getColumn getter name x' + col <- liftIO $ getColumn getter (entityDB def) x' let col' = case col of Left e -> Left e Right c -> Right $ Left c - cols <- helper pop + cols <- helper return $ col' : cols -getAlters :: ([Column], [UniqueDef']) - -> ([Column], [UniqueDef']) +getAlters :: ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable]) getAlters (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) @@ -226,6 +345,10 @@ getAltersC (new:news) old = let (alters, old') = findAlters new old in alters ++ getAltersC news old' + + getAltersU :: [(DBName, [DBName])] + -> [(DBName, [DBName])] + -> [AlterTable] getAltersU [] old = map (DropConstraint . fst) old getAltersU ((name, cols):news) old = case lookup name old of @@ -239,21 +362,18 @@ : getAltersU news old' getColumn :: (Text -> IO Statement) - -> RawName -> [PersistValue] + -> DBName -> [PersistValue] -> IO (Either Text Column) -getColumn getter tname - [PersistByteString x, PersistByteString y, - PersistByteString z, d] = +getColumn getter tname [PersistText x, PersistText y, PersistText z, d] = case d' of Left s -> return $ Left s Right d'' -> - case getType $ bsToChars z of + case getType z of Left s -> return $ Left s Right t -> do - let cname = RawName $ bsToChars x + let cname = DBName x ref <- getRef cname - return $ Right $ Column cname (bsToChars y == "YES") - t d'' ref + return $ Right $ Column cname (y == "YES") t d'' ref where getRef cname = do let sql = pack $ concat @@ -265,27 +385,27 @@ ] let ref = refName tname cname stmt <- getter sql - withStmt stmt - [ PersistText $ pack $ unRawName tname - , PersistText $ pack $ unRawName ref - ] $ \pop -> do - Just [PersistInt64 i] <- pop - return $ if i == 0 then Nothing else Just (RawName "", ref) + C.runResourceT $ withStmt stmt + [ PersistText $ unDBName tname + , PersistText $ unDBName ref + ] C.$$ do + Just [PersistInt64 i] <- CL.head + return $ if i == 0 then Nothing else Just (DBName "", ref) d' = case d of - PersistNull -> Right Nothing - PersistByteString a -> Right $ Just $ bsToChars a + PersistNull -> Right Nothing + PersistText t -> Right $ Just t _ -> Left $ pack $ "Invalid default column: " ++ show d - getType "int4" = Right $ SqlInt32 - getType "int8" = Right $ SqlInteger - getType "varchar" = Right $ SqlString - getType "date" = Right $ SqlDay - getType "bool" = Right $ SqlBool + getType "int4" = Right $ SqlInt32 + getType "int8" = Right $ SqlInteger + getType "varchar" = Right $ SqlString + getType "date" = Right $ SqlDay + getType "bool" = Right $ SqlBool getType "timestamp" = Right $ SqlDayTime - getType "float4" = Right $ SqlReal - getType "float8" = Right $ SqlReal - getType "bytea" = Right $ SqlBlob - getType "time" = Right $ SqlTime - getType a = Left $ pack $ "Unknown type: " ++ a + getType "float4" = Right $ SqlReal + getType "float8" = Right $ SqlReal + getType "bytea" = Right $ SqlBlob + getType "time" = Right $ SqlTime + getType a = Left $ "Unknown type: " `T.append` a getColumn _ _ x = return $ Left $ pack $ "Invalid result from information_schema: " ++ show x @@ -307,7 +427,7 @@ (False, True) -> let up = case def of Nothing -> id - Just s -> (:) (name, Update s) + Just s -> (:) (name, Update $ T.unpack s) in up [(name, NotNull)] _ -> [] modType = if type_ == type_' then [] else [(name, Type type_)] @@ -316,23 +436,23 @@ then [] else case def of Nothing -> [(name, NoDefault)] - Just s -> [(name, Default s)] + Just s -> [(name, Default $ T.unpack s)] in (modRef ++ modDef ++ modNull ++ modType, filter (\c -> cName c /= name) cols) showColumn :: Column -> String showColumn (Column n nu t def ref) = concat - [ escape n + [ T.unpack $ escape n , " " , showSqlType t , " " , if nu then "NULL" else "NOT NULL" , case def of Nothing -> "" - Just s -> " DEFAULT " ++ s + Just s -> " DEFAULT " ++ T.unpack s , case ref of Nothing -> "" - Just (s, _) -> " REFERENCES " ++ escape s + Just (s, _) -> " REFERENCES " ++ T.unpack (escape s) ] showSqlType :: SqlType -> String @@ -355,147 +475,179 @@ isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) -showAlterTable :: RawName -> AlterTable -> String +showAlterTable :: DBName -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ADD CONSTRAINT " - , escape cname + , T.unpack $ escape cname , " UNIQUE(" - , intercalate "," $ map escape cols + , intercalate "," $ map (T.unpack . escape) cols , ")" ] showAlterTable table (DropConstraint cname) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " DROP CONSTRAINT " - , escape cname + , T.unpack $ escape cname ] -showAlter :: RawName -> AlterColumn' -> String +showAlter :: DBName -> AlterColumn' -> String showAlter table (n, Type t) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ALTER COLUMN " - , escape n + , T.unpack $ escape n , " TYPE " , showSqlType t ] showAlter table (n, IsNull) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ALTER COLUMN " - , escape n + , T.unpack $ escape n , " DROP NOT NULL" ] showAlter table (n, NotNull) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ALTER COLUMN " - , escape n + , T.unpack $ escape n , " SET NOT NULL" ] showAlter table (_, Add col) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ADD COLUMN " , showColumn col ] showAlter table (n, Drop) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " DROP COLUMN " - , escape n + , T.unpack $ escape n ] showAlter table (n, Default s) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ALTER COLUMN " - , escape n + , T.unpack $ escape n , " SET DEFAULT " , s ] showAlter table (n, NoDefault) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ALTER COLUMN " - , escape n + , T.unpack $ escape n , " DROP DEFAULT" ] showAlter table (n, Update s) = concat [ "UPDATE " - , escape table + , T.unpack $ escape table , " SET " - , escape n + , T.unpack $ escape n , "=" , s , " WHERE " - , escape n + , T.unpack $ escape n , " IS NULL" ] showAlter table (n, AddReference t2) = concat [ "ALTER TABLE " - , escape table + , T.unpack $ escape table , " ADD CONSTRAINT " - , escape $ refName table n + , T.unpack $ escape $ refName table n , " FOREIGN KEY(" - , escape n + , T.unpack $ escape n , ") REFERENCES " - , escape t2 + , T.unpack $ escape t2 ] -showAlter table (_, DropReference cname) = - "ALTER TABLE " ++ escape table ++ " DROP CONSTRAINT " ++ escape cname +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , T.unpack (escape table) + , " DROP CONSTRAINT " + , T.unpack $ escape cname + ] -escape :: RawName -> String -escape (RawName s) = - '"' : go s ++ "\"" +escape :: DBName -> Text +escape (DBName s) = + T.pack $ '"' : go (T.unpack s) ++ "\"" where go "" = "" go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs -bsToChars :: ByteString -> String -bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode - --- | Information required to connect to a postgres database +-- | Information required to connect to a PostgreSQL database +-- using @persistent@'s generic facilities. These values are the +-- same that are given to 'withPostgresqlPool'. data PostgresConf = PostgresConf - { pgConnStr :: Text + { pgConnStr :: ConnectionString + -- ^ The connection string. , pgPoolSize :: Int + -- ^ How many connections should be held on the connection pool. } instance PersistConfig PostgresConf where type PersistConfigBackend PostgresConf = SqlPersist type PersistConfigPool PostgresConf = ConnectionPool - withPool (PostgresConf cs size) = withPostgresqlPool cs size + createPoolConfig (PostgresConf cs size) = createPostgresqlPool cs size runPool _ = runSqlPool - loadConfig e' = meither Left Right $ do - e <- go $ fromMapping e' - db <- go $ lookupScalar "database" e - pool' <- go $ lookupScalar "poolsize" e - pool <- safeRead "poolsize" pool' + loadConfig (Object o) = do + database <- o .: "database" + host <- o .: "host" + port <- o .: "port" + user <- o .: "user" + password <- o .: "password" + pool <- o .: "poolsize" + let ci = PG.ConnectInfo + { PG.connectHost = host + , PG.connectPort = port + , PG.connectUser = user + , PG.connectPassword = password + , PG.connectDatabase = database + } + cstr = PG.postgreSQLConnectionString ci + return $ PostgresConf cstr pool + loadConfig _ = mzero - -- TODO: default host/port? - connparts <- forM ["user", "password", "host", "port"] $ \k -> do - v <- go $ lookupScalar k e - return $ T.concat [k, "=", v, " "] + applyEnv c0 = do + env <- getEnvironment + return $ addUser env + $ addPass env + $ addDatabase env + $ addPort env + $ addHost env c0 + where + addParam param val c = + c { pgConnStr = B8.concat [pgConnStr c, " ", param, "='", pgescape val, "'"] } - let conn = T.concat connparts + pgescape = B8.pack . go + where + go ('\'':rest) = '\\' : '\'' : go rest + go ('\\':rest) = '\\' : '\\' : go rest + go ( x :rest) = x : go rest + go [] = [] - return $ PostgresConf (T.concat [conn, " dbname=", db]) pool - where - go :: MEither ObjectExtractError a -> MEither String a - go (MLeft e) = MLeft $ show e - go (MRight a) = MRight a + maybeAddParam param envvar env = + maybe id (addParam param) $ + lookup envvar env -safeRead :: String -> T.Text -> MEither String Int -safeRead name t = case reads s of - (i, _):_ -> MRight i - [] -> MLeft $ concat ["Invalid value for ", name, ": ", s] - where - s = T.unpack t + addHost = maybeAddParam "host" "PGHOST" + addPort = maybeAddParam "port" "PGPORT" + addUser = maybeAddParam "user" "PGUSER" + addPass = maybeAddParam "password" "PGPASS" + addDatabase = maybeAddParam "dbname" "PGDATABASE" + +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.concat [table, "_", column, "_fkey"] + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,11 +1,11 @@ name: persistent-postgresql -version: 0.6.1.3 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Backend for the persistent library using postgresql. -description: Based on the HDBC-postgresql package +description: Based on the postgresql-simple package category: Database, Yesod stability: Stable cabal-version: >= 1.6 @@ -14,17 +14,17 @@ library build-depends: base >= 4 && < 5 - , HDBC >= 2.2.6 && < 2.4 , transformers >= 0.2.1 && < 0.3 - , HDBC-postgresql >= 2.2.3.1 && < 2.4 - , persistent >= 0.6.3 && < 0.7 - , containers >= 0.2 && < 0.5 + , postgresql-simple >= 0.0.3 && < 0.1 + , postgresql-libpq >= 0.6.1 && < 0.7 + , persistent >= 0.7 && < 0.8 + , containers >= 0.2 , bytestring >= 0.9 && < 0.10 , text >= 0.7 && < 0.12 , monad-control >= 0.2 && < 0.4 , time >= 1.1 - , data-object >= 0.3 && < 0.4 - , neither >= 0.3 && < 0.4 + , aeson >= 0.5 + , conduit exposed-modules: Database.Persist.Postgresql ghc-options: -Wall