Merge branch 'master-ghc8107' into master-android

src/Simplex/Chat.hs

@@ -30,6 +30,7 @@ import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isSpace, toLower)
+import Data.Composition ((.:))
 import Data.Constraint (Dict (..))
 import Data.Either (fromRight, rights)
 import Data.Fixed (div')
@@ -245,13 +246,9 @@ cfgServers = \case
   SPSMP -> smp
   SPXFTP -> xftp
 
-startChatController :: forall m. ChatMonad' m => ChatCtrlCfg -> m (Async ())
-startChatController ChatCtrlCfg {subConns, enableExpireCIs, startXFTPWorkers, openDBWithKey} = do
-  ChatController {chatStore, smpAgent} <- ask
-  forM_ openDBWithKey $ \(DBEncryptionKey dbKey) -> liftIO $ do
-    openSQLiteStore chatStore dbKey
-    openSQLiteStore (agentClientStore smpAgent) dbKey
-  resumeAgentClient smpAgent
+startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ())
+startChatController subConns enableExpireCIs startXFTPWorkers = do
+  resumeAgentClient =<< asks smpAgent
   unless subConns $
     chatWriteVar subscriptionMode SMOnlyCreate
   users <- fromRight [] <$> runExceptT (withStoreCtx' (Just "startChatController, getUsers") getUsers)
@@ -465,10 +462,17 @@ processChatCommand = \case
     checkDeleteChatUser user'
     withChatLock "deleteUser" . procCmd $ deleteChatUser user' delSMPQueues
   DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_
-  APIStartChat cfg -> withUser' $ \_ ->
+  APIStartChat ChatCtrlCfg {subConns, enableExpireCIs, startXFTPWorkers, openDBWithKey} -> withUser' $ \_ ->
     asks agentAsync >>= readTVarIO >>= \case
       Just _ -> pure CRChatRunning
-      _ -> checkStoreNotChanged $ startChatController cfg $> CRChatStarted
+      _ -> checkStoreNotChanged $ do
+        forM_ openDBWithKey $ \(DBEncryptionKey dbKey) -> do
+          ChatController {chatStore, smpAgent} <- ask
+          open chatStore dbKey
+          open (agentClientStore smpAgent) dbKey
+        startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted
+        where
+          open = handleDBError DBErrorOpen .: openSQLiteStore
   APIStopChat closeStore -> do
     ask >>= (`stopChatController` closeStore)
     pure CRChatStopped

src/Simplex/Chat/Archive.hs

@@ -9,6 +9,7 @@ module Simplex.Chat.Archive
     importArchive,
     deleteStorage,
     sqlCipherExport,
+    handleDBError,
   )
 where
 
@@ -138,17 +139,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
       withDB (`SQL.exec` testSQL) DBErrorOpen
       atomically $ writeTVar dbEnc $ not (null key')
       where
-        withDB a err =
-          liftIO (bracket (SQL.open $ T.pack f) SQL.close a $> Nothing)
-            `catch` checkSQLError
-            `catch` (\(e :: SomeException) -> sqliteError' e)
-            >>= mapM_ (throwDBError . err)
-          where
-            checkSQLError e = case SQL.sqlError e of
-              SQL.ErrorNotADatabase -> pure $ Just SQLiteErrorNotADatabase
-              _ -> sqliteError' e
-            sqliteError' :: Show e => e -> m (Maybe SQLiteError)
-            sqliteError' = pure . Just . SQLiteError . show
+        withDB a err = handleDBError err $ bracket (SQL.open $ T.pack f) SQL.close a
         exportSQL =
           T.unlines $
             keySQL key
@@ -165,3 +156,16 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
                    "SELECT count(*) FROM sqlite_master;"
                  ]
         keySQL k = ["PRAGMA key = " <> sqlString k <> ";" | not (null k)]
+
+handleDBError :: forall m. ChatMonad m => (SQLiteError -> DatabaseError) -> IO () -> m ()
+handleDBError err a =
+  (liftIO a $> Nothing)
+    `catch` checkSQLError
+    `catch` (\(e :: SomeException) -> sqliteError' e)
+    >>= mapM_ (throwDBError . err)
+  where
+    checkSQLError e = case SQL.sqlError e of
+      SQL.ErrorNotADatabase -> pure $ Just SQLiteErrorNotADatabase
+      _ -> sqliteError' e
+    sqliteError' :: Show e => e -> m (Maybe SQLiteError)
+    sqliteError' = pure . Just . SQLiteError . show

src/Simplex/Chat/Controller.hs

@@ -629,9 +629,6 @@ data ChatCtrlCfg = ChatCtrlCfg
   }
   deriving (Show, Generic, FromJSON)
 
-defChatCtrlCfg :: ChatCtrlCfg
-defChatCtrlCfg = ChatCtrlCfg True True True Nothing
-
 newtype UserPwd = UserPwd {unUserPwd :: Text}
   deriving (Eq, Show)
 

src/Simplex/Chat/Core.hs

@@ -35,7 +35,7 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController
 runSimplexChat ChatOpts {maintenance} u cc chat
   | maintenance = wait =<< async (chat u cc)
   | otherwise = do
-    a1 <- runReaderT (startChatController defChatCtrlCfg) cc
+    a1 <- runReaderT (startChatController True True True) cc
     a2 <- async $ chat u cc
     waitEither_ a1 a2
 

src/Simplex/Chat/View.hs

@@ -1642,7 +1642,7 @@ viewChatError logLevel = \case
     DBErrorEncrypted -> ["error: chat database is already encrypted"]
     DBErrorPlaintext -> ["error: chat database is not encrypted"]
     DBErrorExport e -> ["error encrypting database: " <> sqliteError' e]
-    DBErrorOpen e -> ["error opening database after encryption: " <> sqliteError' e]
+    DBErrorOpen e -> ["error opening database: " <> sqliteError' e]
     e -> ["chat database error: " <> sShow e]
   ChatErrorAgent err entity_ -> case err of
     CMD PROHIBITED -> [withConnEntity <> "error: command is prohibited"]

tests/ChatTests/Direct.hs

@@ -959,6 +959,8 @@ testDatabaseEncryption tmp = do
       alice <## "chat stopped"
       alice ##> "/db key wrongkey nextkey"
       alice <## "error encrypting database: wrong passphrase or invalid database file"
+      alice ##> "/_start key=wrongkey"
+      alice <## "error opening database: wrong passphrase or invalid database file"
       alice ##> "/_start key=mykey"
       alice <## "chat started"
       testChatWorking alice bob