core: C API to migrate and check database (#1008)

* core: C API to migrate and check database

* update simplexmq

cabal.project

@@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: 26d149d17c0ceb5cc17d0fd1c1357d95bd47e549
+    tag: e4b47825b56122222e5bf4716285b419acdac83d
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."26d149d17c0ceb5cc17d0fd1c1357d95bd47e549" = "135knaxsyag3mlml62w2j4y8shvi82q8frhcn5b28qd8hlg5q2rq";
+  "https://github.com/simplex-chat/simplexmq.git"."e4b47825b56122222e5bf4716285b419acdac83d" = "1dvr1s4kicf8z3x0bl7v6q1hphdngwcmcbmmqmj99b8728zh8fk4";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."5e154a2aeccc33ead6c243ec07195ab673137221" = "1d1gc5wax4vqg0801ajsmx1sbwvd9y7p7b8mmskvqsmpbwgbh0m0";
   "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp";

src/Simplex/Chat.hs

@@ -133,7 +133,7 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize, de
   firstTime <- not <$> doesFileExist f
   currentUser <- newTVarIO user
   servers <- resolveServers defaultServers
-  smpAgent <- getSMPAgentClient aCfg {dbFile = dbFilePrefix <> "_agent.db", dbKey} servers {netCfg = networkConfig}
+  smpAgent <- getSMPAgentClient aCfg {dbFile = agentStoreFile dbFilePrefix, dbKey} servers {netCfg = networkConfig}
   agentAsync <- newTVarIO Nothing
   idsDrg <- newTVarIO =<< drgNew
   inputQ <- newTBQueueIO tbqSize

src/Simplex/Chat/Core.hs

@@ -23,7 +23,7 @@ simplexChatCore cfg@ChatConfig {yesToMigrations} opts sendToast chat
   where
     initRun = do
       let f = chatStoreFile $ dbFilePrefix opts
-      st <- createStore f (dbKey opts) yesToMigrations
+      st <- createChatStore f (dbKey opts) yesToMigrations
       u <- getCreateActiveUser st
       cc <- newChatController st (Just u) cfg opts sendToast
       runSimplexChat opts u cc chat

src/Simplex/Chat/Mobile.hs

@@ -1,18 +1,23 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Chat.Mobile where
 
 import Control.Concurrent.STM
+import Control.Exception (catch)
 import Control.Monad.Reader
 import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Functor (($>))
 import Data.List (find)
 import Data.Maybe (fromMaybe)
+import Database.SQLite.Simple (SQLError (..))
+import qualified Database.SQLite.Simple as DB
 import Foreign.C.String
 import Foreign.C.Types (CInt (..))
 import Foreign.StablePtr
@@ -24,11 +29,17 @@ import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Types
 import Simplex.Chat.Util (safeDecodeUtf8)
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (yesToMigrations))
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (yesToMigrations), createAgentStore)
+import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore)
 import Simplex.Messaging.Client (defaultNetworkConfig)
+import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (CorrId (..))
+import Simplex.Messaging.Util (catchAll)
 import System.Timeout (timeout)
 
+foreign export ccall "chat_migrate_db" cChatMigrateDB :: CString -> CString -> IO CJSONString
+
+-- chat_init is deprecated
 foreign export ccall "chat_init" cChatInit :: CString -> IO (StablePtr ChatController)
 
 foreign export ccall "chat_init_key" cChatInitKey :: CString -> CString -> IO (StablePtr ChatController)
@@ -41,7 +52,13 @@ foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatCont
 
 foreign export ccall "chat_parse_markdown" cChatParseMarkdown :: CString -> IO CJSONString
 
--- | initialize chat controller
+-- | check and migrate the database
+-- This function validates that the encryption is correct and runs migrations - it should be called before cChatInitKey
+cChatMigrateDB :: CString -> CString -> IO CJSONString
+cChatMigrateDB fp key =
+  ((,) <$> peekCAString fp <*> peekCAString key) >>= uncurry chatMigrateDB >>= newCAString . LB.unpack . J.encode
+
+-- | initialize chat controller (deprecated)
 -- The active user has to be created and the chat has to be started before most commands can be used.
 cChatInit :: CString -> IO (StablePtr ChatController)
 cChatInit fp = peekCAString fp >>= chatInit >>= newStablePtr
@@ -99,13 +116,39 @@ type CJSONString = CString
 getActiveUser_ :: SQLiteStore -> IO (Maybe User)
 getActiveUser_ st = find activeUser <$> withTransaction st getUsers
 
+data DBMigrationResult
+  = DBMOk
+  | DBMErrorNotADatabase {dbFile :: String}
+  | DBMError {dbFile :: String, migrationError :: String}
+  deriving (Show, Generic)
+
+instance ToJSON DBMigrationResult where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "DBM"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "DBM"
+
+chatMigrateDB :: String -> String -> IO DBMigrationResult
+chatMigrateDB dbFilePrefix dbKey =
+  migrate createChatStore (chatStoreFile dbFilePrefix) >>= \case
+    DBMOk -> migrate createAgentStore (agentStoreFile dbFilePrefix)
+    e -> pure e
+  where
+    migrate createStore dbFile =
+      ((createStore dbFile dbKey True >>= closeSQLiteStore) $> DBMOk)
+        `catch` (pure . checkDBError)
+          `catchAll` (pure . dbError)
+      where
+        checkDBError e = case sqlError e of
+          DB.ErrorNotADatabase -> DBMErrorNotADatabase dbFile
+          _ -> dbError e
+        dbError e = DBMError dbFile $ show e
+
 chatInit :: String -> IO ChatController
 chatInit = (`chatInitKey` "")
 
 chatInitKey :: String -> String -> IO ChatController
 chatInitKey dbFilePrefix dbKey = do
   let f = chatStoreFile dbFilePrefix
