diff --git a/Database/MySQL/Simple.hs b/Database/MySQL/Simple.hs --- a/Database/MySQL/Simple.hs +++ b/Database/MySQL/Simple.hs @@ -60,6 +60,11 @@ -- * Queries that return results , query , query_ + -- * Queries that stream results + , fold + , fold_ + , forEach + , forEach_ -- * Statements that do not return results , execute , execute_ @@ -78,14 +83,15 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import Control.Applicative ((<$>), pure) -import Control.Exception (Exception, onException, throw) +import Control.Exception (Exception, bracket, onException, throw, throwIO) import Control.Monad.Fix (fix) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mappend, mconcat) import Data.Typeable (Typeable) -import Database.MySQL.Base (Connection) +import Database.MySQL.Base (Connection, Result) +import Database.MySQL.Base.Types (Field) import Database.MySQL.Simple.Param (Action(..), inQuotes) import Database.MySQL.Simple.QueryParams (QueryParams(..)) import Database.MySQL.Simple.QueryResults (QueryResults(..)) @@ -182,13 +188,13 @@ execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do Base.query conn =<< formatQuery conn template qs - finishExecute template conn + finishExecute conn template -- | A version of 'execute' that does not perform query substitution. execute_ :: Connection -> Query -> IO Int64 execute_ conn q@(Query stmt) = do Base.query conn stmt - finishExecute q conn + finishExecute conn q -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. @@ -200,21 +206,22 @@ executeMany _ _ [] = return 0 executeMany conn q qs = do Base.query conn =<< formatMany conn q qs - finishExecute q conn + finishExecute conn q -finishExecute :: Query -> Connection -> IO Int64 -finishExecute q conn = do +finishExecute :: Connection -> Query -> IO Int64 +finishExecute conn q = do ncols <- Base.fieldCount (Left conn) if ncols /= 0 - then throw $ QueryError ("execute resulted in " ++ show ncols ++ - "-column result") q + then throwIO $ QueryError ("execute resulted in " ++ show ncols ++ + "-column result") q else Base.affectedRows conn -- | Perform a @SELECT@ or other SQL query that is expected to return --- results. +-- results. All results are retrieved and converted before this +-- function returns. -- --- All results are retrieved and converted before this function --- returns. +-- When processing large results, this function will consume a lot of +-- client-side memory. Consider using 'fold' instead. -- -- Exceptions that may be thrown: -- @@ -228,28 +235,102 @@ => Connection -> Query -> q -> IO [r] query conn template qs = do Base.query conn =<< formatQuery conn template qs - finishQuery template conn + finishQuery conn template -- | A version of 'query' that does not perform query substitution. query_ :: (QueryResults r) => Connection -> Query -> IO [r] query_ conn q@(Query que) = do Base.query conn que - finishQuery q conn + finishQuery conn q -finishQuery :: (QueryResults r) => Query -> Connection -> IO [r] -finishQuery q conn = do - r <- Base.storeResult conn +-- | Perform a @SELECT@ or other SQL query that is expected to return +-- 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. +-- +-- This fold is /not/ strict. The stream consumer is responsible for +-- forcing the evaluation of its result to avoid space leaks. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string could not be formatted correctly. +-- +-- * 'QueryError': the result contains no columns (i.e. you should be +-- 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 = do + Base.query conn =<< formatQuery conn template qs + finishFold conn template z f + +-- | A version of 'fold' that does not perform query substitution. +fold_ :: (QueryResults r) => + Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +fold_ conn q@(Query que) z f = do + Base.query conn que + finishFold conn q z f + +-- | A version of 'fold' that does not transform a state value. +forEach :: (QueryParams q, QueryResults r) => + Connection + -> Query -- ^ Query template. + -> q -- ^ Query parameters. + -> (r -> IO ()) -- ^ Result consumer. + -> IO () +forEach conn template qs = fold conn template qs () . const +{-# INLINE forEach #-} + +-- | A version of 'forEach' that does not perform query substitution. +forEach_ :: (QueryResults r) => + Connection + -> Query -- ^ Query template. + -> (r -> IO ()) -- ^ Result consumer. + -> IO () +forEach_ conn template = fold_ conn template () . const +{-# INLINE forEach_ #-} + +finishQuery :: (QueryResults r) => Connection -> Query -> IO [r] +finishQuery conn q = withResult (Base.storeResult conn) q $ \r fs -> + flip fix [] $ \loop acc -> do + row <- Base.fetchRow r + case row of + [] -> return (reverse acc) + _ -> let !c = convertResults fs row + in loop (c:acc) + +finishFold :: (QueryResults r) => + Connection -> Query -> a -> (a -> r -> IO a) -> IO a +finishFold conn q z0 f = withResult (Base.useResult conn) q $ \r fs -> + flip fix z0 $ \loop z -> do + row <- Base.fetchRow r + case row of + [] -> return z + _ -> (f z $! convertResults fs row) >>= loop + +withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a +withResult fetchResult q act = bracket fetchResult Base.freeResult $ \r -> do ncols <- Base.fieldCount (Right r) if ncols == 0 - then throw $ QueryError "query resulted in zero-column result" q - else do - fs <- Base.fetchFields r - flip fix [] $ \loop acc -> do - row <- Base.fetchRow r - case row of - [] -> return (reverse acc) - _ -> let !c = convertResults fs row - in loop (c:acc) + then throwIO $ QueryError "query resulted in zero-column result" q + else act r =<< Base.fetchFields r -- | Execute an action inside a SQL transaction. -- @@ -263,7 +344,7 @@ -- 'Base.rollback', then the exception will be rethrown. withTransaction :: Connection -> IO a -> IO a withTransaction conn act = do - execute_ conn "start transaction" + _ <- execute_ conn "start transaction" r <- act `onException` Base.rollback conn Base.commit conn return r diff --git a/mysql-simple.cabal b/mysql-simple.cabal --- a/mysql-simple.cabal +++ b/mysql-simple.cabal @@ -1,5 +1,5 @@ name: mysql-simple -version: 0.2.0.2 +version: 0.2.1.0 homepage: https://github.com/mailrank/mysql-simple bug-reports: https://github.com/mailrank/mysql-simple/issues synopsis: A mid-level MySQL client library.