diff --git a/Database/SQLite3/Bindings.hs b/Database/SQLite3/Bindings.hs --- a/Database/SQLite3/Bindings.hs +++ b/Database/SQLite3/Bindings.hs @@ -7,6 +7,9 @@ c_sqlite3_close, c_sqlite3_errmsg, c_sqlite3_interrupt, + c_sqlite3_trace, + CTraceCallback, + mkCTraceCallback, -- * Simple query execution -- | @@ -21,6 +24,7 @@ c_sqlite3_reset, c_sqlite3_finalize, c_sqlite3_clear_bindings, + c_sqlite3_sql, -- * Parameter and column information c_sqlite3_bind_parameter_count, @@ -77,7 +81,16 @@ foreign import ccall "sqlite3_interrupt" c_sqlite3_interrupt :: Ptr CDatabase -> IO () +-- | +foreign import ccall "sqlite3_trace" + c_sqlite3_trace + :: Ptr CDatabase + -> FunPtr (CTraceCallback a) -- ^ Optional callback function called for each row + -> Ptr a -- ^ Context passed to the callback + -> IO (Ptr ()) -- ^ Returns context pointer from previously + -- registered trace + foreign import ccall "sqlite3_exec" c_sqlite3_exec :: Ptr CDatabase @@ -99,6 +112,12 @@ -- 'c_sqlite3_exec' returns @SQLITE_ABORT@ -- ('ErrorAbort'). +type CTraceCallback a + = Ptr a + -> CString -- ^ UTF-8 rendering of the SQL statement text as + -- the statement first begins executing + -> IO () + -- | A couple important things to know about callbacks from Haskell code: -- -- * If the callback throws an exception, apparently, the /whole program/ is @@ -109,7 +128,10 @@ foreign import ccall "wrapper" mkCExecCallback :: CExecCallback a -> IO (FunPtr (CExecCallback a)) +foreign import ccall "wrapper" + mkCTraceCallback :: CTraceCallback a -> IO (FunPtr (CTraceCallback a)) + -- | -- -- If the query contains no SQL statements, this returns @SQLITE_OK@ and sets @@ -153,6 +175,10 @@ -- A look at the source reveals that this function always returns @SQLITE_OK@. foreign import ccall unsafe "sqlite3_clear_bindings" c_sqlite3_clear_bindings :: Ptr CStatement -> IO CError + +-- | +foreign import ccall unsafe "sqlite3_sql" + c_sqlite3_sql :: Ptr CStatement -> IO CString -- | -- diff --git a/Database/SQLite3/Direct.hs b/Database/SQLite3/Direct.hs --- a/Database/SQLite3/Direct.hs +++ b/Database/SQLite3/Direct.hs @@ -12,6 +12,7 @@ open, close, errmsg, + setTrace, -- * Simple query execution -- | @@ -26,6 +27,7 @@ reset, finalize, clearBindings, + statementSql, -- * Parameter and column information bindParameterCount, @@ -284,6 +286,29 @@ -> [Maybe Utf8] -- ^ List of column values, as returned by 'columnText'. -> IO () +-- | +-- +-- 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 will crash. Enable only for debugging! +setTrace :: Database -> Maybe (Utf8 -> IO ()) -> IO () +setTrace (Database db) logger = + case logger of + Nothing -> do + _ <- c_sqlite3_trace db nullFunPtr nullPtr + return () + Just output -> do + -- NB: this FunPtr never gets freed. Shouldn't be a big deal, + -- though, since 'setTrace' is mainly for debugging, and is + -- typically only called once per application invocation. + cb <- mkCTraceCallback $ \_ctx cStr -> do + msg <- packUtf8 (Utf8 BS.empty) id cStr + output msg + _ <- c_sqlite3_trace db cb nullPtr + return () + -- | -- -- If the query contains no SQL statements, this returns @@ -328,6 +353,13 @@ finalize :: Statement -> IO (Either Error ()) finalize (Statement stmt) = toResult () <$> c_sqlite3_finalize stmt + +-- | +-- +-- Return a copy of the original SQL text used to compile the statement. +statementSql :: Statement -> IO (Maybe Utf8) +statementSql (Statement stmt) = + c_sqlite3_sql stmt >>= packUtf8 Nothing Just -- | -- 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.2 +version: 2.3.3 build-type: Simple license: BSD3 license-file: LICENSE @@ -20,6 +20,8 @@ supports strings encoded as UTF8, and BLOBs represented as ByteStrings. . Release history: + . + [Version 2.3.3] Add trace support, as a feature for debugging. . [Version 2.3.2] Add execPrint, execWithCallback, and interruptibly functions. Add bindings for sqlite3_last_insert_rowid and sqlite3_changes. Change the diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -19,6 +19,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T data TestEnv = @@ -48,6 +49,8 @@ , TestLabel "Integrity" . testIntegrity , TestLabel "DecodeError" . testDecodeError , TestLabel "ResultStats" . testResultStats + , TestLabel "Debug" . testStatementSql + , TestLabel "Debug" . testTracing ] ++ (if rtsSupportsBoundThreads then [ TestLabel "Interrupt" . testInterrupt @@ -149,6 +152,43 @@ return () + +testTracing :: TestEnv -> Test +testTracing TestEnv{..} = TestCase $ + withConn $ \conn -> do + chan <- newChan + let logger m = writeChan chan m + Direct.setTrace conn (Just logger) + withStmt conn "SELECT null" $ \stmt -> do + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "tracing" [SQLNull] res + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT null" msg + withStmt conn "SELECT 1+?" $ \stmt -> do + bind stmt [SQLInteger 2] + Row <- step stmt + Done <- step stmt + reset stmt + bind stmt [SQLInteger 3] + Row <- step stmt + Done <- step stmt + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT 1+2" msg + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT 1+3" msg + -- Check that disabling works too + Direct.setTrace conn Nothing + reset stmt + bind stmt [SQLInteger 3] + Row <- step stmt + Done <- step stmt + writeChan chan (Direct.Utf8 "empty") + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "empty" msg + + -- Simplest SELECT testSimplest :: TestEnv -> Test testSimplest TestEnv{..} = TestCase $ do @@ -531,6 +571,13 @@ liftM3 (,,) (lastInsertRowId conn) (changes conn) (Direct.totalChanges conn) + +testStatementSql :: TestEnv -> Test +testStatementSql TestEnv{..} = TestCase $ do + let q1 = "SELECT 1+1" + withStmt conn q1 $ \stmt -> do + Just (Direct.Utf8 sql1) <- Direct.statementSql stmt + T.encodeUtf8 q1 @=? sql1 testInterrupt :: TestEnv -> Test testInterrupt TestEnv{..} = TestCase $