-  chatStore <- createStore f dbKey (yesToMigrations (defaultMobileConfig :: ChatConfig))
+  chatStore <- createChatStore f dbKey (yesToMigrations (defaultMobileConfig :: ChatConfig))
   user_ <- getActiveUser_ chatStore
   newChatController chatStore user_ defaultMobileConfig mobileChatOpts {dbFilePrefix} Nothing
 

src/Simplex/Chat/Store.hs

@@ -20,8 +20,9 @@
 module Simplex.Chat.Store
   ( SQLiteStore,
     StoreError (..),
-    createStore,
+    createChatStore,
     chatStoreFile,
+    agentStoreFile,
     createUser,
     getUsers,
     setActiveUser,
@@ -276,12 +277,15 @@ migrations = sortBy (compare `on` name) $ map migration schemaMigrations
   where
     migration (name, query) = Migration {name = name, up = fromQuery query}
 
-createStore :: FilePath -> String -> Bool -> IO SQLiteStore
-createStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey migrations
+createChatStore :: FilePath -> String -> Bool -> IO SQLiteStore
+createChatStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey migrations
 
 chatStoreFile :: FilePath -> FilePath
 chatStoreFile = (<> "_chat.db")
 
+agentStoreFile :: FilePath -> FilePath
+agentStoreFile = (<> "_agent.db")
+
 checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
 checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err)
 

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
   # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: 26d149d17c0ceb5cc17d0fd1c1357d95bd47e549
+    commit: e4b47825b56122222e5bf4716285b419acdac83d
   # - ../direct-sqlcipher
   - github: simplex-chat/direct-sqlcipher
     commit: 34309410eb2069b029b8fc1872deb1e0db123294

tests/ChatClient.hs

@@ -105,14 +105,14 @@ testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
 createTestChat :: ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
 createTestChat cfg opts@ChatOpts {dbKey} dbPrefix profile = do
   let dbFilePrefix = testDBPrefix <> dbPrefix
-  st <- createStore (dbFilePrefix <> "_chat.db") dbKey False
+  st <- createChatStore (dbFilePrefix <> "_chat.db") dbKey False
   Right user <- withTransaction st $ \db -> runExceptT $ createUser db profile True
   startTestChat_ st cfg opts dbFilePrefix user
 
 startTestChat :: ChatConfig -> ChatOpts -> String -> IO TestCC
 startTestChat cfg opts@ChatOpts {dbKey} dbPrefix = do
   let dbFilePrefix = testDBPrefix <> dbPrefix
-  st <- createStore (dbFilePrefix <> "_chat.db") dbKey False
+  st <- createChatStore (dbFilePrefix <> "_chat.db") dbKey False
   Just user <- find activeUser <$> withTransaction st getUsers
   startTestChat_ st cfg opts dbFilePrefix user
 

tests/MobileTests.hs

@@ -73,7 +73,9 @@ parsedMarkdown = "{\"formattedText\":[{\"format\":{\"type\":\"bold\"},\"text\":\
 
 testChatApiNoUser :: IO ()
 testChatApiNoUser = withTmpFiles $ do
+  DBMOk <- chatMigrateDB testDBPrefix ""
   cc <- chatInit testDBPrefix
+  DBMErrorNotADatabase _ <- chatMigrateDB testDBPrefix "myKey"
   chatSendCmd cc "/u" `shouldReturn` noActiveUser
   chatSendCmd cc "/_start" `shouldReturn` noActiveUser
   chatSendCmd cc "/u alice Alice" `shouldReturn` activeUser
@@ -81,10 +83,14 @@ testChatApiNoUser = withTmpFiles $ do
 
 testChatApi :: IO ()
 testChatApi = withTmpFiles $ do
-  let f = chatStoreFile $ testDBPrefix <> "1"
-  st <- createStore f "" True
+  let dbPrefix = testDBPrefix <> "1"
+      f = chatStoreFile dbPrefix
+  st <- createChatStore f "myKey" True
   Right _ <- withTransaction st $ \db -> runExceptT $ createUser db aliceProfile True
-  cc <- chatInit $ testDBPrefix <> "1"
+  DBMOk <- chatMigrateDB testDBPrefix "myKey"
+  cc <- chatInitKey dbPrefix "myKey"
+  DBMErrorNotADatabase _ <- chatMigrateDB testDBPrefix ""
+  DBMErrorNotADatabase _ <- chatMigrateDB testDBPrefix "anotherKey"
   chatSendCmd cc "/u" `shouldReturn` activeUser
   chatSendCmd cc "/u alice Alice" `shouldReturn` activeUserExists
   chatSendCmd cc "/_start" `shouldReturn` chatStarted

tests/SchemaDump.hs

@@ -5,7 +5,7 @@ module SchemaDump where
 import ChatClient (withTmpFiles)
 import Control.DeepSeq
 import Control.Monad (void)
-import Simplex.Chat.Store (createStore)
+import Simplex.Chat.Store (createChatStore)
 import System.Process (readCreateProcess, shell)
 import Test.Hspec
 
@@ -22,7 +22,7 @@ schemaDumpTest =
 testVerifySchemaDump :: IO ()
 testVerifySchemaDump =
   withTmpFiles $ do
-    void $ createStore testDB "" False
+    void $ createChatStore testDB "" False
     void $ readCreateProcess (shell $ "touch " <> schema) ""
     savedSchema <- readFile schema
     savedSchema `deepseq` pure ()