persistent-postgresql 0.6.1.3 → 0.7.0
raw patch · 2 files changed
+366/−214 lines, 2 filesdep +aesondep +conduitdep +postgresql-libpqdep −HDBCdep −HDBC-postgresqldep −data-objectdep ~containersdep ~persistent
Dependencies added: aeson, conduit, postgresql-libpq, postgresql-simple
Dependencies removed: HDBC, HDBC-postgresql, data-object, neither
Dependency ranges changed: containers, persistent
Files
- Database/Persist/Postgresql.hs +358/−206
- persistent-postgresql.cabal +8/−8
Database/Persist/Postgresql.hs view
@@ -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+-- <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>+-- 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)
persistent-postgresql.cabal view
@@ -1,11 +1,11 @@ name: persistent-postgresql-version: 0.6.1.3+version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> 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