add support for incremental blob I/O

IreneKnapp · Jan 21, 2015 · 382abe6 · 382abe6
1 parent 5297537
commit 382abe6
Show file tree

Hide file tree

Showing 5 changed files with 220 additions and 0 deletions.
diff --git a/Database/SQLite3.hs b/Database/SQLite3.hs
@@ -88,6 +88,15 @@ module Database.SQLite3 (
     interrupt,
     interruptibly,
 
+    -- * Incremental blob I/O
+    blobOpen,
+    blobClose,
+    blobReopen,
+    blobBytes,
+    blobRead,
+    blobReadBuf,
+    blobWrite,
+
     -- * Types
     Database,
     Statement,
@@ -96,6 +105,7 @@ module Database.SQLite3 (
     ColumnType(..),
     FuncContext,
     FuncArgs,
+    Blob,
 
     -- ** Results and errors
     StepResult(..),
@@ -123,6 +133,7 @@ import Database.SQLite3.Direct
     , FuncArgs
     , ArgCount(..)
     , ArgIndex
+    , Blob
 
     -- Re-exported from Database.SQLite3.Direct without modification.
     -- Note that if this module were in another package, source links would not
@@ -148,6 +159,7 @@ import Database.SQLite3.Direct
     , lastInsertRowId
     , changes
     , interrupt
+    , blobBytes
     )
 
 import qualified Database.SQLite3.Direct as Direct
@@ -166,6 +178,7 @@ import Data.Text            (Text)
 import Data.Text.Encoding   (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (UnicodeException(..), lenientDecode)
 import Data.Typeable
+import Foreign.Ptr          (Ptr)
 
 data SQLData
     = SQLInteger    !Int64
@@ -679,3 +692,56 @@ deleteCollation :: Database -> Text -> IO ()
 deleteCollation db name =
     Direct.deleteCollation db (toUtf8 name)
         >>= checkError (DetailDatabase db) ("deleteCollation " `appendShow` name)
+
+
+-- | <https://www.sqlite.org/c3ref/blob_open.html>
+--
+-- Open a blob for incremental I/O.
+blobOpen
+    :: Database
+    -> Text   -- ^ The symbolic name of the database (e.g. "main").
+    -> Text   -- ^ The table name.
+    -> Text   -- ^ The column name.
+    -> Int64  -- ^ The @ROWID@ of the row.
+    -> Bool   -- ^ Open the blob for read-write.
+    -> IO Blob
+blobOpen db zDb zTable zColumn rowid rw =
+    Direct.blobOpen db (toUtf8 zDb) (toUtf8 zTable) (toUtf8 zColumn) rowid rw
+        >>= checkError (DetailDatabase db) "blobOpen"
+
+-- | <https://www.sqlite.org/c3ref/blob_close.html>
+blobClose :: Blob -> IO ()
+blobClose blob@(Direct.Blob db _) =
+    Direct.blobClose blob
+        >>= checkError (DetailDatabase db) "blobClose"
+
+-- | <https://www.sqlite.org/c3ref/blob_reopen.html>
+blobReopen :: Blob -> Int64 -> IO ()
+blobReopen blob@(Direct.Blob db _) rowid =
+    Direct.blobReopen blob rowid
+        >>= checkError (DetailDatabase db) "blobReopen"
+
+-- | <https://www.sqlite.org/c3ref/blob_read.html>
+blobRead
+    :: Blob
+    -> Int -- ^ Number of bytes to read.
+    -> Int -- ^ Offset within the blob.
+    -> IO ByteString
+blobRead blob@(Direct.Blob db _) len offset =
+    Direct.blobRead blob len offset
+        >>= checkError (DetailDatabase db) "blobRead"
+
+blobReadBuf :: Blob -> Ptr a -> Int -> Int -> IO ()
+blobReadBuf blob@(Direct.Blob db _) buf len offset =
+    Direct.blobReadBuf blob buf len offset
+        >>= checkError (DetailDatabase db) "blobReadBuf"
+
+-- | <https://www.sqlite.org/c3ref/blob_write.html>
+blobWrite
+    :: Blob
+    -> ByteString
+    -> Int -- ^ Offset within the blob.
+    -> IO ()
+blobWrite blob@(Direct.Blob db _) bs offset =
+    Direct.blobWrite blob bs offset
+        >>= checkError (DetailDatabase db) "blobWrite"
diff --git a/Database/SQLite3/Bindings.hs b/Database/SQLite3/Bindings.hs
@@ -105,6 +105,14 @@ module Database.SQLite3.Bindings (
     c_sqlite3_wal_hook,
     CWalHook,
     mkCWalHook,
+
+    -- * Incremental blob I/O
+    c_sqlite3_blob_open,
+    c_sqlite3_blob_close,
+    c_sqlite3_blob_reopen,
+    c_sqlite3_blob_bytes,
+    c_sqlite3_blob_read,
+    c_sqlite3_blob_write,
 ) where
 
 import Database.SQLite3.Bindings.Types
@@ -454,3 +462,36 @@ type CWalHook = Ptr () -> Ptr CDatabase -> CString -> CInt -> IO CError
 
 foreign import ccall "wrapper"
     mkCWalHook :: CWalHook -> IO (FunPtr CWalHook)
+
+
+-- | <https://www.sqlite.org/c3ref/blob_open.html>
+foreign import ccall "sqlite3_blob_open"
+    c_sqlite3_blob_open
+        :: Ptr CDatabase
+        -> CString         -- ^ Database name
+        -> CString         -- ^ Table name
+        -> CString         -- ^ Column name
+        -> Int64           -- ^ Row ROWID
+        -> CInt            -- ^ Flags
+        -> Ptr (Ptr CBlob) -- ^ OUT: Blob handle, will be NULL on error
+        -> IO CError
+
+-- | <https://www.sqlite.org/c3ref/blob_close.html>
+foreign import ccall "sqlite3_blob_close"
+    c_sqlite3_blob_close :: Ptr CBlob -> IO CError
+
+-- | <https://www.sqlite.org/c3ref/blob_reopen.html>
+foreign import ccall "sqlite3_blob_reopen"
+    c_sqlite3_blob_reopen :: Ptr CBlob -> Int64 -> IO CError
+
+-- | <https://www.sqlite.org/c3ref/blob_bytes.html>
+foreign import ccall unsafe "sqlite3_blob_bytes"
+    c_sqlite3_blob_bytes :: Ptr CBlob -> IO CInt
+
+-- | <https://www.sqlite.org/c3ref/blob_read.html>
+foreign import ccall "sqlite3_blob_read"
+    c_sqlite3_blob_read :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError
+
+-- | <https://www.sqlite.org/c3ref/blob_write.html>
+foreign import ccall "sqlite3_blob_write"
+    c_sqlite3_blob_write :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError
diff --git a/Database/SQLite3/Bindings/Types.hsc b/Database/SQLite3/Bindings/Types.hsc
@@ -9,6 +9,7 @@ module Database.SQLite3.Bindings.Types (
     CStatement,
     CValue,
     CContext,
+    CBlob,
 
     -- * Enumerations
 
@@ -119,6 +120,11 @@ data CValue
 -- @CContext@ = @sqlite3_context@
 data CContext
 
+-- | <https://www.sqlite.org/c3ref/blob.html>
+--
+-- @CBlob@ = @sqlite3_blob@
+data CBlob
+
 -- | Index of a parameter in a parameterized query.
 -- Parameter indices start from 1.
 --

diff --git a/Database/SQLite3/Direct.hs b/Database/SQLite3/Direct.hs
@@ -91,12 +91,22 @@ module Database.SQLite3.Direct (
     -- * Interrupting a long-running query
     interrupt,
 
+    -- * Incremental blob I/O
+    blobOpen,
+    blobClose,
+    blobReopen,
+    blobBytes,
+    blobRead,
+    blobReadBuf,
+    blobWrite,
+
     -- * Types
     Database(..),
     Statement(..),
     ColumnType(..),
     FuncContext(..),
     FuncArgs(..),
+    Blob(..),
 
     -- ** Results and errors
     StepResult(..),
@@ -209,6 +219,11 @@ newtype FuncContext = FuncContext (Ptr CContext)
 -- | The arguments of a custom SQL function.
 data FuncArgs = FuncArgs CArgCount (Ptr (Ptr CValue))
 
+-- | The type of blob handles used for incremental blob I/O
+data Blob = Blob Database (Ptr CBlob) -- we include the db handle to use in
+    deriving (Eq, Show)               -- error messages since it cannot
+                                      -- be retrieved any other way
+
 ------------------------------------------------------------------------
 
 -- | <http://www.sqlite.org/c3ref/open.html>
@@ -800,3 +815,77 @@ deleteCollation (Database db) (Utf8 name) =
 setLoadExtensionEnabled :: Database -> Bool -> IO (Either Error ())
 setLoadExtensionEnabled (Database db) enabled = do
     toResult () <$> c_sqlite3_enable_load_extension db enabled
+
+
+-- | <https://www.sqlite.org/c3ref/blob_open.html>
+--
+-- Open a blob for incremental I/O.
+blobOpen
+    :: Database
+    -> Utf8   -- ^ The symbolic name of the database (e.g. "main").
+    -> Utf8   -- ^ The table name.
+    -> Utf8   -- ^ The column name.
+    -> Int64  -- ^ The @ROWID@ of the row.
+    -> Bool   -- ^ Open the blob for read-write.
+    -> IO (Either Error Blob)
+blobOpen (Database db) (Utf8 zDb) (Utf8 zTable) (Utf8 zColumn) rowid rw =
+    BS.useAsCString zDb $ \ptrDb ->
+    BS.useAsCString zTable $ \ptrTable ->
+    BS.useAsCString zColumn $ \ptrColumn ->
+    alloca $ \ptrBlob -> do
+        c_sqlite3_blob_open db ptrDb ptrTable ptrColumn rowid flags ptrBlob
+            >>= toResultM (Blob (Database db) <$> peek ptrBlob)
+  where
+    flags = if rw then 1 else 0
+
+-- | <https://www.sqlite.org/c3ref/blob_close.html>
+blobClose :: Blob -> IO (Either Error ())
+blobClose (Blob _ blob) =
+    toResult () <$> c_sqlite3_blob_close blob
+
+-- | <https://www.sqlite.org/c3ref/blob_reopen.html>
+blobReopen :: Blob -> Int64 -> IO (Either Error ())
+blobReopen (Blob _ blob) rowid =
+    toResult () <$> c_sqlite3_blob_reopen blob rowid
+
+-- | <https://www.sqlite.org/c3ref/blob_bytes.html>
+blobBytes :: Blob -> IO Int
+blobBytes (Blob _ blob) =
+    fromIntegral <$> c_sqlite3_blob_bytes blob
+
+-- | <https://www.sqlite.org/c3ref/blob_read.html>
+blobRead
+    :: Blob
+    -> Int -- ^ Number of bytes to read.
+    -> Int -- ^ Offset within the blob.
+    -> IO (Either Error ByteString)
+blobRead blob len offset =
+    -- we do not use allocaBytes here because it deallocates its buffer
+    -- which would necessitate copying it
+    -- instead we use mallocBytes and mask to ensure both exception
+    -- safety and that the buffer is not copied any times
+    mask $ \restore -> do
+        buf <- mallocBytes len
+        r <- restore (blobReadBuf blob buf len offset)
+            `onException` (free buf)
+        case r of
+            Left err -> free buf >> return (Left err)
+            Right () -> do
+                bs <- BSU.unsafePackCStringFinalizer buf len (free buf)
+                return (Right bs)
+
+blobReadBuf :: Blob -> Ptr a -> Int -> Int -> IO (Either Error ())
+blobReadBuf (Blob _ blob) buf len offset =
+    toResult () <$>
+        c_sqlite3_blob_read blob buf (fromIntegral len) (fromIntegral offset)
+
+-- | <https://www.sqlite.org/c3ref/blob_write.html>
+blobWrite
+    :: Blob
+    -> ByteString
+    -> Int -- ^ Offset within the blob.
+    -> IO (Either Error ())
+blobWrite (Blob _ blob) bs offset =
+    BSU.unsafeUseAsCStringLen bs $ \(buf, len) ->
+        toResult () <$>
+            c_sqlite3_blob_write blob buf (fromIntegral len) (fromIntegral offset)
diff --git a/test/Main.hs b/test/Main.hs
@@ -60,6 +60,7 @@ regressionTests =
     , TestLabel "CustomFuncErr" . testCustomFunctionError
     , TestLabel "CustomAggr"    . testCustomAggragate
     , TestLabel "CustomColl"    . testCustomCollation
+    , TestLabel "IncrBlobIO"    . testIncrementalBlobIO
     ] ++
     (if rtsSupportsBoundThreads then
     [ TestLabel "Interrupt"     . testInterrupt
@@ -809,6 +810,23 @@ testCustomCollation TestEnv{..} = TestCase $ do
     -- order by length first, then by lexicographical order
     cmpLen s1 s2 = compare (T.length s1) (T.length s2) <> compare s1 s2
 
+testIncrementalBlobIO :: TestEnv -> Test
+testIncrementalBlobIO TestEnv{..} = TestCase $ do
+  withConn $ \conn -> do
+    exec conn "CREATE TABLE tbl (n BLOB)"
+    exec conn "INSERT INTO tbl(rowid,n) VALUES (1,'abcdefg')"
+    blob <- blobOpen conn "main" "tbl" "n" 1 True
+    l <- blobBytes blob
+    assertEqual "blobBytes" 7 l
+    s <- blobRead blob 4 2
+    assertEqual "blobRead" "cdef" s
+    blobWrite blob "BC" 1
+    blobClose blob
+    withStmt conn "SELECT n FROM tbl" $ \stmt -> do
+      Row <- step stmt
+      s' <- columnBlob stmt 0
+      assertEqual "blobWrite" "aBCdefg" s'
+
 testInterrupt :: TestEnv -> Test
 testInterrupt TestEnv{..} = TestCase $
   withConn $ \conn -> do