diff --git a/Database/SQLite3.hs b/Database/SQLite3.hs --- a/Database/SQLite3.hs +++ b/Database/SQLite3.hs @@ -38,6 +38,7 @@ bindDouble, bindText, bindBlob, + bindZeroBlob, bindNull, -- * Reading the result row @@ -75,7 +76,9 @@ funcResultDouble, funcResultText, funcResultBlob, + funcResultZeroBlob, funcResultNull, + getFuncContextDatabase, -- * Create custom collations createCollation, @@ -85,6 +88,24 @@ interrupt, interruptibly, + -- * Incremental blob I/O + blobOpen, + blobClose, + blobReopen, + blobBytes, + blobRead, + blobReadBuf, + blobWrite, + + -- * Online Backup API + -- | and + -- + backupInit, + backupFinish, + backupStep, + backupRemaining, + backupPagecount, + -- * Types Database, Statement, @@ -93,9 +114,12 @@ ColumnType(..), FuncContext, FuncArgs, + Blob, + Backup, -- ** Results and errors StepResult(..), + BackupStepResult(..), Error(..), -- ** Special integers @@ -111,6 +135,7 @@ , Statement , ColumnType(..) , StepResult(..) + , BackupStepResult(..) , Error(..) , ParamIndex(..) , ColumnIndex(..) @@ -120,6 +145,8 @@ , FuncArgs , ArgCount(..) , ArgIndex + , Blob + , Backup -- Re-exported from Database.SQLite3.Direct without modification. -- Note that if this module were in another package, source links would not @@ -139,10 +166,15 @@ , funcResultInt64 , funcResultDouble , funcResultBlob + , funcResultZeroBlob , funcResultNull + , getFuncContextDatabase , lastInsertRowId , changes , interrupt + , blobBytes + , backupRemaining + , backupPagecount ) import qualified Database.SQLite3.Direct as Direct @@ -161,6 +193,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (UnicodeException(..), lenientDecode) import Data.Typeable +import Foreign.Ptr (Ptr) data SQLData = SQLInteger !Int64 @@ -464,6 +497,11 @@ Direct.bindBlob statement parameterIndex byteString >>= checkError (DetailStatement statement) "bind blob" +bindZeroBlob :: Statement -> ParamIndex -> Int -> IO () +bindZeroBlob statement parameterIndex len = + Direct.bindZeroBlob statement parameterIndex len + >>= checkError (DetailStatement statement) "bind zeroblob" + bindDouble :: Statement -> ParamIndex -> Double -> IO () bindDouble statement parameterIndex datum = Direct.bindDouble statement parameterIndex datum @@ -669,3 +707,79 @@ deleteCollation db name = Direct.deleteCollation db (toUtf8 name) >>= checkError (DetailDatabase db) ("deleteCollation " `appendShow` name) + + +-- | +-- +-- 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" + +-- | +blobClose :: Blob -> IO () +blobClose blob@(Direct.Blob db _) = + Direct.blobClose blob + >>= checkError (DetailDatabase db) "blobClose" + +-- | +blobReopen :: Blob -> Int64 -> IO () +blobReopen blob@(Direct.Blob db _) rowid = + Direct.blobReopen blob rowid + >>= checkError (DetailDatabase db) "blobReopen" + +-- | +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" + +-- | +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" + + +backupInit + :: Database -- ^ Destination database handle + -> Text -- ^ Destination database name + -> Database -- ^ Source database handle + -> Text -- ^ Source database name + -> IO Backup +backupInit dstDb dstName srcDb srcName = + Direct.backupInit dstDb (toUtf8 dstName) srcDb (toUtf8 srcName) + >>= checkError (DetailDatabase dstDb) "backupInit" + +backupFinish :: Backup -> IO (()) +backupFinish backup@(Direct.Backup dstDb _) = + Direct.backupFinish backup + >>= checkError (DetailDatabase dstDb) "backupFinish" + +backupStep :: Backup -> Int -> IO BackupStepResult +backupStep backup pages = + Direct.backupStep backup pages + -- it appears that sqlite does not generate an + -- error message when sqlite3_backup_step fails + >>= checkError (DetailMessage "failed") "backupStep" diff --git a/Database/SQLite3/Bindings.hs b/Database/SQLite3/Bindings.hs --- a/Database/SQLite3/Bindings.hs +++ b/Database/SQLite3/Bindings.hs @@ -5,12 +5,14 @@ -- * Connection management c_sqlite3_open, c_sqlite3_close, + c_sqlite3_errcode, c_sqlite3_errmsg, c_sqlite3_interrupt, c_sqlite3_trace, CTraceCallback, mkCTraceCallback, c_sqlite3_get_autocommit, + c_sqlite3_enable_shared_cache, -- * Simple query execution -- | @@ -37,6 +39,7 @@ -- * Binding Values To Prepared Statements -- | c_sqlite3_bind_blob, + c_sqlite3_bind_zeroblob, c_sqlite3_bind_text, c_sqlite3_bind_double, c_sqlite3_bind_int64, @@ -97,7 +100,29 @@ c_sqlite3_free, -- * Extensions - c_sqlite3_enable_load_extension + c_sqlite3_enable_load_extension, + + -- * Write-Ahead Log Commit Hook + 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, + + -- * Online Backup API + -- | and + -- + c_sqlite3_backup_init, + c_sqlite3_backup_finish, + c_sqlite3_backup_step, + c_sqlite3_backup_remaining, + c_sqlite3_backup_pagecount, ) where import Database.SQLite3.Bindings.Types @@ -117,6 +142,10 @@ c_sqlite3_close :: Ptr CDatabase -> IO CError -- | +foreign import ccall "sqlite3_errcode" + c_sqlite3_errcode :: Ptr CDatabase -> IO CError + +-- | foreign import ccall "sqlite3_errmsg" c_sqlite3_errmsg :: Ptr CDatabase -> IO CString @@ -137,7 +166,11 @@ foreign import ccall unsafe "sqlite3_get_autocommit" c_sqlite3_get_autocommit :: Ptr CDatabase -> IO CInt +-- | +foreign import ccall unsafe "sqlite3_enable_shared_cache" + c_sqlite3_enable_shared_cache :: CInt -> IO CError + foreign import ccall "sqlite3_exec" c_sqlite3_exec :: Ptr CDatabase @@ -264,6 +297,10 @@ -> Ptr CDestructor -> IO CError +foreign import ccall unsafe "sqlite3_bind_zeroblob" + c_sqlite3_bind_zeroblob + :: Ptr CStatement -> CParamIndex -> CInt -> IO CError + foreign import ccall unsafe "sqlite3_bind_text" c_sqlite3_bind_text :: Ptr CStatement @@ -429,3 +466,67 @@ -- | foreign import ccall "sqlite3_enable_load_extension" c_sqlite3_enable_load_extension :: Ptr CDatabase -> Bool -> IO CError + + +-- | +foreign import ccall unsafe "sqlite3_wal_hook" + c_sqlite3_wal_hook :: Ptr CDatabase -> FunPtr CWalHook -> Ptr a -> IO (Ptr ()) + +type CWalHook = Ptr () -> Ptr CDatabase -> CString -> CInt -> IO CError + +foreign import ccall "wrapper" + mkCWalHook :: CWalHook -> IO (FunPtr CWalHook) + + +-- | +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 + +-- | +foreign import ccall "sqlite3_blob_close" + c_sqlite3_blob_close :: Ptr CBlob -> IO CError + +-- | +foreign import ccall "sqlite3_blob_reopen" + c_sqlite3_blob_reopen :: Ptr CBlob -> Int64 -> IO CError + +-- | +foreign import ccall unsafe "sqlite3_blob_bytes" + c_sqlite3_blob_bytes :: Ptr CBlob -> IO CInt + +-- | +foreign import ccall "sqlite3_blob_read" + c_sqlite3_blob_read :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError + +-- | +foreign import ccall "sqlite3_blob_write" + c_sqlite3_blob_write :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError + + +foreign import ccall "sqlite3_backup_init" + c_sqlite3_backup_init + :: Ptr CDatabase -- ^ Destination database handle + -> CString -- ^ Destination database name + -> Ptr CDatabase -- ^ Source database handle + -> CString -- ^ Source database name + -> IO (Ptr CBackup) + +foreign import ccall "sqlite3_backup_finish" + c_sqlite3_backup_finish :: Ptr CBackup -> IO CError + +foreign import ccall "sqlite3_backup_step" + c_sqlite3_backup_step :: Ptr CBackup -> CInt -> IO CError + +foreign import ccall unsafe "sqlite3_backup_remaining" + c_sqlite3_backup_remaining :: Ptr CBackup -> IO CInt + +foreign import ccall unsafe "sqlite3_backup_pagecount" + c_sqlite3_backup_pagecount :: Ptr CBackup -> IO CInt diff --git a/Database/SQLite3/Bindings/Types.hsc b/Database/SQLite3/Bindings/Types.hsc --- a/Database/SQLite3/Bindings/Types.hsc +++ b/Database/SQLite3/Bindings/Types.hsc @@ -9,6 +9,8 @@ CStatement, CValue, CContext, + CBlob, + CBackup, -- * Enumerations @@ -118,6 +120,16 @@ -- -- @CContext@ = @sqlite3_context@ data CContext + +-- | +-- +-- @CBlob@ = @sqlite3_blob@ +data CBlob + +-- | +-- +-- @CBackup@ = @sqlite3_backup@ +data CBackup -- | 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 --- a/Database/SQLite3/Direct.hs +++ b/Database/SQLite3/Direct.hs @@ -12,9 +12,11 @@ -- * Connection management open, close, + errcode, errmsg, setTrace, getAutoCommit, + setSharedCacheEnabled, -- * Simple query execution -- | @@ -44,6 +46,7 @@ bindDouble, bindText, bindBlob, + bindZeroBlob, bindNull, -- * Reading the result row @@ -78,7 +81,9 @@ funcResultDouble, funcResultText, funcResultBlob, + funcResultZeroBlob, funcResultNull, + getFuncContextDatabase, -- * Create custom collations createCollation, @@ -87,15 +92,36 @@ -- * Interrupting a long-running query interrupt, + -- * Incremental blob I/O + blobOpen, + blobClose, + blobReopen, + blobBytes, + blobRead, + blobReadBuf, + blobWrite, + + -- * Online Backup API + -- | and + -- + backupInit, + backupFinish, + backupStep, + backupRemaining, + backupPagecount, + -- * Types Database(..), Statement(..), ColumnType(..), FuncContext(..), FuncArgs(..), + Blob(..), + Backup(..), -- ** Results and errors StepResult(..), + BackupStepResult(..), Error(..), -- ** Special types @@ -136,6 +162,11 @@ | Done deriving (Eq, Show) +data BackupStepResult + = BackupOK -- ^ There are still more pages to be copied. + | BackupDone -- ^ All pages were successfully copied. + deriving (Eq, Show) + -- | A 'ByteString' containing UTF8-encoded text with no NUL characters. newtype Utf8 = Utf8 ByteString deriving (Eq, Ord) @@ -198,6 +229,13 @@ ErrorDone -> Right Done err -> Left err +toBackupStepResult :: CError -> Result BackupStepResult +toBackupStepResult code = + case decodeError code of + ErrorOK -> Right BackupOK + ErrorDone -> Right BackupDone + err -> Left err + -- | The context in which a custom SQL function is executed. newtype FuncContext = FuncContext (Ptr CContext) deriving (Eq, Show) @@ -205,6 +243,17 @@ -- | 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 + +-- | A handle for an online backup process. +data Backup = Backup Database (Ptr CBackup) + deriving (Eq, Show) +-- we include the destination db handle to use in error messages since +-- it cannot be retrieved any other way + ------------------------------------------------------------------------ -- | @@ -245,6 +294,11 @@ c_sqlite3_interrupt db -- | +errcode :: Database -> IO Error +errcode (Database db) = + decodeError <$> c_sqlite3_errcode db + +-- | errmsg :: Database -> IO Utf8 errmsg (Database db) = c_sqlite3_errmsg db >>= packUtf8 (Utf8 BS.empty) id @@ -368,6 +422,16 @@ getAutoCommit (Database db) = (/= 0) <$> c_sqlite3_get_autocommit db + +-- | +-- +-- Enable or disable shared cache for all future connections. +setSharedCacheEnabled :: Bool -> IO (Either Error ()) +setSharedCacheEnabled val = + toResult () <$> c_sqlite3_enable_shared_cache + (if val then 1 else 0) + + -- | -- -- If the query contains no SQL statements, this returns @@ -483,6 +547,11 @@ toResult () <$> c_sqlite3_bind_blob stmt (toFFI idx) ptr len c_SQLITE_TRANSIENT +bindZeroBlob :: Statement -> ParamIndex -> Int -> IO (Either Error ()) +bindZeroBlob (Statement stmt) idx len = + toResult () <$> + c_sqlite3_bind_zeroblob stmt (toFFI idx) (fromIntegral len) + bindNull :: Statement -> ParamIndex -> IO (Either Error ()) bindNull (Statement stmt) idx = toResult () <$> c_sqlite3_bind_null stmt (toFFI idx) @@ -639,7 +708,7 @@ -- call c_sqlite3_result_error in the event of an error catchAsResultError :: Ptr CContext -> IO () -> IO () -catchAsResultError ctx action = catch action $ \exn -> do +catchAsResultError ctx action = E.catch action $ \exn -> do let msg = show (exn :: SomeException) withCAStringLen msg $ \(ptr, len) -> c_sqlite3_result_error ctx ptr (fromIntegral len) @@ -712,11 +781,23 @@ unsafeUseAsCStringLenNoNull value $ \ptr len -> c_sqlite3_result_blob ctx ptr len c_SQLITE_TRANSIENT +funcResultZeroBlob :: FuncContext -> Int -> IO () +funcResultZeroBlob (FuncContext ctx) len = + c_sqlite3_result_zeroblob ctx (fromIntegral len) + funcResultNull :: FuncContext -> IO () funcResultNull (FuncContext ctx) = c_sqlite3_result_null ctx +-- | +getFuncContextDatabase :: FuncContext -> IO Database +getFuncContextDatabase (FuncContext ctx) = do + db <- c_sqlite3_context_db_handle ctx + if db == nullPtr + then fail $ "sqlite3_context_db_handle(" ++ show ctx ++ ") returned NULL" + else return (Database db) + -- Deallocate the function pointer to the comparison function used to -- implement a custom collation destroyCCompare :: CFuncDestroy () @@ -769,3 +850,110 @@ setLoadExtensionEnabled :: Database -> Bool -> IO (Either Error ()) setLoadExtensionEnabled (Database db) enabled = do toResult () <$> c_sqlite3_enable_load_extension db enabled + + +-- | +-- +-- 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 + +-- | +blobClose :: Blob -> IO (Either Error ()) +blobClose (Blob _ blob) = + toResult () <$> c_sqlite3_blob_close blob + +-- | +blobReopen :: Blob -> Int64 -> IO (Either Error ()) +blobReopen (Blob _ blob) rowid = + toResult () <$> c_sqlite3_blob_reopen blob rowid + +-- | +blobBytes :: Blob -> IO Int +blobBytes (Blob _ blob) = + fromIntegral <$> c_sqlite3_blob_bytes blob + +-- | +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) + +-- | +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) + + +backupInit + :: Database -- ^ Destination database handle + -> Utf8 -- ^ Destination database name + -> Database -- ^ Source database handle + -> Utf8 -- ^ Source database name + -> IO (Either Error Backup) +backupInit (Database dstDb) (Utf8 dstName) (Database srcDb) (Utf8 srcName) = + BS.useAsCString dstName $ \dstName' -> + BS.useAsCString srcName $ \srcName' -> do + r <- c_sqlite3_backup_init dstDb dstName' srcDb srcName' + if r == nullPtr + then Left <$> errcode (Database dstDb) + else return (Right (Backup (Database dstDb) r)) + +backupFinish :: Backup -> IO (Either Error ()) +backupFinish (Backup _ backup) = + toResult () <$> + c_sqlite3_backup_finish backup + +backupStep :: Backup -> Int -> IO (Either Error BackupStepResult) +backupStep (Backup _ backup) pages = + toBackupStepResult <$> + c_sqlite3_backup_step backup (fromIntegral pages) + +backupRemaining :: Backup -> IO Int +backupRemaining (Backup _ backup) = + fromIntegral <$> c_sqlite3_backup_remaining backup + +backupPagecount :: Backup -> IO Int +backupPagecount (Backup _ backup) = + fromIntegral <$> c_sqlite3_backup_pagecount backup diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,23 @@ +v2.3.15 + * Add support for the online backup API + + * Add support for incremental blob I/O + + * Add support for zeroblobs + + * Add support for enabling/disabling the shared cache mode + + * Add low-level bindings to sqlite3_wal_hook + + * Add function for retrieving the db handle from a custom function + context. + + * Add bindings for sqlite3_errcode + + * Improve Travis CI coverage to cover more GHC versions (GHC 7.4 and higher) + + * Big thanks to Mario Titas and Marcin Tolysz for the above! + v2.3.14 * Add custom functions, aggregates and collations. diff --git a/direct-sqlite.cabal b/direct-sqlite.cabal --- a/direct-sqlite.cabal +++ b/direct-sqlite.cabal @@ -1,5 +1,5 @@ name: direct-sqlite -version: 2.3.14 +version: 2.3.15 build-type: Simple license: BSD3 license-file: LICENSE diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -60,6 +60,7 @@ , TestLabel "CustomFuncErr" . testCustomFunctionError , TestLabel "CustomAggr" . testCustomAggragate , TestLabel "CustomColl" . testCustomCollation + , TestLabel "IncrBlobIO" . testIncrementalBlobIO ] ++ (if rtsSupportsBoundThreads then [ TestLabel "Interrupt" . testInterrupt @@ -248,6 +249,7 @@ testBind TestEnv{..} = TestCase $ do bracket (prepare conn "SELECT ?") finalize testBind1 bracket (prepare conn "SELECT ?+?") finalize testBind2 + bracket (prepare conn "SELECT ?,?") finalize testBind3 where testBind1 stmt = do let params = [SQLInteger 3] @@ -265,6 +267,16 @@ Done <- step stmt assertEqual "two params param" [SQLInteger 2] res + testBind3 stmt = do + let len = 7 + bs = B.replicate len 0 + bindBlob stmt 1 bs + bindZeroBlob stmt 2 len + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "blob vs. zeroblob" [SQLBlob bs, SQLBlob bs] res + -- Test bindParameterCount testBindParamCounts :: TestEnv -> Test testBindParamCounts TestEnv{..} = TestCase $ do @@ -797,6 +809,23 @@ where -- 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 $