diff --git a/Database/SQLite3.hs b/Database/SQLite3.hs --- a/Database/SQLite3.hs +++ b/Database/SQLite3.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Database.SQLite3 ( @@ -8,6 +10,9 @@ -- * Simple query execution -- | exec, + execPrint, + execWithCallback, + ExecCallback, -- * Statement management prepare, @@ -45,8 +50,13 @@ columnText, columnBlob, + -- * Result statistics + lastInsertRowId, + changes, + -- * Interrupting a long-running query interrupt, + interruptibly, -- * Types Database, @@ -79,7 +89,6 @@ -- Re-exported from Database.SQLite3.Direct without modification. -- Note that if this module were in another package, source links would not -- be generated for these functions. - , interrupt , clearBindings , bindParameterCount , columnCount @@ -87,17 +96,23 @@ , columnBlob , columnInt64 , columnDouble + , lastInsertRowId + , changes + , interrupt ) import qualified Database.SQLite3.Direct as Direct import Prelude hiding (error) import qualified Data.Text as T +import qualified Data.Text.IO as T import Control.Applicative ((<$>)) -import Control.Exception (Exception, evaluate, throw, throwIO) +import Control.Concurrent +import Control.Exception import Control.Monad (when, zipWithM_) import Data.ByteString (ByteString) import Data.Int (Int64) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (UnicodeException(..), lenientDecode) @@ -146,10 +161,15 @@ instance Exception SQLError +-- | Like 'decodeUtf8', but substitute a custom error message if +-- decoding fails. fromUtf8 :: String -> Utf8 -> IO Text -fromUtf8 desc (Utf8 bs) = - evaluate $ decodeUtf8With (\_ c -> throw (DecodeError desc c)) bs +fromUtf8 desc utf8 = evaluate $ fromUtf8' desc utf8 +fromUtf8' :: String -> Utf8 -> Text +fromUtf8' desc (Utf8 bs) = + decodeUtf8With (\_ c -> throw (DecodeError desc c)) bs + toUtf8 :: Text -> Utf8 toUtf8 = Utf8 . encodeUtf8 @@ -200,12 +220,92 @@ close db = Direct.close db >>= checkError (DetailDatabase db) "close" +-- | Make it possible to interrupt the given database operation with an +-- asynchronous exception. This only works if the program is compiled with +-- base >= 4.3 and @-threaded@. +-- +-- It works by running the callback in a forked thread. If interrupted, +-- it uses 'interrupt' to try to stop the operation. +interruptibly :: Database -> IO a -> IO a +#if MIN_VERSION_base(4,3,0) +interruptibly db io + | rtsSupportsBoundThreads = + mask $ \restore -> do + mv <- newEmptyMVar + tid <- forkIO $ try' (restore io) >>= putMVar mv + + let interruptAndWait = + -- Don't let a second exception interrupt us. Otherwise, + -- the operation will dangle in the background, which could + -- be really bad if it uses locally-allocated resources. + uninterruptibleMask_ $ do + -- Tell SQLite3 to interrupt the current query. + interrupt db + + -- Interrupt the thread in case it's blocked for some + -- other reason. + -- + -- NOTE: killThread blocks until the exception is delivered. + -- That's fine, since we're going to wait for the thread + -- to finish anyway. + killThread tid + + -- Wait for the forked thread to finish. + _ <- takeMVar mv + return () + + e <- takeMVar mv `onException` interruptAndWait + either throwIO return e + | otherwise = io + where + try' :: IO a -> IO (Either SomeException a) + try' = try +#else +interruptibly _db io = io +#endif + -- | Execute zero or more SQL statements delimited by semicolons. exec :: Database -> Text -> IO () exec db sql = Direct.exec db (toUtf8 sql) >>= checkErrorMsg ("exec " `appendShow` sql) +-- | Like 'exec', but print result rows to 'System.IO.stdout'. +-- +-- This is mainly for convenience when experimenting in GHCi. +-- The output format may change in the future. +execPrint :: Database -> Text -> IO () +execPrint !db !sql = + interruptibly db $ + execWithCallback db sql $ \_count _colnames -> T.putStrLn . showValues + where + -- This mimics sqlite3's default output mode. It displays a NULL and an + -- empty string identically. + showValues = T.intercalate "|" . map (fromMaybe "") + +-- | Like 'exec', but invoke the callback for each result row. +execWithCallback :: Database -> Text -> ExecCallback -> IO () +execWithCallback db sql cb = + Direct.execWithCallback db (toUtf8 sql) cb' + >>= checkErrorMsg ("execWithCallback " `appendShow` sql) + where + -- We want 'names' computed once and shared with every call. + cb' count namesUtf8 = + let names = map fromUtf8'' namesUtf8 + {-# NOINLINE names #-} + in \valuesUtf8 -> cb count names (map (fmap fromUtf8'') valuesUtf8) + + fromUtf8'' = fromUtf8' "Database.SQLite3.execWithCallback: Invalid UTF-8" + +type ExecCallback + = ColumnCount -- ^ Number of columns, which is the number of items in + -- the following lists. This will be the same for + -- every row. + -> [Text] -- ^ List of column names. This will be the same + -- for every row. + -> [Maybe Text] -- ^ List of column values, as returned by 'columnText'. + -> IO () + -- | -- -- Unlike 'exec', 'prepare' only executes the first statement, and ignores @@ -340,7 +440,7 @@ -- 'fail' if the list has the wrong number of parameters. bind :: Statement -> [SQLData] -> IO () bind statement sqlData = do - nParams <- fromIntegral <$> bindParameterCount statement + ParamIndex nParams <- bindParameterCount statement when (nParams /= length sqlData) $ fail ("mismatched parameter count for bind. Prepared statement "++ "needs "++ show nParams ++ ", " ++ show (length sqlData) ++" given") diff --git a/Database/SQLite3/Bindings.hs b/Database/SQLite3/Bindings.hs --- a/Database/SQLite3/Bindings.hs +++ b/Database/SQLite3/Bindings.hs @@ -44,6 +44,11 @@ c_sqlite3_column_double, c_sqlite3_column_text, + -- * Result statistics + c_sqlite3_last_insert_rowid, + c_sqlite3_changes, + c_sqlite3_total_changes, + -- * Miscellaneous c_sqlite3_free, ) where @@ -86,11 +91,11 @@ = Ptr a -> CColumnCount -- ^ Number of columns, which is the number of elements in -- the following arrays. - -> Ptr CString -- ^ Array of column names -> Ptr CString -- ^ Array of column values, as returned by -- 'c_sqlite3_column_text'. Null values are represented -- as null pointers. - -> CInt -- ^ If the callback returns non-zero, then + -> Ptr CString -- ^ Array of column names + -> IO CInt -- ^ If the callback returns non-zero, then -- 'c_sqlite3_exec' returns @SQLITE_ABORT@ -- ('ErrorAbort'). @@ -216,6 +221,19 @@ foreign import ccall unsafe "sqlite3_column_double" c_sqlite3_column_double :: Ptr CStatement -> CColumnIndex -> IO Double + + +-- | +foreign import ccall unsafe "sqlite3_last_insert_rowid" + c_sqlite3_last_insert_rowid :: Ptr CDatabase -> IO Int64 + +-- | +foreign import ccall unsafe "sqlite3_changes" + c_sqlite3_changes :: Ptr CDatabase -> IO CInt + +-- | +foreign import ccall unsafe "sqlite3_total_changes" + c_sqlite3_total_changes :: Ptr CDatabase -> IO CInt -- | diff --git a/Database/SQLite3/Direct.hs b/Database/SQLite3/Direct.hs --- a/Database/SQLite3/Direct.hs +++ b/Database/SQLite3/Direct.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -- | -- This API is a slightly lower-level version of "Database.SQLite3". Namely: @@ -11,11 +12,12 @@ open, close, errmsg, - interrupt, -- * Simple query execution -- | exec, + execWithCallback, + ExecCallback, -- * Statement management prepare, @@ -46,6 +48,14 @@ columnText, columnBlob, + -- * Result statistics + lastInsertRowId, + changes, + totalChanges, + + -- * Interrupting a long-running query + interrupt, + -- * Types Database(..), Statement(..), @@ -69,8 +79,13 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Control.Applicative ((<$>)) +import Control.Exception as E +import Control.Monad (join) import Data.ByteString (ByteString) +import Data.IORef +import Data.Monoid import Data.String (IsString(..)) +import Data.Text.Encoding.Error (lenientDecode) import Foreign import Foreign.C @@ -87,12 +102,20 @@ -- | A 'ByteString' containing UTF8-encoded text with no NUL characters. newtype Utf8 = Utf8 ByteString - deriving (Eq, Show) + deriving (Eq, Ord) +instance Show Utf8 where + show (Utf8 s) = (show . T.decodeUtf8With lenientDecode) s + -- | @fromString = Utf8 . 'T.encodeUtf8' . 'T.pack'@ instance IsString Utf8 where fromString = Utf8 . T.encodeUtf8 . T.pack +instance Monoid Utf8 where + mempty = Utf8 BS.empty + mappend (Utf8 a) (Utf8 b) = Utf8 (BS.append a b) + mconcat = Utf8 . BS.concat . map (\(Utf8 s) -> s) + packUtf8 :: a -> (Utf8 -> a) -> CString -> IO a packUtf8 n f cstr | cstr == nullPtr = return n | otherwise = f . Utf8 <$> BS.packCString cstr @@ -101,6 +124,10 @@ packCStringLen cstr len = BS.packCStringLen (cstr, fromIntegral len) +packUtf8Array :: IO a -> (Utf8 -> IO a) -> Int -> Ptr CString -> IO [a] +packUtf8Array onNull onUtf8 count base = + peekArray count base >>= mapM (join . packUtf8 onNull onUtf8) + -- | Like 'unsafeUseAsCStringLen', but if the string is empty, -- never pass the callback a null pointer. unsafeUseAsCStringLenNoNull :: ByteString -> (CString -> CNumBytes -> IO a) -> IO a @@ -192,6 +219,71 @@ return $ Left (err, msg) Right () -> return $ Right () +-- | Like 'exec', but invoke the callback for each result row. +-- +-- If the callback throws an exception, it will be rethrown by +-- 'execWithCallback'. +execWithCallback :: Database -> Utf8 -> ExecCallback -> IO (Either (Error, Utf8) ()) +execWithCallback (Database db) (Utf8 sql) cb = do + abortReason <- newIORef Nothing :: IO (IORef (Maybe SomeException)) + cbCache <- newIORef Nothing :: IO (IORef (Maybe ([Maybe Utf8] -> IO ()))) + -- Cache the partial application of column count and name, so if the + -- caller wants to convert them to something else, it only has to do + -- the conversions once. + + let getCallback cCount cNames = do + m <- readIORef cbCache + case m of + Nothing -> do + names <- packUtf8Array (fail "execWithCallback: NULL column name") + return + (fromIntegral cCount) cNames + let !cb' = cb (fromFFI cCount) names + writeIORef cbCache $ Just cb' + return cb' + Just cb' -> return cb' + + let onExceptionAbort io = + (io >> return 0) `E.catch` \ex -> do + writeIORef abortReason $ Just ex + return 1 + + let cExecCallback _ctx cCount cValues cNames = + onExceptionAbort $ do + cb' <- getCallback cCount cNames + values <- packUtf8Array (return Nothing) + (return . Just) + (fromIntegral cCount) cValues + cb' values + + BS.useAsCString sql $ \sql' -> + alloca $ \msgPtrOut -> + bracket (mkCExecCallback cExecCallback) freeHaskellFunPtr $ + \pExecCallback -> do + let returnError err = do + msgPtr <- peek msgPtrOut + msg <- packUtf8 (Utf8 BS.empty) id msgPtr + c_sqlite3_free msgPtr + return $ Left (err, msg) + rc <- c_sqlite3_exec db sql' pExecCallback nullPtr msgPtrOut + case toResult () rc of + Left ErrorAbort -> do + m <- readIORef abortReason + case m of + Nothing -> returnError ErrorAbort + Just ex -> throwIO ex + Left err -> returnError err + Right () -> return $ Right () + +type ExecCallback + = ColumnCount -- ^ Number of columns, which is the number of items in + -- the following lists. This will be the same for + -- every row. + -> [Utf8] -- ^ List of column names. This will be the same + -- for every row. + -> [Maybe Utf8] -- ^ List of column values, as returned by 'columnText'. + -> IO () + -- | -- -- If the query contains no SQL statements, this returns @@ -314,3 +406,25 @@ ptr <- c_sqlite3_column_blob stmt (toFFI idx) len <- c_sqlite3_column_bytes stmt (toFFI idx) packCStringLen ptr len + + +-- | +lastInsertRowId :: Database -> IO Int64 +lastInsertRowId (Database db) = + c_sqlite3_last_insert_rowid db + +-- | +-- +-- Return the number of rows that were changed, inserted, or deleted +-- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. +changes :: Database -> IO Int +changes (Database db) = + fromIntegral <$> c_sqlite3_changes db + +-- | +-- +-- Return the total number of row changes caused by @INSERT@, @DELETE@, +-- or @UPDATE@ statements since the 'Database' was opened. +totalChanges :: Database -> IO Int +totalChanges (Database db) = + fromIntegral <$> c_sqlite3_total_changes db diff --git a/direct-sqlite.cabal b/direct-sqlite.cabal --- a/direct-sqlite.cabal +++ b/direct-sqlite.cabal @@ -1,11 +1,11 @@ name: direct-sqlite -version: 2.3.1 +version: 2.3.2 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright (c) 2012 Irene Knapp -author: Irene Knapp -maintainer: ireney.knapp@gmail.com +copyright: Copyright (c) 2012, 2013 Irene Knapp +author: Irene Knapp +maintainer: irene.knapp@icloud.com homepage: http://ireneknapp.com/software/ bug-reports: https://github.com/IreneKnapp/direct-sqlite/issues/new category: Database @@ -14,14 +14,17 @@ Build-type: Simple description: This package is not very different from the other SQLite3 bindings out - there, but it fixes a few deficiencies I was finding. It is not as - complete as bindings-sqlite3, but is slightly higher-level, in that it - supports marshalling of data values to and from the database. In - particular, it supports strings encoded as UTF8, and BLOBs represented - as ByteStrings. + there, but it fixes a few deficiencies I was finding. As compared to + bindings-sqlite3, it is slightly higher-level, in that it supports + marshalling of data values to and from the database. In particular, it + supports strings encoded as UTF8, and BLOBs represented as ByteStrings. . Release history: . + [Version 2.3.2] Add execPrint, execWithCallback, and interruptibly functions. + Add bindings for sqlite3_last_insert_rowid and sqlite3_changes. Change the + Show instance of the Utf8 newtype to better match the IsString instance. + . [Version 2.3.1] Upgrade the bundled SQLite3 to 3.7.15. Add bindings for sqlite3_interrupt. Export Int rather than CInt. . @@ -92,7 +95,8 @@ default-language: Haskell2010 - default-extensions: NamedFieldPuns + default-extensions: DeriveDataTypeable + , NamedFieldPuns , OverloadedStrings , Rank2Types , RecordWildCards diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,13 +5,15 @@ import Control.Concurrent import Control.Exception -import Control.Monad (forM_, when) +import Control.Monad (forM_, liftM3, when) import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException(..)) +import Data.Typeable import System.Directory import System.Exit (exitFailure) import System.IO import System.IO.Error (isDoesNotExistError, isUserError) +import System.Timeout (timeout) import Test.HUnit import qualified Data.ByteString as B @@ -33,6 +35,7 @@ regressionTests :: [TestEnv -> Test] regressionTests = [ TestLabel "Exec" . testExec + , TestLabel "ExecCallback" . testExecCallback , TestLabel "Simple" . testSimplest , TestLabel "Prepare" . testPrepare , TestLabel "CloseBusy" . testCloseBusy @@ -44,6 +47,7 @@ , TestLabel "Errors" . testErrors , TestLabel "Integrity" . testIntegrity , TestLabel "DecodeError" . testDecodeError + , TestLabel "ResultStats" . testResultStats ] ++ (if rtsSupportsBoundThreads then [ TestLabel "Interrupt" . testInterrupt @@ -104,6 +108,47 @@ Done <- step stmt return () +data Ex = Ex + deriving (Show, Typeable) + +instance Exception Ex + +testExecCallback :: TestEnv -> Test +testExecCallback TestEnv{..} = TestCase $ + withConn $ \conn -> do + chan <- newChan + let exec' sql = execWithCallback conn sql $ \c n v -> writeChan chan (c, n, v) + exec' "CREATE TABLE foo (a INT, b TEXT); \ + \INSERT INTO foo VALUES (1, 'a'); \ + \INSERT INTO foo VALUES (2, 'b'); \ + \INSERT INTO foo VALUES (3, null); \ + \INSERT INTO foo VALUES (null, 'd'); " + + exec' "SELECT 1, 2, 3" + (3, ["1","2","3"], [Just "1", Just "2", Just "3"]) <- readChan chan + + exec' "SELECT null" + (1, ["null"], [Nothing]) <- readChan chan + + exec' "SELECT * FROM foo" + (2, ["a","b"], [Just "1", Just "a"]) <- readChan chan + (2, ["a","b"], [Just "2", Just "b"]) <- readChan chan + (2, ["a","b"], [Just "3", Nothing ]) <- readChan chan + (2, ["a","b"], [Nothing, Just "d"]) <- readChan chan + + exec' "SELECT * FROM foo WHERE a < 0; SELECT 123" + (1, ["123"], [Just "123"]) <- readChan chan + + exec' "SELECT rowid, f.a, f.b, a || b FROM foo AS f" + (4, ["rowid", "a", "b", "a || b"], [Just "1", Just "1", Just "a", Just "1a"]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "2", Just "2", Just "b", Just "2b"]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "3", Just "3", Nothing , Nothing ]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "4", Nothing , Just "d", Nothing ]) <- readChan chan + + Left Ex <- try $ execWithCallback conn "SELECT 1" $ \_ _ _ -> throwIO Ex + + return () + -- Simplest SELECT testSimplest :: TestEnv -> Test testSimplest TestEnv{..} = TestCase $ do @@ -458,6 +503,35 @@ where invalidUtf8 = Direct.Utf8 $ B.pack [0x80] +testResultStats :: TestEnv -> Test +testResultStats TestEnv{..} = TestCase $ + withConn $ \conn -> do + (0, 0, 0) <- stats conn + exec conn "CREATE TABLE tbl (n INTEGER PRIMARY KEY)" + (0, 0, 0) <- stats conn + exec conn "INSERT INTO tbl DEFAULT VALUES" + (1, 1, 1) <- stats conn + exec conn "INSERT INTO tbl VALUES (123)" + (123, 1, 2) <- stats conn + exec conn "INSERT INTO tbl VALUES (9223372036854775807)" + (maxBound, 1, 3) <- stats conn + exec conn "INSERT INTO tbl DEFAULT VALUES" -- picks a rowid at random + (rowid, 1, 4) <- stats conn + True <- return $ (`notElem` [1, 123, maxBound]) rowid + exec conn "UPDATE tbl SET rowid=rowid+1 WHERE rowid=1 OR rowid=123" + (_, 2, 6) <- stats conn + Left SQLError{ sqlError = ErrorConstraint } + <- try $ exec conn "UPDATE tbl SET rowid=4" + (_, 1, 7) <- stats conn -- quirky behavior + exec conn "DELETE FROM tbl" + (_, 4, 11) <- stats conn + return () + where + stats conn = + liftM3 (,,) (lastInsertRowId conn) + (changes conn) + (Direct.totalChanges conn) + testInterrupt :: TestEnv -> Test testInterrupt TestEnv{..} = TestCase $ withConn $ \conn -> do @@ -476,6 +550,9 @@ _ <- forkIO $ threadDelay 100000 >> interrupt conn Left ErrorInterrupt <- Direct.step stmt Left ErrorInterrupt <- Direct.finalize stmt + + Nothing <- timeout 100000 $ interruptibly conn $ exec conn tripleSum + return () where @@ -493,6 +570,7 @@ assertFailure $ show e Right () -> do -- Make sure multi-row insert actually worked + 2 <- changes conn withStmt conn "SELECT * FROM foo" $ \stmt -> do Row <- step stmt [SQLInteger 1, SQLInteger 2] <- columns stmt