blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Plug discovery into remote controller UI

Browse Source
This commit is contained in:
IC Rainbow
2023-09-27 18:24:38 +03:00
parent 77410e5d5e
commit cccb3e33fb
8 changed files with 167 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Remote.hs
+37 -27
View File
@@ -10,9 +10,9 @@ module Simplex.Chat.Remote where
import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Data.Aeson as J
import qualified Data.Binary.Builder as Binary
import Data.ByteString.Char8 (ByteString)
import qualified Data.Map.Strict as M
import qualified Data.Binary.Builder as Binary
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP2.Client as HTTP2Client
import Simplex.Chat.Controller
@@ -20,43 +20,44 @@ import Simplex.Chat.Remote.Types
import Simplex.Chat.Types
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
import Simplex.Messaging.Util (bshow)
import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
import Simplex.Messaging.Util (bshow)
import System.Directory (getFileSize)
withRemoteHostSession :: ChatMonad m => RemoteHostId -> (RemoteHostSession -> m a) -> m a
withRemoteHostSession :: (ChatMonad m) => RemoteHostId -> (RemoteHostSession -> m a) -> m a
withRemoteHostSession remoteHostId action = do
chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId
where
err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing
closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ()
closeRemoteHostSession rh = withRemoteHostSession rh (liftIO . HTTP2.closeHTTP2Client . ctrlClient)
processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
processRemoteCommand :: (ChatMonad m) => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
processRemoteCommand rhs = \case
-- XXX: intercept and filter some commands
-- TODO: store missing files on remote host
(s, _cmd) -> relayCommand rhs s
relayCommand :: ChatMonad m => RemoteHostSession -> ByteString -> m ChatResponse
relayCommand RemoteHostSession {ctrlClient} s = postBytestring Nothing ctrlClient "/relay" mempty s >>= \case
Left e -> error "TODO: http2chatError"
Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
remoteChatResponse <-
if iTax then
case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
Left e -> error "TODO: json2chatError" e
Right (raw :: J.Value) -> case J.fromJSON (sum2tagged raw) of
J.Error e -> error "TODO: json2chatError" e
J.Success cr -> pure cr
else
case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
Left e -> error "TODO: json2chatError" e
Right cr -> pure cr
case remoteChatResponse of
-- TODO: intercept file responses and fetch files when needed
-- XXX: is that even possible, to have a file response to a command?
_ -> pure remoteChatResponse
relayCommand :: (ChatMonad m) => RemoteHostSession -> ByteString -> m ChatResponse
relayCommand RemoteHostSession {ctrlClient} s =
postBytestring Nothing ctrlClient "/relay" mempty s >>= \case
Left e -> error "TODO: http2chatError"
Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
remoteChatResponse <-
if iTax
then case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
Left e -> error "TODO: json2chatError" e
Right (raw :: J.Value) -> case J.fromJSON (sum2tagged raw) of
J.Error e -> error "TODO: json2chatError" e
J.Success cr -> pure cr
else case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
Left e -> error "TODO: json2chatError" e
Right cr -> pure cr
case remoteChatResponse of
-- TODO: intercept file responses and fetch files when needed
-- XXX: is that even possible, to have a file response to a command?
_ -> pure remoteChatResponse
where
iTax = True -- TODO: get from RemoteHost
-- XXX: extract to http2 transport
@@ -64,11 +65,11 @@ relayCommand RemoteHostSession {ctrlClient} s = postBytestring Nothing ctrlClien
where
req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body)
storeRemoteFile :: ChatMonad m => RemoteHostSession -> FilePath -> m ChatResponse
storeRemoteFile :: (ChatMonad m) => RemoteHostSession -> FilePath -> m ChatResponse
storeRemoteFile RemoteHostSession {ctrlClient} localFile = do
postFile Nothing ctrlClient "/store" mempty localFile >>= \case
Left e -> error "TODO: http2chatError"
Right HTTP2.HTTP2Response { response } -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of
Right HTTP2.HTTP2Response {response} -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of
Just 200 -> pure $ CRCmdOk Nothing
unexpected -> error "TODO: http2chatError"
where
@@ -78,7 +79,7 @@ storeRemoteFile RemoteHostSession {ctrlClient} localFile = do
where
req size = HTTP2Client.requestFile "POST" path hs (HTTP2Client.FileSpec file 0 size)
fetchRemoteFile :: ChatMonad m => RemoteHostSession -> FileTransferId -> m ChatResponse
fetchRemoteFile :: (ChatMonad m) => RemoteHostSession -> FileTransferId -> m ChatResponse
fetchRemoteFile RemoteHostSession {ctrlClient, storePath} remoteFileId = do
liftIO (HTTP2.sendRequest ctrlClient req Nothing) >>= \case
Left e -> error "TODO: http2chatError"
@@ -93,3 +94,12 @@ sum2tagged :: J.Value -> J.Value
sum2tagged = \case
J.Object todo'convert -> J.Object todo'convert
skip -> skip
-- withRemoteCtrlSession :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrlSession -> m a) -> m a
-- withRemoteCtrlSession remoteCtrlId action = do
-- chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteCtrlId
-- where
-- err = throwError $ ChatErrorRemoteCtrl (Just remoteCtrlId) RCMissing
processControllerCommand :: (ChatMonad m) => RemoteCtrlId -> HTTP2.HTTP2Request -> m ()
processControllerCommand rc req = error "TODO: processControllerCommand"