diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs --- a/Database/SQLite/Simple.hs +++ b/Database/SQLite/Simple.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} ------------------------------------------------------------------------------ -- | @@ -49,6 +48,7 @@ -- * Connections , open , close + , withConnection -- * Queries that return results , query , query_ @@ -56,6 +56,8 @@ , execute , execute_ , field + , fold + , fold_ -- ** Exceptions , FormatError(fmtMessage, fmtQuery, fmtParams) , ResultError(errSQLType, errHaskellType, errMessage) @@ -106,6 +108,11 @@ close :: Connection -> IO () close (Connection c) = Base.close c +-- | Opens a database connection, executes an action using this connection, and +-- closes the connection, even in the presence of exceptions. +withConnection :: String -> (Connection -> IO a) -> IO a +withConnection connString = bracket (open connString) close + withBind :: Query -> Base.Statement -> [Base.SQLData] -> IO r -> IO r withBind templ stmt qp action = do stmtParamCount <- Base.bindParameterCount stmt @@ -125,16 +132,23 @@ templ qp Nothing -> return () +withStatement :: Connection -> Query -> (Base.Statement -> IO r) -> IO r +withStatement (Connection c) (Query t) = bracket (Base.prepare c t) Base.finalize + -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. -- -- Throws 'FormatError' if the query could not be formatted correctly. execute :: (ToRow q) => Connection -> Query -> q -> IO () -execute (Connection c) template@(Query t) qs = - bracket (Base.prepare c t) Base.finalize go - where - go stmt = withBind template stmt (toRow qs) (void $ Base.step stmt) +execute conn template qs = + withStatement conn template $ \stmt -> + withBind template stmt (toRow qs) (void $ Base.step stmt) + +doFoldToList :: (FromRow row) => Base.Statement -> IO [row] +doFoldToList stmt = + fmap reverse $ doFold stmt [] (\acc e -> return (e : acc)) + -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this -- function returns. @@ -149,45 +163,86 @@ -- * 'ResultError': result conversion failed. query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] -query (Connection conn) templ@(Query t) qs = - bracket (Base.prepare conn t) Base.finalize go - where - go stmt = withBind templ stmt (toRow qs) (stepStmt stmt >>= finishQuery) +query conn templ qs = + withStatement conn templ $ \stmt -> + withBind templ stmt (toRow qs) (doFoldToList stmt) -- | A version of 'query' that does not perform query substitution. query_ :: (FromRow r) => Connection -> Query -> IO [r] -query_ conn (Query que) = do - result <- exec conn que - finishQuery result +query_ conn query = + withStatement conn query doFoldToList -- | A version of 'execute' that does not perform query substitution. execute_ :: Connection -> Query -> IO () -execute_ (Connection conn) (Query que) = - bracket (Base.prepare conn que) Base.finalize go - where - go stmt = void $ Base.step stmt +execute_ conn template = + withStatement conn template $ \stmt -> + void $ Base.step stmt +-- | Perform a @SELECT@ or other SQL query that is expected to return results. +-- Results are converted and fed into the 'action' callback as they are being +-- retrieved from the database. +-- +-- This allows gives the possibility of processing results in constant space +-- (for instance writing them to disk). +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string mismatched with given arguments. +-- +-- * 'ResultError': result conversion failed. +fold :: ( FromRow row, ToRow params ) + => Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +fold conn query params initalState action = + withStatement conn query $ \stmt -> + withBind query stmt (toRow params) + (doFold stmt initalState action) -finishQuery :: (FromRow r) => Result -> IO [r] -finishQuery rows = - mapM doRow $ zip rows [0..] - where - doRow (rowRes, rowNdx) = do - let rw = Row rowNdx rowRes - case runStateT (runReaderT (unRP fromRow) rw) 0 of - Ok (val,col) | col == ncols -> return val - | otherwise -> do - let vals = map (\f -> (gettypename f, f)) rowRes - throw (ConversionFailed - (show ncols ++ " values: " ++ show vals) - (show col ++ " slots in target type") - "mismatch between number of columns to \ - \convert and number in target type") - Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" - Errors [x] -> throwIO x - Errors xs -> throwIO $ ManyErrors xs +-- | A version of 'fold' which does not perform parameter substitution. +fold_ :: ( FromRow row ) + => Connection + -> Query + -> a + -> (a -> row -> IO a) + -> IO a +fold_ conn query initalState action = + withStatement conn query $ \stmt -> + doFold stmt initalState action - ncols = length . head $ rows +doFold :: (FromRow row) => Base.Statement -> a -> (a -> row -> IO a) -> IO a +doFold stmt initState action = do + nCols <- Base.columnCount stmt + loop (fromIntegral nCols) 0 initState + where + loop nCols i val = do + statRes <- Base.step stmt + case statRes of + Base.Row -> do + rowRes <- Base.columns stmt + res <- convertRow rowRes i nCols + val' <- action val res + loop nCols (i+1) val' + Base.Done -> return val + +convertRow :: (FromRow r) => [Base.SQLData] -> Int -> Int -> IO r +convertRow rowRes rowNdx ncols = do + let rw = Row rowNdx rowRes + case runStateT (runReaderT (unRP fromRow) rw) 0 of + Ok (val,col) | col == ncols -> return val + | otherwise -> do + let vals = map (\f -> (gettypename f, f)) rowRes + throw (ConversionFailed + (show ncols ++ " values: " ++ show vals) + (show col ++ " slots in target type") + "mismatch between number of columns to \ + \convert and number in target type") + Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" + Errors [x] -> throwIO x + Errors xs -> throwIO $ ManyErrors xs fmtError :: String -> Query -> [Base.SQLData] -> a fmtError msg q xs = throw FormatError { diff --git a/Database/SQLite/Simple/Internal.hs b/Database/SQLite/Simple/Internal.hs --- a/Database/SQLite/Simple/Internal.hs +++ b/Database/SQLite/Simple/Internal.hs @@ -23,15 +23,11 @@ import Prelude hiding (catch) import Control.Applicative -import Control.Monad.Fix (fix) -import Control.Exception import Data.ByteString (ByteString) import Data.ByteString.Char8() import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader -import qualified Data.Text as T - import Database.SQLite.Simple.Ok import qualified Database.SQLite3 as Base @@ -53,8 +49,6 @@ newtype RowParser a = RP { unRP :: ReaderT Row (StateT Int Ok) a } deriving ( Functor, Applicative, Alternative, Monad ) -type Result = [[Base.SQLData]] - gettypename :: Base.SQLData -> ByteString gettypename (Base.SQLInteger _) = "INTEGER" gettypename (Base.SQLFloat _) = "FLOAT" @@ -62,19 +56,3 @@ gettypename (Base.SQLBlob _) = "BLOB" gettypename Base.SQLNull = "NULL" -exec :: Connection -> T.Text -> IO Result -exec (Connection conn) q = - bracket (Base.prepare conn q) Base.finalize stepStmt - - --- Run a query on a prepared statement -stepStmt :: Base.Statement -> IO Result -stepStmt stmt = - flip fix [] $ \loop acc -> do - res <- Base.step stmt - case res of - Base.Done -> - return (reverse acc) - Base.Row -> do - !cols <- Base.columns stmt - loop (cols : acc) diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -82,6 +82,11 @@ e-mail to the [database-devel mailing list](http://www.haskell.org/mailman/listinfo/database-devel). +### Contributing + +If you send pull requests for new features, it'd be great if you could also develop unit +tests for any such features. + Credits ------- diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal --- a/sqlite-simple.cabal +++ b/sqlite-simple.cabal @@ -1,5 +1,5 @@ Name: sqlite-simple -Version: 0.2.1.0 +Version: 0.3.0.0 Synopsis: Mid-Level SQLite client library Description: Mid-level SQLite client library, based on postgresql-simple. @@ -39,7 +39,7 @@ base < 5, bytestring >= 0.9, containers, - direct-sqlite >= 2.2 && < 2.3, + direct-sqlite >= 2.2 && < 2.4, text >= 0.11, time, old-locale >= 1.0.0.0, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,6 +11,7 @@ import Utf8Strings import UserInstances import TestImports() +import Fold tests :: [TestEnv -> Test] tests = @@ -27,6 +28,7 @@ , TestLabel "Utf8" . testUtf8Simplest , TestLabel "Utf8" . testBlobs , TestLabel "Instances" . testUserFromField + , TestLabel "Fold" . testFolds ] -- | Action for connecting to the database that will be used for testing. diff --git a/test/Simple.hs b/test/Simple.hs --- a/test/Simple.hs +++ b/test/Simple.hs @@ -53,6 +53,9 @@ assertEqual "select params" "test string" row [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] assertEqual "select params" "test2" row + [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String] + assertEqual "select params" "test string" r1 + assertEqual "select params" "test2" r2 [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int] assertEqual "select int param" 43 i