packages feed

sqlite-simple 0.3.0.0 → 0.4.0.0

raw patch · 10 files changed

+210/−48 lines, 10 filesdep ~direct-sqlite

Dependency ranges changed: direct-sqlite

Files

Database/SQLite/Simple.hs view
@@ -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+-- | <http://www.sqlite.org/c3ref/profile.html>+--+-- 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 <http://www.sqlite.org/c3ref/last_insert_rowid.html>.+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
Database/SQLite/Simple/FromField.hs view
@@ -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"
Database/SQLite/Simple/Internal.hs view
@@ -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 )
Database/SQLite/Simple/ToField.hs view
@@ -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
Database/SQLite/Simple/Types.hs view
@@ -49,7 +49,7 @@ -- -- > {-# LANGUAGE OverloadedStrings #-} -- >--- > import Database.PostgreSQL.Simple+-- > import Database.SQLite.Simple -- > -- > q :: Query -- > q = "select ?"
sqlite-simple.cabal view
@@ -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 <http://github.com/nurpax/sqlite-simple> for usage examples &-    more information.+    Main documentation: "Database.SQLite.Simple"+    .+    For more info, browse to <http://github.com/nurpax/sqlite-simple>+    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,
test/Errors.hs view
@@ -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"
test/Main.hs view
@@ -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.
test/ParamConv.hs view
@@ -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
test/Simple.hs view
@@ -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