direct-sqlite 2.3.1 → 2.3.2

raw patch · 5 files changed

+334/−20 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Database/SQLite3.hs +105/−5
• Database/SQLite3/Bindings.hs +20/−2
• Database/SQLite3/Direct.hs +116/−2
• direct-sqlite.cabal +14/−10
• test/Main.hs +79/−1

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Database.SQLite3 (@@ -8,6 +10,9 @@     -- * Simple query execution     -- | <http://sqlite.org/c3ref/exec.html>     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 ()+ -- | <http://www.sqlite.org/c3ref/prepare.html> -- -- 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")

@@ -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+++-- | <http://www.sqlite.org/c3ref/last_insert_rowid.html>+foreign import ccall unsafe "sqlite3_last_insert_rowid"+    c_sqlite3_last_insert_rowid :: Ptr CDatabase -> IO Int64++-- | <http://www.sqlite.org/c3ref/changes.html>+foreign import ccall unsafe "sqlite3_changes"+    c_sqlite3_changes :: Ptr CDatabase -> IO CInt++-- | <http://www.sqlite.org/c3ref/total_changes.html>+foreign import ccall unsafe "sqlite3_total_changes"+    c_sqlite3_total_changes :: Ptr CDatabase -> IO CInt   -- | <http://sqlite.org/c3ref/free.html>

@@ -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     -- | <http://sqlite.org/c3ref/exec.html>     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 ()+ -- | <http://www.sqlite.org/c3ref/prepare.html> -- -- 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+++-- | <http://www.sqlite.org/c3ref/last_insert_rowid.html>+lastInsertRowId :: Database -> IO Int64+lastInsertRowId (Database db) =+    c_sqlite3_last_insert_rowid db++-- | <http://www.sqlite.org/c3ref/changes.html>+--+-- 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++-- | <http://www.sqlite.org/c3ref/total_changes.html>+--+-- 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

@@ -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 <ireney.knapp@gmail.com>-maintainer: ireney.knapp@gmail.com+copyright: Copyright (c) 2012, 2013 Irene Knapp+author: Irene Knapp <irene.knapp@icloud.com>+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

@@ -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