diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.0.3 +Version: 0.0.4 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -53,4 +53,4 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.0.3 + tag: v0.0.4 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -69,8 +69,13 @@ , query , query_ -- * Queries that stream results + , FoldOptions(..) + , FetchQuantity(..) + , defaultFoldOptions , fold + , foldWithOptions , fold_ + , foldWithOptions_ , forEach , forEach_ -- * Statements that do not return results @@ -80,8 +85,18 @@ -- , Base.insertID -- * Transaction handling , withTransaction + , TransactionMode(..) + , IsolationLevel(..) + , ReadWriteMode(..) + , defaultTransactionMode + , defaultIsolationLevel + , defaultReadWriteMode + , withTransactionLevel + , withTransactionMode -- , Base.autocommit , begin + , beginLevel + , beginMode , commit , rollback -- * Helper functions @@ -93,7 +108,7 @@ import Blaze.ByteString.Builder.Char8 (fromChar) import Control.Applicative ((<$>), pure) import Control.Concurrent.MVar -import Control.Exception (Exception, bracket, onException, throw, throwIO) +import Control.Exception (Exception, bracket, onException, throw, throwIO, finally) import Control.Monad (foldM) import Control.Monad.Fix (fix) import Data.ByteString (ByteString) @@ -294,11 +309,6 @@ -- results. Results are streamed incrementally from the server, and -- consumed via a left fold. -- --- The result consumer must be carefully written to execute --- quickly. If the consumer is slow, server resources will be tied up, --- and other clients may not be able to update the tables from which --- the results are being streamed. --- -- When dealing with small results, it may be simpler (and perhaps -- faster) to use 'query' instead. -- @@ -313,23 +323,43 @@ -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed. -fold :: (QueryParams q, QueryResults r) => - Connection - -> Query -- ^ Query template. - -> q -- ^ Query parameters. - -> a -- ^ Initial state for result consumer. - -> (a -> r -> IO a) -- ^ Result consumer. - -> IO a -fold conn template qs z f = withConnection conn $ \c -> do - success <- PQ.sendQuery c =<< formatQuery conn template qs - if success - then finishFold conn c template z f - else do - msg <- maybe "fold error" id <$> PQ.errorMessage c - throwIO $ SqlError { sqlNativeError = -1 - , sqlErrorMsg = msg - , sqlState = "" } +fold :: ( QueryResults row, QueryParams params ) + => Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +fold = foldWithOptions defaultFoldOptions + +data FetchQuantity + = Automatic + | Fixed !Int + +data FoldOptions + = FoldOptions { + fetchQuantity :: !FetchQuantity, + transactionMode :: !TransactionMode + } + +defaultFoldOptions = FoldOptions { + fetchQuantity = Automatic, + transactionMode = TransactionMode ReadCommitted ReadOnly + } + +foldWithOptions :: ( QueryResults row, QueryParams params ) + => FoldOptions + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWithOptions opts conn template qs a f = do + q <- formatQuery conn template qs + doFold opts conn template (Query q) a f + -- | A version of 'fold' that does not perform query substitution. fold_ :: (QueryResults r) => Connection @@ -337,16 +367,64 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a -fold_ conn q@(Query que) z f = withConnection conn $ \c -> do - success <- PQ.sendQuery c que - if success - then finishFold conn c q z f - else do - msg <- maybe "fold_ error" id <$> PQ.errorMessage c - throwIO $ SqlError { sqlNativeError = -1 - , sqlErrorMsg = msg - , sqlState = "" } +fold_ = foldWithOptions_ defaultFoldOptions + +foldWithOptions_ :: (QueryResults r) => + FoldOptions + -> Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +foldWithOptions_ opts conn query a f = doFold opts conn query query a f + + +doFold :: ( QueryResults row ) + => FoldOptions + -> Connection + -> Query + -> Query + -> a + -> (a -> row -> IO a) + -> IO a +doFold FoldOptions{..} conn _template q a f = do + stat <- withConnection conn PQ.transactionStatus + case stat of + PQ.TransIdle -> withTransactionMode transactionMode conn go + PQ.TransInTrans -> go + PQ.TransActive -> fail "foldWithOpts FIXME: PQ.TransActive" + -- This _shouldn't_ occur in the current incarnation of + -- the library, as we aren't using libpq asynchronously. + -- However, it could occur in future incarnations of + -- this library or if client code uses the Internal module + -- to use raw libpq commands on postgresql-simple connections. + PQ.TransInError -> fail "foldWithOpts FIXME: PQ.TransInError" + -- This should be turned into a better error message. + -- It is probably a bad idea to automatically roll + -- back the transaction and start another. + PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" + -- Not sure what this means. + where + go = do + -- FIXME: what about name clashes with already-declared cursors? + _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR " + `mappend` q) + loop a `finally` execute_ conn "CLOSE fold" + +-- FIXME: choose the Automatic chunkSize more intelligently +-- One possibility is to use the type of the results, although this +-- still isn't a perfect solution, given that common types (e.g. text) +-- are of highly variable size. +-- A refinement of this technique is to pick this number adaptively +-- as results are read in from the database. + chunkSize = case fetchQuantity of + Automatic -> 256 + Fixed n -> n + loop a = do + rs <- query conn "FETCH FORWARD ? FROM fold" (Only chunkSize) + if null rs then return a else foldM f a rs >>= loop + -- | A version of 'fold' that does not transform a state value. forEach :: (QueryParams q, QueryResults r) => Connection @@ -404,53 +482,36 @@ , sqlErrorMsg = B.concat [ "query: ", statusmsg , ": ", errormsg ]} +-- | Of the four isolation levels defined by the SQL standard, +-- these are the three levels distinguished by PostgreSQL as of version 9.0. +-- See +-- for more information. -finishFold :: (QueryResults r) => - Connection - -> PQ.Connection - -> Query -- ^ Query. - -> a -- ^ Initial state for result consumer. - -> (a -> r -> IO a) -- ^ Result consumer. - -> IO a -finishFold conn c q a_ f = loop a_ - where - loop a = do - mres <- PQ.getResult c - case mres of - Nothing -> return a - Just result -> do - stat <- PQ.resultStatus result - case stat of - PQ.TuplesOk -> do - ncols <- PQ.nfields result - fields <- forM' 0 (ncols-1) $ \column -> do - type_oid <- PQ.ftype result column - typename <- getTypename conn type_oid - return Field{..} - nrows <- PQ.ntuples result - a' <- foldM (\a row -> do - values <- forM' 0 (ncols-1) (PQ.getvalue result row) - case convertResults fields values of - Left err -> clear c >> throwIO err - Right r -> f a r) - a [0..nrows-1] - loop a' - _ -> do - errormsg <- maybe "" id <$> PQ.resultErrorMessage result - statusmsg <- PQ.resStatus stat - state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate - clear c - throwIO $ SqlError { - sqlState = state, - sqlNativeError = fromEnum stat, - sqlErrorMsg = B.concat [ "fold: ", statusmsg - , ": ", errormsg ]} - clear c = do - mres <- PQ.getResult c - case mres of - Nothing -> return () - Just _ -> clear c +data IsolationLevel + = ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Ord, Enum, Bounded) +data ReadWriteMode + = ReadWrite + | ReadOnly + deriving (Show, Eq, Ord, Enum, Bounded) + +data TransactionMode = TransactionMode { + isolationLevel :: !IsolationLevel, + readWriteMode :: !ReadWriteMode + } deriving (Show, Eq) + +defaultTransactionMode :: TransactionMode +defaultTransactionMode = TransactionMode ReadCommitted ReadWrite + +defaultIsolationLevel :: IsolationLevel +defaultIsolationLevel = ReadCommitted + +defaultReadWriteMode :: ReadWriteMode +defaultReadWriteMode = ReadWrite + -- | Execute an action inside a SQL transaction. -- -- This function initiates a transaction with a \"@begin @@ -462,31 +523,53 @@ -- PostgreSQL-related exception), the transaction will be rolled back using -- 'rollback', then the exception will be rethrown. withTransaction :: Connection -> IO a -> IO a -withTransaction conn act = do - _ <- begin conn +withTransaction = withTransactionMode defaultTransactionMode + +-- | Execute an action inside a SQL transaction with a given isolation level. +withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a +withTransactionLevel lvl + = withTransactionMode defaultTransactionMode { isolationLevel = lvl } + +-- | Execute an action inside a SQL transaction with a given transaction mode. +withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a +withTransactionMode mode conn act = do + beginMode mode conn r <- act `onException` rollback conn commit conn return r -- | Rollback a transaction. --- rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m () rollback :: Connection -> IO () -rollback conn = do - _ <- execute_ conn "ABORT" - return () +rollback conn = execute_ conn "ABORT" >> return () -- | Commit a transaction. --- commit :: (MonadCatchIO m,MonadIO m) => Connection -> m () commit :: Connection -> IO () -commit conn = do - _ <- execute_ conn "COMMIT" - return () +commit conn = execute_ conn "COMMIT" >> return () -- | Begin a transaction. --- begin :: (MonadCatchIO m,MonadIO m) => Connection -> m () begin :: Connection -> IO () -begin conn = do - _ <- execute_ conn "BEGIN" +begin = beginMode defaultTransactionMode + +-- | Begin a transaction with a given isolation level +beginLevel :: IsolationLevel -> Connection -> IO () +beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } + +-- | Begin a transaction with a given transaction mode +beginMode :: TransactionMode -> Connection -> IO () +beginMode mode conn = do + execute_ conn $! case mode of + TransactionMode ReadCommitted ReadWrite -> + "BEGIN" + TransactionMode ReadCommitted ReadOnly -> + "BEGIN READ ONLY" + TransactionMode RepeatableRead ReadWrite -> + "BEGIN ISOLATION LEVEL REPEATABLE READ" + TransactionMode RepeatableRead ReadOnly -> + "BEGIN ISOLATION LEVEL REPEATABLE READ READ ONLY" + TransactionMode Serializable ReadWrite -> + "BEGIN ISOLATION LEVEL SERIALIZABLE" + TransactionMode Serializable ReadOnly -> + "BEGIN ISOLATION LEVEL SERIALIZABLE READ ONLY" return () fmtError :: String -> Query -> [Action] -> a diff --git a/src/Database/PostgreSQL/Simple/Param.hs b/src/Database/PostgreSQL/Simple/Param.hs --- a/src/Database/PostgreSQL/Simple/Param.hs +++ b/src/Database/PostgreSQL/Simple/Param.hs @@ -157,12 +157,12 @@ {-# INLINE render #-} instance Param Float where - render v | isNaN v || isInfinite v = renderNull + render v | isNaN v || isInfinite v = Plain (inQuotes (float v)) | otherwise = Plain (float v) {-# INLINE render #-} instance Param Double where - render v | isNaN v || isInfinite v = renderNull + render v | isNaN v || isInfinite v = Plain (inQuotes (double v)) | otherwise = Plain (double v) {-# INLINE render #-} diff --git a/src/Database/PostgreSQL/Simple/QueryResults.hs b/src/Database/PostgreSQL/Simple/QueryResults.hs --- a/src/Database/PostgreSQL/Simple/QueryResults.hs +++ b/src/Database/PostgreSQL/Simple/QueryResults.hs @@ -23,6 +23,7 @@ , convertError ) where +import Control.Applicative (Applicative(..), (<$>)) import Control.Exception (SomeException(..), throw) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B @@ -30,6 +31,7 @@ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..)) import Database.PostgreSQL.Simple.Types (Only(..)) +import qualified Database.PostgreSQL.LibPQ as LibPQ (Result) -- | A collection type that can be converted from a list of strings. -- @@ -42,41 +44,53 @@ -- -- @ -- instance ('Result' a, 'Result' b) => 'QueryResults' (a,b) where --- 'convertResults' [fa,fb] [va,vb] = (a,b) --- where !a = 'convert' fa va --- !b = 'convert' fb vb +-- 'convertResults' [fa,fb] [va,vb] = do +-- !a <- 'convert' fa va +-- !b <- 'convert' fb vb +-- 'return' (a,b) -- 'convertResults' fs vs = 'convertError' fs vs 2 -- @ -- -- Notice that this instance evaluates each element to WHNF before --- constructing the pair. By doing this, we guarantee two important --- properties: +-- constructing the pair. This property is important enough that its +-- a rule all 'QueryResult' instances should follow: -- --- * Keep resource usage under control by preventing the construction --- of potentially long-lived thunks. +-- * Evaluate every 'Result' value to WHNF before constructing +-- the result -- --- * Ensure that any 'ResultError' that might arise is thrown --- immediately, rather than some place later in application code --- that cannot handle it. +-- Doing so keeps resource usage under local control by preventing the +-- construction of potentially long-lived thunks that are forced +-- (or not) by the consumer. -- --- You can also declare Haskell types of your own to be instances of --- 'QueryResults'. +-- This is important to postgresql-simple-0.0.4 because a wayward thunk +-- causes the entire LibPQ.'LibPQ.Result' to be retained. This could lead +-- to a memory leak, depending on how the thunk is consumed. -- +-- Note that instances can be defined outside of postgresql-simple, +-- which is often useful. For example, here is an attempt at an +-- instance for a user-defined pair: +-- -- @ ---data User { firstName :: String, lastName :: String } +-- data User = User { firstName :: String, lastName :: String } -- ---instance 'QueryResults' User where --- 'convertResults' [fa,fb] [va,vb] = User a b --- where !a = 'convert' fa va --- !b = 'convert' fb vb --- 'convertResults' fs vs = 'convertError' fs vs +-- instance 'QueryResults' User where +-- 'convertResults' [fa,qfb] [va,vb] = User \<$\> a \<*\> b +-- where !a = 'convert' fa va +-- !b = 'convert' fb vb +-- 'convertResults' fs vs = 'convertError' fs vs 2 -- @ +-- +-- In this example, the bang patterns are not used correctly. They force +-- the data constructors of the 'Either' type, and are not forcing the +-- 'Result' values we need to force. This gives the consumer of the +-- 'QueryResult' the ability to cause the memory leak, which is an +-- undesirable state of affairs. class QueryResults a where convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a -- ^ Convert values from a row into a Haskell collection. -- - -- This function will throw a 'ResultError' if conversion of the + -- This function will return a 'ResultError' if conversion of the -- collection fails. instance (Result a) => QueryResults (Only a) where @@ -198,6 +212,14 @@ return (a,b,c,d,e,f,g,h,i,j) convertResults fs vs = convertError fs vs 10 +f <$!> (!x) = f <$> x +infixl 4 <$!> + +instance Result a => QueryResults [a] where + convertResults fs vs = foldr convert' (pure []) (zip fs vs) + where convert' (f,v) as = (:) <$!> convert f v <*> as + {-# INLINE convertResults #-} + -- | Throw a 'ConversionFailed' exception, indicating a mismatch -- between the number of columns in the 'Field' and row, and the -- number in the collection to be converted to. @@ -220,3 +242,4 @@ ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs + diff --git a/src/Database/PostgreSQL/Simple/Result.hs b/src/Database/PostgreSQL/Simple/Result.hs --- a/src/Database/PostgreSQL/Simple/Result.hs +++ b/src/Database/PostgreSQL/Simple/Result.hs @@ -26,6 +26,7 @@ ( Result(..) , ResultError(..) + , returnError ) where #include "MachDeps.h" @@ -250,9 +251,13 @@ doConvert f _ _ _ = returnError UnexpectedNull f "" +-- | Given one of the constructors from 'ResultError', the field, +-- and an 'errMessage', this fills in the other fields in the +-- exception value and returns it in a 'Left . SomeException' +-- constructor. returnError :: forall a err . (Typeable a, Exception err) => (String -> String -> String -> err) - -> Field -> String -> Status a + -> Field -> String -> Either SomeException a returnError mkErr f = left . mkErr (B.unpack (typename f)) (show (typeOf (undefined :: a))) diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs --- a/src/Database/PostgreSQL/Simple/SqlQQ.hs +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -15,12 +15,36 @@ import Data.Char -- | 'sql' is a quasiquoter that eases the syntactic burden --- of writing big sql statements in Haskell source code. It attempts --- to minimize whitespace. Note that this implementation is incomplete --- and can mess up your syntax; it only really understands standard --- sql string literals (default in PostgreSQL 9) and not the extended --- escape syntax or other situations where white space should be --- preserved as is. +-- of writing big sql statements in Haskell source code. For example: +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > +-- > query conn [sql| SELECT column_a, column_b +-- > FROM table1 NATURAL JOIN table2 +-- > WHERE ? <= time AND time < ? +-- > AND name LIKE ? +-- > ORDER BY size DESC +-- > LIMIT 100 |] +-- > (beginTime,endTime,string) +-- +-- This quasiquoter attempts to mimimize whitespace; otherwise the +-- above query would consist of approximately half whitespace when sent +-- to the database backend. +-- +-- The implementation of the whitespace reducer is currently incomplete. +-- Thus it can mess up your syntax in cases where whitespace should be +-- preserved as-is. It does preserve whitespace inside standard SQL string +-- literals. But it can get confused by the non-standard PostgreSQL string +-- literal syntax (which is the default setting in PostgreSQL 8 and below), +-- the extended escape string syntax, and other similar constructs. +-- +-- Of course, this caveat only applies to text written inside the SQL +-- quasiquoter; whitespace reduction is a compile-time computation and +-- thus will not touch the @string@ parameter above, which is a run-time +-- value. +-- +-- Also note that this will not work if the substring @|]@ is contained +-- in the query. sql :: QuasiQuoter sql = QuasiQuoter