mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: remove mtl typeclasses to reduce overhead (#3975)
* core: remove mtl typeclasses to reduce overhead * strict data, optimization * update simplexmq, clean up * un-unlift attachRevHTTP2Client * remote --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
9b6ca23dcb
commit
d90e2f4436
14 changed files with 687 additions and 633 deletions
|
|
@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
|||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: ee90ea6a69fe8283d37d9821cd83798fd0a76260
|
||||
tag: 6ded721daaca76c416408396aa068a95616f6eaf
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
|
|||
|
|
@ -150,6 +150,7 @@ tests:
|
|||
|
||||
ghc-options:
|
||||
# - -haddock
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Werror=incomplete-patterns
|
||||
|
|
@ -157,3 +158,6 @@ ghc-options:
|
|||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wunused-type-patterns
|
||||
|
||||
default-extensions:
|
||||
- StrictData
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."ee90ea6a69fe8283d37d9821cd83798fd0a76260" = "0my9f4dlfa79yq73rys0m2zb61fd9bp65djvavk6jwy6qzl5vr40";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."6ded721daaca76c416408396aa068a95616f6eaf" = "1w43p5kjhghsfkl98hq8f6j0iv8qk8scvfrqy086amckpdgv0dzv";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
|
||||
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
|
||||
|
|
|
|||
|
|
@ -181,7 +181,9 @@ library
|
|||
Paths_simplex_chat
|
||||
hs-source-dirs:
|
||||
src
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -240,7 +242,9 @@ executable simplex-bot
|
|||
Paths_simplex_chat
|
||||
hs-source-dirs:
|
||||
apps/simplex-bot
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -300,7 +304,9 @@ executable simplex-bot-advanced
|
|||
Paths_simplex_chat
|
||||
hs-source-dirs:
|
||||
apps/simplex-bot-advanced
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -359,11 +365,13 @@ executable simplex-broadcast-bot
|
|||
hs-source-dirs:
|
||||
apps/simplex-broadcast-bot
|
||||
apps/simplex-broadcast-bot/src
|
||||
default-extensions:
|
||||
StrictData
|
||||
other-modules:
|
||||
Broadcast.Bot
|
||||
Broadcast.Options
|
||||
Paths_simplex_chat
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -424,7 +432,9 @@ executable simplex-chat
|
|||
Paths_simplex_chat
|
||||
hs-source-dirs:
|
||||
apps/simplex-chat
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -484,6 +494,8 @@ executable simplex-directory-service
|
|||
hs-source-dirs:
|
||||
apps/simplex-directory-service
|
||||
apps/simplex-directory-service/src
|
||||
default-extensions:
|
||||
StrictData
|
||||
other-modules:
|
||||
Directory.Events
|
||||
Directory.Options
|
||||
|
|
@ -491,7 +503,7 @@ executable simplex-directory-service
|
|||
Directory.Service
|
||||
Directory.Store
|
||||
Paths_simplex_chat
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -582,7 +594,9 @@ test-suite simplex-chat-test
|
|||
tests
|
||||
apps/simplex-broadcast-bot/src
|
||||
apps/simplex-directory-service/src
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
QuickCheck ==2.14.*
|
||||
, aeson ==2.2.*
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -44,7 +44,7 @@ archiveChatDbFile = "simplex_v1_chat.db"
|
|||
archiveFilesFolder :: String
|
||||
archiveFilesFolder = "simplex_v1_files"
|
||||
|
||||
exportArchive :: ChatMonad m => ArchiveConfig -> m ()
|
||||
exportArchive :: ArchiveConfig -> CM' ()
|
||||
exportArchive cfg@ArchiveConfig {archivePath, disableCompression} =
|
||||
withTempDir cfg "simplex-chat." $ \dir -> do
|
||||
StorageFiles {chatStore, agentStore, filesPath} <- storageFiles
|
||||
|
|
@ -55,7 +55,7 @@ exportArchive cfg@ArchiveConfig {archivePath, disableCompression} =
|
|||
let method = if disableCompression == Just True then Z.Store else Z.Deflate
|
||||
Z.createArchive archivePath $ Z.packDirRecur method Z.mkEntrySelector dir
|
||||
|
||||
importArchive :: ChatMonad m => ArchiveConfig -> m [ArchiveError]
|
||||
importArchive :: ArchiveConfig -> CM' [ArchiveError]
|
||||
importArchive cfg@ArchiveConfig {archivePath} =
|
||||
withTempDir cfg "simplex-chat." $ \dir -> do
|
||||
Z.withArchive archivePath $ Z.unpackInto dir
|
||||
|
|
@ -78,12 +78,12 @@ importArchive cfg@ArchiveConfig {archivePath} =
|
|||
(pure [])
|
||||
_ -> pure []
|
||||
|
||||
withTempDir :: ChatMonad m => ArchiveConfig -> (String -> (FilePath -> m a) -> m a)
|
||||
withTempDir :: ArchiveConfig -> (String -> (FilePath -> CM' a) -> CM' a)
|
||||
withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of
|
||||
Just tmpDir -> withTempDirectory tmpDir
|
||||
_ -> withSystemTempDirectory
|
||||
|
||||
copyDirectoryFiles :: ChatMonad m => FilePath -> FilePath -> m [ArchiveError]
|
||||
copyDirectoryFiles :: FilePath -> FilePath -> CM' [ArchiveError]
|
||||
copyDirectoryFiles fromDir toDir = do
|
||||
createDirectoryIfMissing False toDir
|
||||
fs <- listDirectory fromDir
|
||||
|
|
@ -97,9 +97,9 @@ copyDirectoryFiles fromDir toDir = do
|
|||
f' = fromDir </> fn
|
||||
whenM (doesFileExist f') $ copyFile f' $ toDir </> fn
|
||||
|
||||
deleteStorage :: ChatMonad m => m ()
|
||||
deleteStorage :: CM ()
|
||||
deleteStorage = do
|
||||
fs <- storageFiles
|
||||
fs <- lift storageFiles
|
||||
liftIO $ closeSQLiteStore `withStores` fs
|
||||
remove `withDBs` fs
|
||||
mapM_ removeDir $ filesPath fs
|
||||
|
|
@ -114,17 +114,17 @@ data StorageFiles = StorageFiles
|
|||
filesPath :: Maybe FilePath
|
||||
}
|
||||
|
||||
storageFiles :: ChatMonad m => m StorageFiles
|
||||
storageFiles :: CM' StorageFiles
|
||||
storageFiles = do
|
||||
ChatController {chatStore, filesFolder, smpAgent} <- ask
|
||||
let agentStore = agentClientStore smpAgent
|
||||
filesPath <- readTVarIO filesFolder
|
||||
pure StorageFiles {chatStore, agentStore, filesPath}
|
||||
|
||||
sqlCipherExport :: forall m. ChatMonad m => DBEncryptionConfig -> m ()
|
||||
sqlCipherExport :: DBEncryptionConfig -> CM ()
|
||||
sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = DBEncryptionKey key', keepKey} =
|
||||
when (key /= key') $ do
|
||||
fs <- storageFiles
|
||||
fs <- lift storageFiles
|
||||
checkFile `withDBs` fs
|
||||
backup `withDBs` fs
|
||||
checkEncryption `withStores` fs
|
||||
|
|
@ -159,7 +159,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
|
|||
"DETACH DATABASE exported;"
|
||||
]
|
||||
|
||||
withDB :: forall a m. ChatMonad m => FilePath -> (SQL.Database -> IO a) -> (SQLiteError -> DatabaseError) -> m ()
|
||||
withDB :: FilePath -> (SQL.Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
|
||||
withDB f' a err =
|
||||
liftIO (bracket (SQL.open $ T.pack f') SQL.close a $> Nothing)
|
||||
`catch` checkSQLError
|
||||
|
|
@ -169,7 +169,7 @@ withDB f' a err =
|
|||
checkSQLError e = case SQL.sqlError e of
|
||||
SQL.ErrorNotADatabase -> pure $ Just SQLiteErrorNotADatabase
|
||||
_ -> sqliteError' e
|
||||
sqliteError' :: Show e => e -> m (Maybe SQLiteError)
|
||||
sqliteError' :: Show e => e -> CM (Maybe SQLiteError)
|
||||
sqliteError' = pure . Just . SQLiteError . show
|
||||
|
||||
testSQL :: BA.ScrubbedBytes -> Text
|
||||
|
|
@ -184,9 +184,9 @@ testSQL k =
|
|||
keySQL :: BA.ScrubbedBytes -> [Text]
|
||||
keySQL k = ["PRAGMA key = " <> keyString k <> ";" | not (BA.null k)]
|
||||
|
||||
sqlCipherTestKey :: forall m. ChatMonad m => DBEncryptionKey -> m ()
|
||||
sqlCipherTestKey :: DBEncryptionKey -> CM ()
|
||||
sqlCipherTestKey (DBEncryptionKey key) = do
|
||||
fs <- storageFiles
|
||||
fs <- lift storageFiles
|
||||
testKey `withDBs` fs
|
||||
where
|
||||
testKey f = withDB f (`SQL.exec` testSQL key) DBErrorOpen
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@ import Simplex.Chat.Remote.Types
|
|||
import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Util (liftIOEither)
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure)
|
||||
|
|
@ -82,7 +83,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), Cor
|
|||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (allFinally, catchAllErrors, liftIOEither, tryAllErrors, (<$$>))
|
||||
import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors', (<$$>))
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation)
|
||||
import Simplex.RemoteControl.Types
|
||||
|
|
@ -1140,7 +1141,7 @@ data DatabaseError
|
|||
data SQLiteError = SQLiteErrorNotADatabase | SQLiteError String
|
||||
deriving (Show, Exception)
|
||||
|
||||
throwDBError :: ChatMonad m => DatabaseError -> m ()
|
||||
throwDBError :: DatabaseError -> CM ()
|
||||
throwDBError = throwError . ChatErrorDatabase
|
||||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
|
|
@ -1244,39 +1245,59 @@ data RemoteCtrlInfo = RemoteCtrlInfo
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
type CM' a = ReaderT ChatController IO a
|
||||
|
||||
type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
|
||||
type CM a = ExceptT ChatError (ReaderT ChatController IO) a
|
||||
|
||||
chatReadVar :: ChatMonad' m => (ChatController -> TVar a) -> m a
|
||||
chatReadVar f = asks f >>= readTVarIO
|
||||
chatReadVar :: (ChatController -> TVar a) -> CM a
|
||||
chatReadVar = lift . chatReadVar'
|
||||
{-# INLINE chatReadVar #-}
|
||||
|
||||
chatWriteVar :: ChatMonad' m => (ChatController -> TVar a) -> a -> m ()
|
||||
chatWriteVar f value = asks f >>= atomically . (`writeTVar` value)
|
||||
chatReadVar' :: (ChatController -> TVar a) -> CM' a
|
||||
chatReadVar' f = asks f >>= readTVarIO
|
||||
{-# INLINE chatReadVar' #-}
|
||||
|
||||
chatWriteVar :: (ChatController -> TVar a) -> a -> CM ()
|
||||
chatWriteVar f = lift . chatWriteVar' f
|
||||
{-# INLINE chatWriteVar #-}
|
||||
|
||||
chatModifyVar :: ChatMonad' m => (ChatController -> TVar a) -> (a -> a) -> m ()
|
||||
chatModifyVar f newValue = asks f >>= atomically . (`modifyTVar'` newValue)
|
||||
chatWriteVar' :: (ChatController -> TVar a) -> a -> CM' ()
|
||||
chatWriteVar' f value = asks f >>= atomically . (`writeTVar` value)
|
||||
{-# INLINE chatWriteVar' #-}
|
||||
|
||||
chatModifyVar :: (ChatController -> TVar a) -> (a -> a) -> CM ()
|
||||
chatModifyVar f = lift . chatModifyVar' f
|
||||
{-# INLINE chatModifyVar #-}
|
||||
|
||||
setContactNetworkStatus :: ChatMonad' m => Contact -> NetworkStatus -> m ()
|
||||
setContactNetworkStatus Contact {activeConn = Nothing} _ = pure ()
|
||||
setContactNetworkStatus Contact {activeConn = Just Connection {agentConnId}} status = chatModifyVar connNetworkStatuses $ M.insert agentConnId status
|
||||
chatModifyVar' :: (ChatController -> TVar a) -> (a -> a) -> CM' ()
|
||||
chatModifyVar' f newValue = asks f >>= atomically . (`modifyTVar'` newValue)
|
||||
{-# INLINE chatModifyVar' #-}
|
||||
|
||||
tryChatError :: ChatMonad m => m a -> m (Either ChatError a)
|
||||
setContactNetworkStatus :: Contact -> NetworkStatus -> CM' ()
|
||||
setContactNetworkStatus Contact {activeConn = Nothing} _ = pure ()
|
||||
setContactNetworkStatus Contact {activeConn = Just Connection {agentConnId}} status = chatModifyVar' connNetworkStatuses $ M.insert agentConnId status
|
||||
|
||||
tryChatError :: CM a -> CM (Either ChatError a)
|
||||
tryChatError = tryAllErrors mkChatError
|
||||
{-# INLINE tryChatError #-}
|
||||
|
||||
catchChatError :: ChatMonad m => m a -> (ChatError -> m a) -> m a
|
||||
tryChatError' :: CM a -> CM' (Either ChatError a)
|
||||
tryChatError' = tryAllErrors' mkChatError
|
||||
{-# INLINE tryChatError' #-}
|
||||
|
||||
catchChatError :: CM a -> (ChatError -> CM a) -> CM a
|
||||
catchChatError = catchAllErrors mkChatError
|
||||
{-# INLINE catchChatError #-}
|
||||
|
||||
chatFinally :: ChatMonad m => m a -> m b -> m a
|
||||
catchChatError' :: CM a -> (ChatError -> CM' a) -> CM' a
|
||||
catchChatError' = catchAllErrors' mkChatError
|
||||
{-# INLINE catchChatError' #-}
|
||||
|
||||
chatFinally :: CM a -> CM b -> CM a
|
||||
chatFinally = allFinally mkChatError
|
||||
{-# INLINE chatFinally #-}
|
||||
|
||||
onChatError :: ChatMonad m => m a -> m b -> m a
|
||||
onChatError :: CM a -> CM b -> CM a
|
||||
a `onChatError` onErr = a `catchChatError` \e -> onErr >> throwError e
|
||||
{-# INLINE onChatError #-}
|
||||
|
||||
|
|
@ -1295,12 +1316,16 @@ mkStoreError = SEInternalError . show
|
|||
chatCmdError :: Maybe User -> String -> ChatResponse
|
||||
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
|
||||
|
||||
throwChatError :: ChatMonad m => ChatErrorType -> m a
|
||||
throwChatError :: ChatErrorType -> CM a
|
||||
throwChatError = throwError . ChatError
|
||||
|
||||
-- | Emit local events.
|
||||
toView :: ChatMonad' m => ChatResponse -> m ()
|
||||
toView ev = do
|
||||
toView :: ChatResponse -> CM ()
|
||||
toView = lift . toView'
|
||||
{-# INLINE toView #-}
|
||||
|
||||
toView' :: ChatResponse -> CM' ()
|
||||
toView' ev = do
|
||||
cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask
|
||||
event <- liftIO $ eventHook chatHooks cc ev
|
||||
atomically $
|
||||
|
|
@ -1310,15 +1335,15 @@ toView ev = do
|
|||
-- TODO potentially, it should hold some events while connecting
|
||||
_ -> writeTBQueue localQ (Nothing, Nothing, event)
|
||||
|
||||
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
|
||||
withStore' :: (DB.Connection -> IO a) -> CM a
|
||||
withStore' action = withStore $ liftIO . action
|
||||
|
||||
withStore :: ChatMonad m => (DB.Connection -> ExceptT StoreError IO a) -> m a
|
||||
withStore :: (DB.Connection -> ExceptT StoreError IO a) -> CM a
|
||||
withStore action = do
|
||||
ChatController {chatStore} <- ask
|
||||
liftIOEither $ withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors
|
||||
|
||||
withStoreBatch :: (ChatMonad' m, Traversable t) => (DB.Connection -> t (IO (Either ChatError a))) -> m (t (Either ChatError a))
|
||||
withStoreBatch :: Traversable t => (DB.Connection -> t (IO (Either ChatError a))) -> CM' (t (Either ChatError a))
|
||||
withStoreBatch actions = do
|
||||
ChatController {chatStore} <- ask
|
||||
liftIO $ withTransaction chatStore $ mapM (`E.catches` handleDBErrors) . actions
|
||||
|
|
@ -1332,17 +1357,17 @@ handleDBErrors =
|
|||
E.Handler $ \(E.SomeException e) -> pure . Left . ChatErrorStore . SEDBException $ show e
|
||||
]
|
||||
|
||||
withStoreBatch' :: (ChatMonad' m, Traversable t) => (DB.Connection -> t (IO a)) -> m (t (Either ChatError a))
|
||||
withStoreBatch' :: Traversable t => (DB.Connection -> t (IO a)) -> CM' (t (Either ChatError a))
|
||||
withStoreBatch' actions = withStoreBatch $ fmap (fmap Right) . actions
|
||||
|
||||
withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
|
||||
withAgent :: (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
|
||||
withAgent action =
|
||||
asks smpAgent
|
||||
>>= runExceptT . action
|
||||
>>= liftIO . runExceptT . action
|
||||
>>= liftEither . first (`ChatErrorAgent` Nothing)
|
||||
|
||||
withAgent' :: ChatMonad' m => (AgentClient -> m a) -> m a
|
||||
withAgent' action = asks smpAgent >>= action
|
||||
withAgent' :: (AgentClient -> IO a) -> CM' a
|
||||
withAgent' action = asks smpAgent >>= liftIO . action
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection)
|
||||
|
||||
|
|
|
|||
|
|
@ -3,13 +3,12 @@
|
|||
|
||||
module Simplex.Chat.Files where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import System.FilePath (combine, splitExtensions)
|
||||
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
|
||||
|
||||
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
||||
uniqueCombine :: FilePath -> String -> IO FilePath
|
||||
uniqueCombine fPath fName = tryCombine (0 :: Int)
|
||||
where
|
||||
tryCombine n =
|
||||
|
|
@ -18,10 +17,10 @@ uniqueCombine fPath fName = tryCombine (0 :: Int)
|
|||
f = fPath `combine` (name <> suffix <> ext)
|
||||
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
|
||||
|
||||
getChatTempDirectory :: ChatMonad m => m FilePath
|
||||
getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure
|
||||
getChatTempDirectory :: CM' FilePath
|
||||
getChatTempDirectory = chatReadVar' tempDirectory >>= maybe getTemporaryDirectory pure
|
||||
|
||||
getDefaultFilesFolder :: ChatMonad m => m FilePath
|
||||
getDefaultFilesFolder :: CM' FilePath
|
||||
getDefaultFilesFolder = do
|
||||
dir <- (`combine` "Downloads") <$> getHomeDirectory
|
||||
ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ import Simplex.Chat.Store.Files
|
|||
import Simplex.Chat.Store.Remote
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (encryptFile)
|
||||
import Simplex.Chat.Util (liftIOEither, encryptFile)
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP))
|
||||
|
|
@ -95,7 +95,7 @@ discoveryTimeout = 60000000
|
|||
|
||||
-- * Desktop side
|
||||
|
||||
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
|
||||
getRemoteHostClient :: RemoteHostId -> CM RemoteHostClient
|
||||
getRemoteHostClient rhId = do
|
||||
sessions <- asks remoteHostSessions
|
||||
liftIOEither . atomically $
|
||||
|
|
@ -106,7 +106,7 @@ getRemoteHostClient rhId = do
|
|||
where
|
||||
rhKey = RHId rhId
|
||||
|
||||
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
|
||||
withRemoteHostSession :: RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> CM a
|
||||
withRemoteHostSession rhKey sseq f = do
|
||||
sessions <- asks remoteHostSessions
|
||||
r <-
|
||||
|
|
@ -121,7 +121,7 @@ withRemoteHostSession rhKey sseq f = do
|
|||
liftEither r
|
||||
|
||||
-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
|
||||
setNewRemoteHostId :: ChatMonad m => SessionSeq -> RemoteHostId -> m ()
|
||||
setNewRemoteHostId :: SessionSeq -> RemoteHostId -> CM ()
|
||||
setNewRemoteHostId sseq rhId = do
|
||||
sessions <- asks remoteHostSessions
|
||||
liftIOEither . atomically $ do
|
||||
|
|
@ -136,13 +136,13 @@ setNewRemoteHostId sseq rhId = do
|
|||
where
|
||||
err = pure . Left . ChatErrorRemoteHost RHNew
|
||||
|
||||
startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> Maybe RCCtrlAddress -> Maybe Word16 -> m (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
|
||||
startRemoteHost :: Maybe (RemoteHostId, Bool) -> Maybe RCCtrlAddress -> Maybe Word16 -> CM (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
|
||||
startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
||||
(rhKey, multicast, remoteHost_, pairing) <- case rh_ of
|
||||
Just (rhId, multicast) -> do
|
||||
rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
|
||||
pure (RHId rhId, multicast, Just $ remoteHostInfo rh $ Just RHSStarting, hostPairing) -- get from the database, start multicast if requested
|
||||
Nothing -> withAgent $ \a -> (RHNew,False,Nothing,) <$> rcNewHostPairing a
|
||||
Nothing -> lift . withAgent' $ \a -> (RHNew,False,Nothing,) <$> rcNewHostPairing a
|
||||
sseq <- startRemoteHostSession rhKey
|
||||
ctrlAppInfo <- mkCtrlAppInfo
|
||||
(localAddrs, invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast rcAddrPrefs_ port_
|
||||
|
|
@ -170,18 +170,18 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
|||
unless (isAppCompatible appVersion ctrlAppVersionRange) $ throwError $ RHEBadVersion appVersion
|
||||
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
|
||||
pure hostInfo
|
||||
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
|
||||
handleConnectError :: RHKey -> SessionSeq -> CM a -> CM a
|
||||
handleConnectError rhKey sessSeq action =
|
||||
action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
||||
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
||||
throwError err
|
||||
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
|
||||
handleHostError :: SessionSeq -> TVar RHKey -> CM () -> CM ()
|
||||
handleHostError sessSeq rhKeyVar action =
|
||||
action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
|
||||
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
|
||||
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||
waitForHostSession :: Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> CM ()
|
||||
waitForHostSession remoteHost_ rhKey sseq rcAddr_ rhKeyVar vars = do
|
||||
(sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
|
||||
let sessionCode = verificationCode sessId
|
||||
|
|
@ -203,7 +203,7 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
|||
toView $ CRNewRemoteHost rhi
|
||||
-- set up HTTP transport and remote profile protocol
|
||||
disconnected <- toIO $ onDisconnected rhKey' sseq
|
||||
httpClient <- liftEitherError (httpError remoteHostId) $ attachRevHTTP2Client disconnected tls
|
||||
httpClient <- liftError' (httpError remoteHostId) $ attachRevHTTP2Client disconnected tls
|
||||
rhClient <- mkRemoteHostClient httpClient sessionKeys sessId storePath hostInfo
|
||||
pollAction <- async $ pollEvents remoteHostId rhClient
|
||||
withRemoteHostSession rhKey' sseq $ \case
|
||||
|
|
@ -211,7 +211,7 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
|||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host
|
||||
toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}}
|
||||
upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo
|
||||
upsertRemoteHost :: RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> CM RemoteHostInfo
|
||||
upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ rcAddr_ hostDeviceName sseq state = do
|
||||
KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
|
||||
case rhi_ of
|
||||
|
|
@ -223,11 +223,11 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
|||
Just rhi@RemoteHostInfo {remoteHostId} -> do
|
||||
withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey' rcAddr_ port_
|
||||
pure (rhi :: RemoteHostInfo) {sessionState = Just state}
|
||||
onDisconnected :: ChatMonad m => RHKey -> SessionSeq -> m ()
|
||||
onDisconnected :: RHKey -> SessionSeq -> CM ()
|
||||
onDisconnected rhKey sseq = do
|
||||
logDebug $ "HTTP2 client disconnected: " <> tshow (rhKey, sseq)
|
||||
cancelRemoteHostSession (Just (sseq, RHSRDisconnected)) rhKey
|
||||
pollEvents :: ChatMonad m => RemoteHostId -> RemoteHostClient -> m ()
|
||||
pollEvents :: RemoteHostId -> RemoteHostClient -> CM ()
|
||||
pollEvents rhId rhClient = do
|
||||
oq <- asks outputQ
|
||||
forever $ do
|
||||
|
|
@ -236,7 +236,7 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
|
|||
httpError :: RemoteHostId -> HTTP2ClientError -> ChatError
|
||||
httpError rhId = ChatErrorRemoteHost (RHId rhId) . RHEProtocolError . RPEHTTP2 . tshow
|
||||
|
||||
startRemoteHostSession :: ChatMonad m => RHKey -> m SessionSeq
|
||||
startRemoteHostSession :: RHKey -> CM SessionSeq
|
||||
startRemoteHostSession rhKey = do
|
||||
sessions <- asks remoteHostSessions
|
||||
nextSessionSeq <- asks remoteSessionSeq
|
||||
|
|
@ -247,12 +247,12 @@ startRemoteHostSession rhKey = do
|
|||
sessionSeq <- stateTVar nextSessionSeq $ \s -> (s, s + 1)
|
||||
Right sessionSeq <$ TM.insert rhKey (sessionSeq, RHSessionStarting) sessions
|
||||
|
||||
closeRemoteHost :: ChatMonad m => RHKey -> m ()
|
||||
closeRemoteHost :: RHKey -> CM ()
|
||||
closeRemoteHost rhKey = do
|
||||
logNote $ "Closing remote host session for " <> tshow rhKey
|
||||
cancelRemoteHostSession Nothing rhKey
|
||||
|
||||
cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> m ()
|
||||
cancelRemoteHostSession :: Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
|
||||
cancelRemoteHostSession handlerInfo_ rhKey = do
|
||||
sessions <- asks remoteHostSessions
|
||||
crh <- asks currentRemoteHost
|
||||
|
|
@ -299,7 +299,7 @@ cancelRemoteHost handlingError = \case
|
|||
randomStorePath :: IO FilePath
|
||||
randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
|
||||
|
||||
listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
|
||||
listRemoteHosts :: CM [RemoteHostInfo]
|
||||
listRemoteHosts = do
|
||||
sessions <- chatReadVar remoteHostSessions
|
||||
map (rhInfo sessions) <$> withStore' getRemoteHosts
|
||||
|
|
@ -307,7 +307,7 @@ listRemoteHosts = do
|
|||
rhInfo sessions rh@RemoteHost {remoteHostId} =
|
||||
remoteHostInfo rh $ rhsSessionState . snd <$> M.lookup (RHId remoteHostId) sessions
|
||||
|
||||
switchRemoteHost :: ChatMonad m => Maybe RemoteHostId -> m (Maybe RemoteHostInfo)
|
||||
switchRemoteHost :: Maybe RemoteHostId -> CM (Maybe RemoteHostInfo)
|
||||
switchRemoteHost rhId_ = do
|
||||
rhi_ <- forM rhId_ $ \rhId -> do
|
||||
let rhKey = RHId rhId
|
||||
|
|
@ -322,7 +322,7 @@ remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
|
|||
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_} sessionState =
|
||||
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_, sessionState}
|
||||
|
||||
deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
|
||||
deleteRemoteHost :: RemoteHostId -> CM ()
|
||||
deleteRemoteHost rhId = do
|
||||
RemoteHost {storePath} <- withStore (`getRemoteHost` rhId)
|
||||
chatReadVar remoteHostsFolder >>= \case
|
||||
|
|
@ -333,7 +333,7 @@ deleteRemoteHost rhId = do
|
|||
Nothing -> logWarn "Local file store not available while deleting remote host"
|
||||
withStore' (`deleteRemoteHostRecord` rhId)
|
||||
|
||||
storeRemoteFile :: forall m. ChatMonad m => RemoteHostId -> Maybe Bool -> FilePath -> m CryptoFile
|
||||
storeRemoteFile :: RemoteHostId -> Maybe Bool -> FilePath -> CM CryptoFile
|
||||
storeRemoteFile rhId encrypted_ localPath = do
|
||||
c@RemoteHostClient {encryptHostFiles, storePath} <- getRemoteHostClient rhId
|
||||
let encrypt = fromMaybe encryptHostFiles encrypted_
|
||||
|
|
@ -347,23 +347,23 @@ storeRemoteFile rhId encrypted_ localPath = do
|
|||
(if encrypt then renameFile else copyFile) filePath hPath
|
||||
pure (cf :: CryptoFile) {filePath = filePath'}
|
||||
where
|
||||
encryptLocalFile :: m CryptoFile
|
||||
encryptLocalFile :: CM CryptoFile
|
||||
encryptLocalFile = do
|
||||
tmpDir <- getChatTempDirectory
|
||||
tmpDir <- lift getChatTempDirectory
|
||||
createDirectoryIfMissing True tmpDir
|
||||
tmpFile <- tmpDir `uniqueCombine` takeFileName localPath
|
||||
tmpFile <- liftIO $ tmpDir `uniqueCombine` takeFileName localPath
|
||||
cfArgs <- atomically . CF.randomArgs =<< asks random
|
||||
liftError (ChatError . CEFileWrite tmpFile) $ encryptFile localPath tmpFile cfArgs
|
||||
pure $ CryptoFile tmpFile $ Just cfArgs
|
||||
|
||||
getRemoteFile :: ChatMonad m => RemoteHostId -> RemoteFile -> m ()
|
||||
getRemoteFile :: RemoteHostId -> RemoteFile -> CM ()
|
||||
getRemoteFile rhId rf = do
|
||||
c@RemoteHostClient {storePath} <- getRemoteHostClient rhId
|
||||
dir <- (</> storePath </> archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar remoteHostsFolder)
|
||||
dir <- lift $ (</> storePath </> archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar' remoteHostsFolder)
|
||||
createDirectoryIfMissing True dir
|
||||
liftRH rhId $ remoteGetFile c dir rf
|
||||
|
||||
processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> m ChatResponse
|
||||
processRemoteCommand :: RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> CM ChatResponse
|
||||
processRemoteCommand remoteHostId c cmd s = case cmd of
|
||||
SendFile chatName f -> sendFile "/f" chatName f
|
||||
SendImage chatName f -> sendFile "/img" chatName f
|
||||
|
|
@ -378,7 +378,7 @@ processRemoteCommand remoteHostId c cmd s = case cmd of
|
|||
maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs
|
||||
<> encodeUtf8 (T.pack filePath)
|
||||
|
||||
liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a
|
||||
liftRH :: RemoteHostId -> ExceptT RemoteProtocolError IO a -> CM a
|
||||
liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
|
||||
|
||||
-- * Mobile side
|
||||
|
|
@ -386,7 +386,7 @@ liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
|
|||
-- ** QR/link
|
||||
|
||||
-- | Use provided OOB link as an annouce
|
||||
connectRemoteCtrlURI :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrlURI :: RCSignedInvitation -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrlURI signedInv = do
|
||||
verifiedInv <- maybe (throwError $ ChatErrorRemoteCtrl RCEBadInvitation) pure $ verifySignedInvitation signedInv
|
||||
sseq <- startRemoteCtrlSession
|
||||
|
|
@ -394,7 +394,7 @@ connectRemoteCtrlURI signedInv = do
|
|||
|
||||
-- ** Multicast
|
||||
|
||||
findKnownRemoteCtrl :: ChatMonad m => m ()
|
||||
findKnownRemoteCtrl :: CM ()
|
||||
findKnownRemoteCtrl = do
|
||||
knownCtrls <- withStore' getRemoteCtrls
|
||||
pairings <- case nonEmpty knownCtrls of
|
||||
|
|
@ -420,7 +420,7 @@ findKnownRemoteCtrl = do
|
|||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
atomically $ putTMVar cmdOk ()
|
||||
|
||||
confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m (RemoteCtrlInfo, CtrlAppInfo)
|
||||
confirmRemoteCtrl :: RemoteCtrlId -> CM (RemoteCtrlInfo, CtrlAppInfo)
|
||||
confirmRemoteCtrl rcId = do
|
||||
session <- asks remoteCtrlSession
|
||||
(sseq, listener, found) <- liftIOEither $ atomically $ do
|
||||
|
|
@ -438,7 +438,7 @@ confirmRemoteCtrl rcId = do
|
|||
|
||||
-- ** Common
|
||||
|
||||
startRemoteCtrlSession :: ChatMonad m => m SessionSeq
|
||||
startRemoteCtrlSession :: CM SessionSeq
|
||||
startRemoteCtrlSession = do
|
||||
session <- asks remoteCtrlSession
|
||||
nextSessionSeq <- asks remoteSessionSeq
|
||||
|
|
@ -449,7 +449,7 @@ startRemoteCtrlSession = do
|
|||
sseq <- stateTVar nextSessionSeq $ \s -> (s, s + 1)
|
||||
Right sseq <$ writeTVar session (Just (sseq, RCSessionStarting))
|
||||
|
||||
connectRemoteCtrl :: ChatMonad m => RCVerifiedInvitation -> SessionSeq -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrl :: RCVerifiedInvitation -> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) sseq = handleCtrlError sseq RCSRConnectionFailed "connectRemoteCtrl" $ do
|
||||
ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName} <- parseCtrlAppInfo app
|
||||
v <- checkAppVersion ctrlInfo
|
||||
|
|
@ -470,7 +470,7 @@ connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app})
|
|||
where
|
||||
validateRemoteCtrl RCInvitation {idkey} RemoteCtrl {ctrlPairing = RCCtrlPairing {idPubKey}} =
|
||||
unless (idkey == idPubKey) $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError $ PRERemoteControl RCEIdentity
|
||||
waitForCtrlSession :: ChatMonad m => Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> m ()
|
||||
waitForCtrlSession :: Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> CM ()
|
||||
waitForCtrlSession rc_ ctrlName rcsClient vars = do
|
||||
(uniq, tls, rcsWaitConfirmation) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars
|
||||
let sessionCode = verificationCode uniq
|
||||
|
|
@ -489,18 +489,18 @@ connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app})
|
|||
encryptFiles <- chatReadVar encryptLocalFiles
|
||||
pure HostAppInfo {appVersion, deviceName = hostDeviceName, encoding = localEncoding, encryptFiles}
|
||||
|
||||
parseCtrlAppInfo :: ChatMonad m => JT.Value -> m CtrlAppInfo
|
||||
parseCtrlAppInfo :: JT.Value -> CM CtrlAppInfo
|
||||
parseCtrlAppInfo ctrlAppInfo = do
|
||||
liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
|
||||
|
||||
handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> m ()
|
||||
handleRemoteCommand :: (ByteString -> CM' ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> CM' ()
|
||||
handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
|
||||
logDebug "handleRemoteCommand"
|
||||
liftRC (tryRemoteError parseRequest) >>= \case
|
||||
liftIO (tryRemoteError' parseRequest) >>= \case
|
||||
Right (getNext, rc) -> do
|
||||
chatReadVar currentUser >>= \case
|
||||
chatReadVar' currentUser >>= \case
|
||||
Nothing -> replyError $ ChatError CENoActiveUser
|
||||
Just user -> processCommand user getNext rc `catchChatError` replyError
|
||||
Just user -> processCommand user getNext rc `catchChatError'` replyError
|
||||
Left e -> reply $ RRProtocolError e
|
||||
where
|
||||
parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand)
|
||||
|
|
@ -508,67 +508,72 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
|
|||
(header, getNext) <- parseDecryptHTTP2Body encryption request reqBody
|
||||
(getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecode header)
|
||||
replyError = reply . RRChatResponse . CRChatCmdError Nothing
|
||||
processCommand :: User -> GetChunk -> RemoteCommand -> m ()
|
||||
processCommand :: User -> GetChunk -> RemoteCommand -> CM ()
|
||||
processCommand user getNext = \case
|
||||
RCSend {command} -> handleSend execChatCommand command >>= reply
|
||||
RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply
|
||||
RCStoreFile {fileName, fileSize, fileDigest} -> handleStoreFile encryption fileName fileSize fileDigest getNext >>= reply
|
||||
RCSend {command} -> lift $ handleSend execChatCommand command >>= reply
|
||||
RCRecv {wait = time} -> lift $ liftIO (handleRecv time remoteOutputQ) >>= reply
|
||||
RCStoreFile {fileName, fileSize, fileDigest} -> lift $ handleStoreFile encryption fileName fileSize fileDigest getNext >>= reply
|
||||
RCGetFile {file} -> handleGetFile encryption user file replyWith
|
||||
reply :: RemoteResponse -> m ()
|
||||
reply :: RemoteResponse -> CM' ()
|
||||
reply = (`replyWith` \_ -> pure ())
|
||||
replyWith :: Respond m
|
||||
replyWith rr attach = do
|
||||
resp <- liftRC $ encryptEncodeHTTP2Body encryption $ J.encode rr
|
||||
liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do
|
||||
send resp
|
||||
attach send
|
||||
flush
|
||||
replyWith :: Respond
|
||||
replyWith rr attach =
|
||||
liftIO (tryRemoteError' . encryptEncodeHTTP2Body encryption $ J.encode rr) >>= \case
|
||||
Right resp -> liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do
|
||||
send resp
|
||||
attach send
|
||||
flush
|
||||
Left e -> toView' . CRChatError Nothing . ChatErrorRemoteCtrl $ RCEProtocolError e
|
||||
|
||||
takeRCStep :: ChatMonad m => RCStepTMVar a -> m a
|
||||
takeRCStep = liftEitherError (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar
|
||||
takeRCStep :: RCStepTMVar a -> CM a
|
||||
takeRCStep = liftError' (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar
|
||||
|
||||
type GetChunk = Int -> IO ByteString
|
||||
|
||||
type SendChunk = Builder -> IO ()
|
||||
|
||||
type Respond m = RemoteResponse -> (SendChunk -> IO ()) -> m ()
|
||||
type Respond = RemoteResponse -> (SendChunk -> IO ()) -> CM' ()
|
||||
|
||||
liftRC :: ChatMonad m => ExceptT RemoteProtocolError IO a -> m a
|
||||
liftRC :: ExceptT RemoteProtocolError IO a -> CM a
|
||||
liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError)
|
||||
|
||||
tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolError IO (Either RemoteProtocolError a)
|
||||
tryRemoteError = tryAllErrors (RPEException . tshow)
|
||||
{-# INLINE tryRemoteError #-}
|
||||
|
||||
handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse
|
||||
tryRemoteError' :: ExceptT RemoteProtocolError IO a -> IO (Either RemoteProtocolError a)
|
||||
tryRemoteError' = tryAllErrors' (RPEException . tshow)
|
||||
{-# INLINE tryRemoteError' #-}
|
||||
|
||||
handleSend :: (ByteString -> CM' ChatResponse) -> Text -> CM' RemoteResponse
|
||||
handleSend execChatCommand command = do
|
||||
logDebug $ "Send: " <> tshow command
|
||||
-- execChatCommand checks for remote-allowed commands
|
||||
-- convert errors thrown in ChatMonad into error responses to prevent aborting the protocol wrapper
|
||||
RRChatResponse <$> execChatCommand (encodeUtf8 command) `catchError` (pure . CRChatError Nothing)
|
||||
-- convert errors thrown in execChatCommand into error responses to prevent aborting the protocol wrapper
|
||||
RRChatResponse <$> execChatCommand (encodeUtf8 command)
|
||||
|
||||
handleRecv :: MonadUnliftIO m => Int -> TBQueue ChatResponse -> m RemoteResponse
|
||||
handleRecv :: Int -> TBQueue ChatResponse -> IO RemoteResponse
|
||||
handleRecv time events = do
|
||||
logDebug $ "Recv: " <> tshow time
|
||||
RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
|
||||
|
||||
-- TODO this command could remember stored files and return IDs to allow removing files that are not needed.
|
||||
-- Also, there should be some process removing unused files uploaded to remote host (possibly, all unused files).
|
||||
handleStoreFile :: forall m. ChatMonad m => RemoteCrypto -> FilePath -> Word32 -> FileDigest -> GetChunk -> m RemoteResponse
|
||||
handleStoreFile :: RemoteCrypto -> FilePath -> Word32 -> FileDigest -> GetChunk -> CM' RemoteResponse
|
||||
handleStoreFile encryption fileName fileSize fileDigest getChunk =
|
||||
either RRProtocolError RRFileStored <$> (chatReadVar filesFolder >>= storeFile)
|
||||
either RRProtocolError RRFileStored <$> (chatReadVar' filesFolder >>= storeFile)
|
||||
where
|
||||
storeFile :: Maybe FilePath -> m (Either RemoteProtocolError FilePath)
|
||||
storeFile :: Maybe FilePath -> CM' (Either RemoteProtocolError FilePath)
|
||||
storeFile = \case
|
||||
Just ff -> takeFileName <$$> storeFileTo ff
|
||||
Nothing -> storeFileTo =<< getDefaultFilesFolder
|
||||
storeFileTo :: FilePath -> m (Either RemoteProtocolError FilePath)
|
||||
storeFileTo dir = liftRC . tryRemoteError $ do
|
||||
filePath <- dir `uniqueCombine` fileName
|
||||
storeFileTo :: FilePath -> CM' (Either RemoteProtocolError FilePath)
|
||||
storeFileTo dir = liftIO . tryRemoteError' $ do
|
||||
filePath <- liftIO $ dir `uniqueCombine` fileName
|
||||
receiveEncryptedFile encryption getChunk fileSize fileDigest filePath
|
||||
pure filePath
|
||||
|
||||
handleGetFile :: ChatMonad m => RemoteCrypto -> User -> RemoteFile -> Respond m -> m ()
|
||||
handleGetFile :: RemoteCrypto -> User -> RemoteFile -> Respond -> CM ()
|
||||
handleGetFile encryption User {userId} RemoteFile {userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do
|
||||
logDebug $ "GetFile: " <> tshow filePath
|
||||
unless (userId == commandUserId) $ throwChatError $ CEDifferentActiveUser {commandUserId, activeUserId = userId}
|
||||
|
|
@ -577,13 +582,13 @@ handleGetFile encryption User {userId} RemoteFile {userId = commandUserId, fileI
|
|||
cf <- getLocalCryptoFile db commandUserId fileId sent
|
||||
unless (cf == cf') $ throwError $ SEFileNotFound fileId
|
||||
liftRC (tryRemoteError $ getFileInfo path) >>= \case
|
||||
Left e -> reply (RRProtocolError e) $ \_ -> pure ()
|
||||
Left e -> lift $ reply (RRProtocolError e) $ \_ -> pure ()
|
||||
Right (fileSize, fileDigest) ->
|
||||
withFile path ReadMode $ \h -> do
|
||||
ExceptT . withFile path ReadMode $ \h -> runExceptT $ do
|
||||
encFile <- liftRC $ prepareEncryptedFile encryption (h, fileSize)
|
||||
reply RRFile {fileSize, fileDigest} $ sendEncryptedFile encFile
|
||||
lift $ reply RRFile {fileSize, fileDigest} $ sendEncryptedFile encFile
|
||||
|
||||
listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
|
||||
listRemoteCtrls :: CM [RemoteCtrlInfo]
|
||||
listRemoteCtrls = do
|
||||
session <- snd <$$> chatReadVar remoteCtrlSession
|
||||
let rcId = sessionRcId =<< session
|
||||
|
|
@ -604,7 +609,7 @@ remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState =
|
|||
RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState}
|
||||
|
||||
-- | Take a look at emoji of tlsunique, commit pairing, and start session server
|
||||
verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession :: (ByteString -> CM' ChatResponse) -> Text -> CM RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
(sseq, client, ctrlName, sessionCode, vars) <-
|
||||
chatReadVar remoteCtrlSession >>= \case
|
||||
|
|
@ -619,14 +624,15 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
|||
rc@RemoteCtrl {remoteCtrlId} <- upsertRemoteCtrl ctrlName rcCtrlPairing
|
||||
remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO
|
||||
encryption <- mkCtrlRemoteCrypto sessionKeys $ tlsUniq tls
|
||||
http2Server <- async $ attachHTTP2Server tls $ handleRemoteCommand execChatCommand encryption remoteOutputQ
|
||||
cc <- ask
|
||||
http2Server <- liftIO . async $ attachHTTP2Server tls $ \req -> handleRemoteCommand execChatCommand encryption remoteOutputQ req `runReaderT` cc
|
||||
void . forkIO $ monitor sseq http2Server
|
||||
updateRemoteCtrlSession sseq $ \case
|
||||
RCSessionPendingConfirmation {} -> Right RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ}
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
pure $ remoteCtrlInfo rc $ Just RCSConnected {sessionCode = tlsSessionCode tls}
|
||||
where
|
||||
upsertRemoteCtrl :: ChatMonad m => Text -> RCCtrlPairing -> m RemoteCtrl
|
||||
upsertRemoteCtrl :: Text -> RCCtrlPairing -> CM RemoteCtrl
|
||||
upsertRemoteCtrl ctrlName rcCtrlPairing = withStore $ \db -> do
|
||||
rc_ <- liftIO $ getRemoteCtrlByFingerprint db (ctrlFingerprint rcCtrlPairing)
|
||||
case rc_ of
|
||||
|
|
@ -635,16 +641,16 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
|||
let dhPrivKey' = dhPrivKey rcCtrlPairing
|
||||
liftIO $ updateRemoteCtrl db rc ctrlName dhPrivKey'
|
||||
pure rc {ctrlDeviceName = ctrlName, ctrlPairing = ctrlPairing {dhPrivKey = dhPrivKey'}}
|
||||
monitor :: ChatMonad m => SessionSeq -> Async () -> m ()
|
||||
monitor :: SessionSeq -> Async () -> CM ()
|
||||
monitor sseq server = do
|
||||
res <- waitCatch server
|
||||
logInfo $ "HTTP2 server stopped: " <> tshow res
|
||||
cancelActiveRemoteCtrl $ Just (sseq, RCSRDisconnected)
|
||||
|
||||
stopRemoteCtrl :: ChatMonad m => m ()
|
||||
stopRemoteCtrl :: CM ()
|
||||
stopRemoteCtrl = cancelActiveRemoteCtrl Nothing
|
||||
|
||||
handleCtrlError :: ChatMonad m => SessionSeq -> (ChatError -> RemoteCtrlStopReason) -> Text -> m a -> m a
|
||||
handleCtrlError :: SessionSeq -> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
|
||||
handleCtrlError sseq mkReason name action =
|
||||
action `catchChatError` \e -> do
|
||||
logError $ name <> " remote ctrl error: " <> tshow e
|
||||
|
|
@ -652,7 +658,7 @@ handleCtrlError sseq mkReason name action =
|
|||
throwError e
|
||||
|
||||
-- | Stop session controller, unless session update key is present but stale
|
||||
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
|
||||
cancelActiveRemoteCtrl :: Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
|
||||
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
|
||||
var <- asks remoteCtrlSession
|
||||
session_ <-
|
||||
|
|
@ -685,18 +691,18 @@ cancelRemoteCtrl handlingError = \case
|
|||
cancelCtrlClient rcsClient
|
||||
closeConnection tls
|
||||
|
||||
deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
|
||||
deleteRemoteCtrl :: RemoteCtrlId -> CM ()
|
||||
deleteRemoteCtrl rcId = do
|
||||
checkNoRemoteCtrlSession
|
||||
-- TODO check it exists
|
||||
withStore' (`deleteRemoteCtrlRecord` rcId)
|
||||
|
||||
checkNoRemoteCtrlSession :: ChatMonad m => m ()
|
||||
checkNoRemoteCtrlSession :: CM ()
|
||||
checkNoRemoteCtrlSession =
|
||||
chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy)
|
||||
|
||||
-- | Transition controller to a new state, unless session update key is stale
|
||||
updateRemoteCtrlSession :: ChatMonad m => SessionSeq -> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession) -> m ()
|
||||
updateRemoteCtrlSession :: SessionSeq -> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession) -> CM ()
|
||||
updateRemoteCtrlSession sseq state = do
|
||||
session <- asks remoteCtrlSession
|
||||
r <- atomically $ do
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFi
|
|||
import Simplex.Messaging.Transport.Buffer (getBuffered)
|
||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
|
||||
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
|
||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
|
||||
import Simplex.Messaging.Util (liftError', liftEitherWith, liftError, tshow)
|
||||
import Simplex.RemoteControl.Client (xrcpBlockSize)
|
||||
import qualified Simplex.RemoteControl.Client as RC
|
||||
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
|
||||
|
|
@ -75,7 +75,7 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
|
|||
|
||||
-- * Client side / desktop
|
||||
|
||||
mkRemoteHostClient :: ChatMonad m => HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> m RemoteHostClient
|
||||
mkRemoteHostClient :: HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> CM RemoteHostClient
|
||||
mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {encoding, deviceName, encryptFiles} = do
|
||||
drg <- asks random
|
||||
counter <- newTVarIO 1
|
||||
|
|
@ -92,15 +92,15 @@ mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {enc
|
|||
storePath
|
||||
}
|
||||
|
||||
mkCtrlRemoteCrypto :: ChatMonad m => CtrlSessKeys -> SessionCode -> m RemoteCrypto
|
||||
mkCtrlRemoteCrypto :: CtrlSessKeys -> SessionCode -> CM RemoteCrypto
|
||||
mkCtrlRemoteCrypto CtrlSessKeys {hybridKey, idPubKey, sessPubKey} sessionCode = do
|
||||
drg <- asks random
|
||||
counter <- newTVarIO 1
|
||||
let signatures = RSVerify {idPubKey, sessPubKey}
|
||||
pure RemoteCrypto {drg, counter, sessionCode, hybridKey, signatures}
|
||||
|
||||
closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m ()
|
||||
closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient
|
||||
closeRemoteHostClient :: RemoteHostClient -> IO ()
|
||||
closeRemoteHostClient RemoteHostClient {httpClient} = closeHTTP2Client httpClient
|
||||
|
||||
-- ** Commands
|
||||
|
||||
|
|
@ -141,7 +141,7 @@ sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand
|
|||
sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do
|
||||
encFile_ <- mapM (prepareEncryptedFile encryption) file_
|
||||
req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd)
|
||||
HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
|
||||
HTTP2Response {response, respBody} <- liftError' (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
|
||||
(header, getNext) <- parseDecryptHTTP2Body encryption response respBody
|
||||
rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecode header >>= JT.parseEither J.parseJSON . convertJSON hostEncoding localEncoding
|
||||
pure (getNext, rr)
|
||||
|
|
@ -271,7 +271,7 @@ parseDecryptHTTP2Body RemoteCrypto {hybridKey, sessionCode, signatures} hr HTTP2
|
|||
where
|
||||
getSig = do
|
||||
len <- liftIO $ B.head <$> getNext 1
|
||||
liftEitherError RPEInvalidBody $ C.decodeSignature <$> getNext (fromIntegral len)
|
||||
liftError' RPEInvalidBody $ C.decodeSignature <$> getNext (fromIntegral len)
|
||||
verifySig key sig hc' = do
|
||||
let signed = BA.convert $ CH.hashFinalize hc'
|
||||
unless (C.verify' key sig signed) $ throwError $ PRERemoteControl RCECtrlAuth
|
||||
|
|
|
|||
|
|
@ -20,12 +20,11 @@ attachRevHTTP2Client disconnected = attachHTTP2Client config ANY_ADDR_V4 "0" dis
|
|||
where
|
||||
config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
|
||||
|
||||
attachHTTP2Server :: MonadUnliftIO m => TLS -> (HTTP2Request -> m ()) -> m ()
|
||||
attachHTTP2Server tls processRequest = do
|
||||
withRunInIO $ \unlift ->
|
||||
runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
|
||||
reqBody <- getHTTP2Body r doNotPrefetchHead
|
||||
unlift $ processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
|
||||
attachHTTP2Server :: TLS -> (HTTP2Request -> IO ()) -> IO ()
|
||||
attachHTTP2Server tls processRequest =
|
||||
runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
|
||||
reqBody <- getHTTP2Body r doNotPrefetchHead
|
||||
processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
|
||||
|
||||
-- | Suppress storing initial chunk in bodyHead, forcing clients and servers to stream chunks
|
||||
doNotPrefetchHead :: Int
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sen
|
|||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
|
||||
import Simplex.Messaging.Util (liftError', liftEitherWith)
|
||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||
import UnliftIO
|
||||
import UnliftIO.Directory (getFileSize)
|
||||
|
|
@ -37,11 +37,11 @@ receiveEncryptedFile :: RemoteCrypto -> (Int -> IO ByteString) -> Word32 -> File
|
|||
receiveEncryptedFile RemoteCrypto {hybridKey} getChunk fileSize fileDigest toPath = do
|
||||
c <- liftIO $ getChunk 1
|
||||
unless (c == "\x01") $ throwError RPENoFile
|
||||
nonce <- liftEitherError RPEInvalidBody $ smpDecode <$> getChunk 24
|
||||
size <- liftEitherError RPEInvalidBody $ smpDecode <$> getChunk 4
|
||||
nonce <- liftError' RPEInvalidBody $ smpDecode <$> getChunk 24
|
||||
size <- liftError' RPEInvalidBody $ smpDecode <$> getChunk 4
|
||||
unless (size == fileSize + fromIntegral C.authTagSize) $ throwError RPEFileSize
|
||||
sbState <- liftEitherWith (const $ PRERemoteControl RCEDecrypt) $ LC.kcbInit hybridKey nonce
|
||||
liftEitherError fErr $ withFile toPath WriteMode $ \h -> receiveSbFile getChunk h sbState fileSize
|
||||
liftError' fErr $ withFile toPath WriteMode $ \h -> receiveSbFile getChunk h sbState fileSize
|
||||
digest <- liftIO $ LC.sha512Hash <$> LB.readFile toPath
|
||||
unless (FileDigest digest == fileDigest) $ throwError RPEFileDigest
|
||||
where
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Chat.Util (week, encryptFile, chunkSize, shuffle) where
|
||||
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
|
|
@ -42,3 +42,7 @@ shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) x
|
|||
where
|
||||
random :: IO Word16
|
||||
random = randomRIO (0, 65535)
|
||||
|
||||
liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
|
||||
liftIOEither a = liftIO a >>= liftEither
|
||||
{-# INLINE liftIOEither #-}
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ testOpts =
|
|||
testCoreOpts :: CoreChatOpts
|
||||
testCoreOpts =
|
||||
CoreChatOpts
|
||||
{ dbFilePrefix = undefined,
|
||||
{ dbFilePrefix = "./simplex_v1",
|
||||
dbKey = "",
|
||||
-- dbKey = "this is a pass-phrase to encrypt the database",
|
||||
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue