use static function with SQLite to avoid dynamic wrapper

Author: epoberezkin

simplexmq.cabal

@@ -218,6 +218,7 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251009_queue_to_subscribe
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251020_service_certs
+          Simplex.Messaging.Agent.Store.SQLite.Util
   if flag(client_postgres) || flag(server_postgres)
       exposed-modules:
           Simplex.Messaging.Agent.Store.Postgres

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -42,6 +42,9 @@ module Simplex.Messaging.Agent.Store.SQLite
   )
 where
 
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception (bracketOnError, onException, throwIO)
 import Control.Monad
 import Data.Bits (xor)
 import Data.ByteArray (ScrubbedBytes)
@@ -55,21 +58,21 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Database.SQLite.Simple (Query (..))
 import qualified Database.SQLite.Simple as SQL
-import Database.SQLite.Simple.Function
 import Database.SQLite.Simple.QQ (sql)
 import qualified Database.SQLite3 as SQLite3
+import Database.SQLite3.Bindings
+import Foreign.C.Types
+import Foreign.Ptr
 import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema)
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.SQLite.Common
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.SQLite.Util (SQLiteFunc, createStaticFunction, mkSQLiteFunc)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.FilePath (takeDirectory, takeFileName, (</>))
-import UnliftIO.Exception (bracketOnError, onException, throwIO)
-import UnliftIO.MVar
-import UnliftIO.STM
 
 -- * SQLite Store implementation
 
@@ -114,19 +117,29 @@ connectDB path key track = do
   pure db
   where
     prepare db = do
-      let exec = SQLite3.exec $ SQL.connectionHandle $ DB.conn db
-      unless (BA.null key) . exec $ "PRAGMA key = " <> keyString key <> ";"
-      exec . fromQuery $
+      let db' = SQL.connectionHandle $ DB.conn db
+      unless (BA.null key) . SQLite3.exec db' $ "PRAGMA key = " <> keyString key <> ";"
+      SQLite3.exec db' . fromQuery $
         [sql|
           PRAGMA busy_timeout = 100;
           PRAGMA foreign_keys = ON;
           -- PRAGMA trusted_schema = OFF;
           PRAGMA secure_delete = ON;
           PRAGMA auto_vacuum = FULL;
         |]
-      createFunction (DB.conn db) "simplex_xor_md5_combine" xorMd5Combine
+      createStaticFunction db' "simplex_xor_md5_combine" 2 True sqliteXorMd5CombinePtr
         >>= either (throwIO . userError . show) pure
 
+foreign export ccall "simplex_xor_md5_combine" sqliteXorMd5Combine :: SQLiteFunc
+
+foreign import ccall "&simplex_xor_md5_combine" sqliteXorMd5CombinePtr :: FunPtr SQLiteFunc
+
+sqliteXorMd5Combine :: SQLiteFunc
+sqliteXorMd5Combine = mkSQLiteFunc $ \cxt args -> do
+  idsHash <- SQLite3.funcArgBlob args 0
+  rId <- SQLite3.funcArgBlob args 1
+  SQLite3.funcResultBlob cxt $ xorMd5Combine idsHash rId
+
 xorMd5Combine :: ByteString -> ByteString -> ByteString
 xorMd5Combine idsHash rId = B.packZipWith xor idsHash $ C.md5Hash rId
 

src/Simplex/Messaging/Agent/Store/SQLite/Util.hs

@@ -0,0 +1,41 @@
+module Simplex.Messaging.Agent.Store.SQLite.Util where
+
+import Control.Exception (SomeException, catch, mask_)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Database.SQLite3.Direct (Database (..), FuncArgs (..), FuncContext (..))
+import Database.SQLite3.Bindings
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.StablePtr
+
+data CFuncPtrs = CFuncPtrs (FunPtr CFunc) (FunPtr CFunc) (FunPtr CFuncFinal)
+
+type SQLiteFunc = Ptr CContext -> CArgCount -> Ptr (Ptr CValue) -> IO ()
+
+mkSQLiteFunc :: (FuncContext -> FuncArgs -> IO ()) -> SQLiteFunc
+mkSQLiteFunc f cxt nArgs cvals = catchAsResultError cxt $ f (FuncContext cxt) (FuncArgs nArgs cvals)
+{-# INLINE mkSQLiteFunc #-}
+
+-- Based on createFunction from Database.SQLite3.Direct, but uses static function pointer to avoid dynamic wrapper that triggers DCL.
+createStaticFunction :: Database -> ByteString -> CArgCount -> Bool -> FunPtr SQLiteFunc -> IO (Either Error ())
+createStaticFunction (Database db) name nArgs isDet funPtr = mask_ $ do
+  u <- newStablePtr $ CFuncPtrs funPtr nullFunPtr nullFunPtr
+  let flags = if isDet then c_SQLITE_DETERMINISTIC else 0
+  B.useAsCString name $ \namePtr ->
+    toResult () <$> c_sqlite3_create_function_v2 db namePtr nArgs flags (castStablePtrToPtr u) funPtr nullFunPtr nullFunPtr nullFunPtr
+
+-- Convert a 'CError' to a 'Either Error', in the common case where
+-- SQLITE_OK signals success and anything else signals an error.
+--
+-- Note that SQLITE_OK == 0.
+toResult :: a -> CError -> Either Error a
+toResult a (CError 0) = Right a
+toResult _ code = Left $ decodeError code
+
+-- call c_sqlite3_result_error in the event of an error
+catchAsResultError :: Ptr CContext -> IO () -> IO ()
+catchAsResultError ctx action = catch action $ \exn -> do
+  let msg = show (exn :: SomeException)
+  withCAStringLen msg $ \(ptr, len) ->
+    c_sqlite3_result_error ctx ptr (fromIntegral len)