diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs --- a/Database/SQLite/Simple.hs +++ b/Database/SQLite/Simple.hs @@ -44,35 +44,47 @@ , Only(..) , (:.)(..) , Base.SQLData(..) - + , Statement -- * Connections , open , close , withConnection + , setTrace -- * Queries that return results , query , query_ + , lastInsertRowId -- * Statements that do not return results , execute , execute_ , field , fold , fold_ + -- * Low-level statement API for stream access and prepared statements + , openStatement + , closeStatement + , withStatement + , bind + , reset + , withBind + , nextRow -- ** Exceptions , FormatError(fmtMessage, fmtQuery, fmtParams) , ResultError(errSQLType, errHaskellType, errMessage) ) where import Control.Applicative -import Control.Exception - ( Exception, throw, throwIO, bracket ) +import Control.Exception (Exception, throw, throwIO, bracket) import Control.Monad (void, when) import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict +import Data.Int (Int64) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Data.Typeable (Typeable) import Database.SQLite.Simple.Types import qualified Database.SQLite3 as Base +import qualified Database.SQLite3.Direct as BaseD import Database.SQLite.Simple.FromField (ResultError(..)) @@ -81,6 +93,9 @@ import Database.SQLite.Simple.ToRow (ToRow(..)) import Database.SQLite.Simple.FromRow +-- | An SQLite prepared statement. +newtype Statement = Statement Base.Statement + -- | Exception thrown if a 'Query' was malformed. -- This may occur if the number of \'@?@\' characters in the query -- string does not match the number of parameters provided. @@ -113,18 +128,36 @@ 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 +-- | +-- +-- Enable/disable tracing of SQL execution. Tracing can be disabled +-- by setting 'Nothing' as the logger callback. +-- +-- Warning: If the logger callback throws an exception, your whole +-- program may crash. Enable only for debugging! +setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO () +setTrace (Connection db) logger = + BaseD.setTrace db (fmap (\lf -> lf . unUtf8) logger) + where + unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs + +-- | Binds parameters to a prepared statement. Once 'nextRow' returns 'Nothing', +-- the statement must be reset with the 'reset' function before it can be +-- executed again by calling 'nextRow'. +bind :: (ToRow params) => Statement -> params -> IO () +bind (Statement stmt) params = do + let qp = toRow params stmtParamCount <- Base.bindParameterCount stmt when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount) - mapM_ errorCheckParamName [1..stmtParamCount] + mapM_ (errorCheckParamName qp) [1..stmtParamCount] Base.bind stmt qp - action where - throwColumnMismatch qp nParams = + throwColumnMismatch qp nParams = do + templ <- getQuery stmt fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ show (length qp) ++ " arguments given") templ qp - errorCheckParamName paramNdx = do + errorCheckParamName qp paramNdx = do + templ <- getQuery stmt name <- Base.bindParameterName stmt paramNdx case name of Just n -> @@ -132,20 +165,55 @@ 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 +-- | Resets a statement. This does not reset bound parameters, if any, but +-- allows the statement to be reexecuted again by invoking 'nextRow'. +reset :: Statement -> IO () +reset (Statement stmt) = Base.reset stmt +-- | Binds parameters to a prepared statement and then resets them, even in the +-- presence of exceptions. +withBind :: (ToRow params) => Statement -> params -> IO a -> IO a +withBind stmt params io = + bracket (bind stmt params >> return stmt) reset (const io) + +-- | Opens a prepared statement. A prepared statement must always be closed with +-- a corresponding call to 'closeStatement' before closing the connection. Use +-- 'nextRow' to iterate on the values returned. Once 'nextRow' returns +-- 'Nothing', you need to invoke 'reset' before reexecuting the statement again +-- with 'nextRow'. +openStatement :: Connection -> Query -> IO Statement +openStatement (Connection c) (Query t) = do + stmt <- Base.prepare c t + return $ Statement stmt + +-- | Closes a prepared statement. +closeStatement :: Statement -> IO () +closeStatement (Statement stmt) = Base.finalize stmt + +-- | Opens a prepared statement, executes an action using this statement, and +-- closes the statement, even in the presence of exceptions. +withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a +withStatement conn query = bracket (openStatement conn query) closeStatement + +-- A version of 'withStatement' which binds parameters. +withStatementP :: (ToRow params) => Connection -> Query -> params -> (Statement -> IO a) -> IO a +withStatementP conn template params action = + withStatement conn template $ \stmt -> + -- Don't use withBind here, there is no need to reset the parameters since + -- we're destroying the statement + bind stmt (toRow params) >> action stmt + -- | 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 conn template qs = - withStatement conn template $ \stmt -> - withBind template stmt (toRow qs) (void $ Base.step stmt) + withStatementP conn template qs $ \(Statement stmt) -> + void . Base.step $ stmt -doFoldToList :: (FromRow row) => Base.Statement -> IO [row] +doFoldToList :: (FromRow row) => Statement -> IO [row] doFoldToList stmt = fmap reverse $ doFold stmt [] (\acc e -> return (e : acc)) @@ -164,8 +232,8 @@ query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query conn templ qs = - withStatement conn templ $ \stmt -> - withBind templ stmt (toRow qs) (doFoldToList stmt) + withStatementP conn templ qs $ \stmt -> + doFoldToList stmt -- | A version of 'query' that does not perform query substitution. query_ :: (FromRow r) => Connection -> Query -> IO [r] @@ -175,7 +243,7 @@ -- | A version of 'execute' that does not perform query substitution. execute_ :: Connection -> Query -> IO () execute_ conn template = - withStatement conn template $ \stmt -> + withStatement conn template $ \(Statement stmt) -> void $ Base.step stmt -- | Perform a @SELECT@ or other SQL query that is expected to return results. @@ -198,9 +266,8 @@ -> (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) + withStatementP conn query params $ \stmt -> + doFold stmt initalState action -- | A version of 'fold' which does not perform parameter substitution. fold_ :: ( FromRow row ) @@ -213,24 +280,33 @@ withStatement conn query $ \stmt -> doFold stmt initalState action -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 +doFold :: (FromRow row) => Statement -> a -> (a -> row -> IO a) -> IO a +doFold stmt initState action = + loop 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 + loop val = do + maybeNextRow <- nextRow stmt + case maybeNextRow of + Just row -> do + val' <- action val row + loop val' + Nothing -> return val -convertRow :: (FromRow r) => [Base.SQLData] -> Int -> Int -> IO r -convertRow rowRes rowNdx ncols = do - let rw = Row rowNdx rowRes +-- | Extracts the next row from the prepared statement. +nextRow :: (FromRow r) => Statement -> IO (Maybe r) +nextRow (Statement stmt) = do + statRes <- Base.step stmt + case statRes of + Base.Row -> do + rowRes <- Base.columns stmt + let nCols = length rowRes + row <- convertRow rowRes nCols + return $ Just row + Base.Done -> return Nothing + +convertRow :: (FromRow r) => [Base.SQLData] -> Int -> IO r +convertRow rowRes ncols = do + let rw = Row rowRes case runStateT (runReaderT (unRP fromRow) rw) 0 of Ok (val,col) | col == ncols -> return val | otherwise -> do @@ -244,12 +320,26 @@ Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs +-- | Returns the rowid of the most recent successful INSERT on the +-- given database connection. +-- +-- See also . +lastInsertRowId :: Connection -> IO Int64 +lastInsertRowId (Connection c) = BaseD.lastInsertRowId c + fmtError :: String -> Query -> [Base.SQLData] -> a fmtError msg q xs = throw FormatError { fmtMessage = msg , fmtQuery = q , fmtParams = map show xs } + +getQuery :: Base.Statement -> IO Query +getQuery stmt = + toQuery <$> BaseD.statementSql stmt + where + toQuery = + Query . maybe "no query string" (\(BaseD.Utf8 s) -> TE.decodeUtf8 s) -- $use -- Create a test database by copy pasting the below snippet to your diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs --- a/Database/SQLite/Simple/FromField.hs +++ b/Database/SQLite/Simple/FromField.hs @@ -128,6 +128,13 @@ fromField (Field (SQLFloat flt) _) = Ok flt fromField f = returnError ConversionFailed f "need a float" +instance FromField Bool where + fromField f@(Field (SQLInteger b) _) + | (b == 0) || (b == 1) = Ok (b /= 0) + | otherwise = returnError ConversionFailed f ("bool must be 0 or 1, got " ++ show b) + + fromField f = returnError ConversionFailed f "need a float" + instance FromField T.Text where fromField (Field (SQLText txt) _) = Ok txt fromField f = returnError ConversionFailed f "need a text" 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 @@ -41,10 +41,7 @@ , column :: {-# UNPACK #-} !Int } -data Row = Row { - row :: {-# UNPACK #-} !Int - , rowresult :: [Base.SQLData] - } +newtype Row = Row { rowresult :: [Base.SQLData] } newtype RowParser a = RP { unRP :: ReaderT Row (StateT Int Ok) a } deriving ( Functor, Applicative, Alternative, Monad ) diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs --- a/Database/SQLite/Simple/ToField.hs +++ b/Database/SQLite/Simple/ToField.hs @@ -52,8 +52,8 @@ {-# INLINE toField #-} instance ToField Bool where - toField True = SQLText "true" - toField False = SQLText "false" + toField False = SQLInteger 0 + toField True = SQLInteger 1 {-# INLINE toField #-} instance ToField Int8 where diff --git a/Database/SQLite/Simple/Types.hs b/Database/SQLite/Simple/Types.hs --- a/Database/SQLite/Simple/Types.hs +++ b/Database/SQLite/Simple/Types.hs @@ -49,7 +49,7 @@ -- -- > {-# LANGUAGE OverloadedStrings #-} -- > --- > import Database.PostgreSQL.Simple +-- > import Database.SQLite.Simple -- > -- > q :: Query -- > q = "select ?" diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal --- a/sqlite-simple.cabal +++ b/sqlite-simple.cabal @@ -1,11 +1,13 @@ Name: sqlite-simple -Version: 0.3.0.0 +Version: 0.4.0.0 Synopsis: Mid-Level SQLite client library Description: Mid-level SQLite client library, based on postgresql-simple. . - See for usage examples & - more information. + Main documentation: "Database.SQLite.Simple" + . + For more info, browse to + for examples & more information. License: BSD3 License-file: LICENSE @@ -39,7 +41,7 @@ base < 5, bytestring >= 0.9, containers, - direct-sqlite >= 2.2 && < 2.4, + direct-sqlite >= 2.3.3 && < 2.4, text >= 0.11, time, old-locale >= 1.0.0.0, diff --git a/test/Errors.hs b/test/Errors.hs --- a/test/Errors.hs +++ b/test/Errors.hs @@ -3,6 +3,7 @@ module Errors ( testErrorsColumns , testErrorsInvalidParams + , testErrorsWithStatement ) where import Prelude hiding (catch) @@ -11,6 +12,7 @@ import Data.Word import Common +import Database.SQLite3 (SQLError) assertResultErrorCaught :: IO a -> Assertion assertResultErrorCaught action = do @@ -22,6 +24,11 @@ catch (action >> return False) (\(_ :: FormatError) -> return True) >>= assertBool "assertFormatError exc" +assertSQLErrorCaught :: IO a -> Assertion +assertSQLErrorCaught action = do + catch (action >> return False) (\(_ :: SQLError) -> return True) >>= + assertBool "assertErrorError exc" + testErrorsColumns :: TestEnv -> Test testErrorsColumns TestEnv{..} = TestCase $ do execute_ conn "CREATE TABLE cols (id INTEGER PRIMARY KEY, t TEXT)" @@ -42,7 +49,14 @@ assertResultErrorCaught (do [Only _t1] <- query conn "SELECT b FROM cols_blobs WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] return ()) + execute_ conn "CREATE TABLE cols_bools (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- 3 = invalid value for bool, must be 0 or 1 + execute_ conn "INSERT INTO cols_bools (b) VALUES (3)" + assertResultErrorCaught + (do [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool] + return ()) + testErrorsInvalidParams :: TestEnv -> Test testErrorsInvalidParams TestEnv{..} = TestCase $ do execute_ conn "CREATE TABLE invparams (id INTEGER PRIMARY KEY, t TEXT)" @@ -55,3 +69,10 @@ -- execute. This should cause an error. assertFormatErrorCaught (execute conn "INSERT INTO invparams (id, t) VALUES (?, ?)" (Only (3::Int))) + +testErrorsWithStatement :: TestEnv -> Test +testErrorsWithStatement TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE invstat (id INTEGER PRIMARY KEY, t TEXT)" + assertSQLErrorCaught $ + withStatement conn "SELECT id, t, t1 FROM invstat" $ \_stmt -> + assertFailure "Error not detected" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,6 +12,8 @@ import UserInstances import TestImports() import Fold +import Statement +import Debug tests :: [TestEnv -> Test] tests = @@ -20,15 +22,22 @@ , TestLabel "Simple" . testSimpleParams , TestLabel "Simple" . testSimpleTime , TestLabel "Simple" . testSimpleTimeFract + , TestLabel "Simple" . testSimpleInsertId , TestLabel "ParamConv" . testParamConvInt , TestLabel "ParamConv" . testParamConvFloat , TestLabel "ParamConv" . testParamConvDateTime + , TestLabel "ParamConv" . testParamConvBools , TestLabel "Errors" . testErrorsColumns , TestLabel "Errors" . testErrorsInvalidParams + , TestLabel "Errors" . testErrorsWithStatement , TestLabel "Utf8" . testUtf8Simplest , TestLabel "Utf8" . testBlobs , TestLabel "Instances" . testUserFromField , TestLabel "Fold" . testFolds + , TestLabel "Statement" . testBind + , TestLabel "Statement" . testDoubleBind + , TestLabel "Statement" . testPreparedStatements + , TestLabel "Debug" . testDebugTracing ] -- | Action for connecting to the database that will be used for testing. diff --git a/test/ParamConv.hs b/test/ParamConv.hs --- a/test/ParamConv.hs +++ b/test/ParamConv.hs @@ -2,6 +2,7 @@ module ParamConv ( testParamConvInt , testParamConvFloat + , testParamConvBools , testParamConvDateTime) where import Data.Int @@ -60,3 +61,21 @@ assertEqual "day" (read "2012-08-12" :: Day) t1 assertEqual "day" (read "2012-08-12 01:01:01" :: UTCTime) t2 + +testParamConvBools :: TestEnv -> Test +testParamConvBools TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE bt (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- Booleans are ints with values 0 or 1 on SQLite + execute_ conn "INSERT INTO bt (b) VALUES (0)" + execute_ conn "INSERT INTO bt (b) VALUES (1)" + [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool] + assertEqual "bool" False r1 + assertEqual "bool" True r2 + execute conn "INSERT INTO bt (b) VALUES (?)" (Only True) + execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) + execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) + [Only r3, Only r4, Only r5] <- + query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool] + assertEqual "bool" True r3 + assertEqual "bool" False r4 + assertEqual "bool" False r5 diff --git a/test/Simple.hs b/test/Simple.hs --- a/test/Simple.hs +++ b/test/Simple.hs @@ -5,7 +5,9 @@ , testSimpleSelect , testSimpleParams , testSimpleTime - , testSimpleTimeFract) where + , testSimpleTimeFract + , testSimpleInsertId + ) where import qualified Data.Text as T import Data.Time (UTCTime) @@ -90,3 +92,18 @@ rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime] assertEqual "should see one row result" 1 (length rows) assertEqual "UTCTime" time t + +testSimpleInsertId :: TestEnv -> Test +testSimpleInsertId TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE test_row_id (id INTEGER PRIMARY KEY, t TEXT)" + execute conn "INSERT INTO test_row_id (t) VALUES (?)" (Only ("test string" :: String)) + id1 <- lastInsertRowId conn + execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')" + id2 <- lastInsertRowId conn + 1 @=? id1 + 2 @=? id2 + rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] + 1 @=? (length rows) + (Only "test string") @=? (head rows) + [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] + "test2" @=? row