sqlite-simple 0.2.1.0 → 0.3.0.0
raw patch · 6 files changed
+103/−60 lines, 6 filesdep ~basedep ~direct-sqlitedep ~time
Dependency ranges changed: base, direct-sqlite, time
Files
- Database/SQLite/Simple.hs +91/−36
- Database/SQLite/Simple/Internal.hs +0/−22
- README.markdown +5/−0
- sqlite-simple.cabal +2/−2
- test/Main.hs +2/−0
- test/Simple.hs +3/−0
Database/SQLite/Simple.hs view
@@ -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 {
Database/SQLite/Simple/Internal.hs view
@@ -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)
README.markdown view
@@ -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 -------
sqlite-simple.cabal view
@@ -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,
test/Main.hs view
@@ -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.
test/Simple.hs view
@@ -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