IntenseFinance/simplex-chat
3
0 Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

remote: refactor (WIP) (#3222)

Browse Source 
* remote: refactor (WIP)

* refactor discoverRemoteCtrls

* refactor processRemoteCommand, storeRemoteFile

* refactor fetchRemoteFile

* refactor startRemoteHost, receiving files

* refactor relayCommand
This commit is contained in:
Evgeny Poberezkin authored and GitHub committed 2023-10-15 14:17:36 +01:00
1 parent 41b86e07f1
commit fc1bba8817
9 files changed
+274 -254
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

apps/ios/SimpleXChat/APITypes.swift
-1
View File
@@ -1804,7 +1804,6 @@ public enum ArchiveError: Decodable {
} }
public enum RemoteCtrlError: Decodable { public enum RemoteCtrlError: Decodable {
case missing(remoteCtrlId: Int64)
case inactive case inactive
case busy case busy
case timeout case timeout
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt
-2
View File
@@ -4521,7 +4521,6 @@ sealed class RemoteHostError {
@Serializable @Serializable
sealed class RemoteCtrlError { sealed class RemoteCtrlError {
val string: String get() = when (this) { val string: String get() = when (this) {
is Missing -> "missing"
is Inactive -> "inactive" is Inactive -> "inactive"
is Busy -> "busy" is Busy -> "busy"
is Timeout -> "timeout" is Timeout -> "timeout"
@@ -4531,7 +4530,6 @@ sealed class RemoteCtrlError {
is CertificateUntrusted -> "certificateUntrusted" is CertificateUntrusted -> "certificateUntrusted"
is BadFingerprint -> "badFingerprint" is BadFingerprint -> "badFingerprint"
} }
@Serializable @SerialName("missing") class Missing(val remoteCtrlId: Long): RemoteCtrlError()
@Serializable @SerialName("inactive") object Inactive: RemoteCtrlError() @Serializable @SerialName("inactive") object Inactive: RemoteCtrlError()
@Serializable @SerialName("busy") object Busy: RemoteCtrlError() @Serializable @SerialName("busy") object Busy: RemoteCtrlError()
@Serializable @SerialName("timeout") object Timeout: RemoteCtrlError() @Serializable @SerialName("timeout") object Timeout: RemoteCtrlError()
src/Simplex/Chat.hs
+1 -4
View File
@@ -397,7 +397,7 @@ execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd) execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse
execRemoteCommand u rh scmd = either (CRChatCmdError u) id <$> runExceptT (withRemoteHostSession rh $ \rhs -> processRemoteCommand rhs scmd) execRemoteCommand u rhId scmd = either (CRChatCmdError u) id <$> runExceptT (getRemoteHostSession rhId >>= (`processRemoteCommand` scmd))
parseChatCommand :: ByteString -> Either String ChatCommand parseChatCommand :: ByteString -> Either String ChatCommand
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
@@ -5154,9 +5154,6 @@ closeFileHandle fileId files = do
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
liftIO $ mapM_ hClose h_ `catchAll_` pure () liftIO $ mapM_ hClose h_ `catchAll_` pure ()
throwChatError :: ChatMonad m => ChatErrorType -> m a
throwChatError = throwError . ChatError
deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m () deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m ()
deleteMembersConnections user members = do deleteMembersConnections user members = do
let memberConns = let memberConns =
src/Simplex/Chat/Controller.hs
+12 -3
View File
@@ -1158,8 +1158,7 @@ instance ToJSON RemoteHostError where
-- TODO review errors, some of it can be covered by HTTP2 errors -- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteCtrlError data RemoteCtrlError
= RCEMissing {remoteCtrlId :: RemoteCtrlId} -- ^ No remote session matches this identifier = RCEInactive -- ^ No session is running
| RCEInactive -- ^ No session is running
| RCEBusy -- ^ A session is already running | RCEBusy -- ^ A session is already running
| RCETimeout -- ^ Remote operation timed out | RCETimeout -- ^ Remote operation timed out
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
@@ -1167,6 +1166,9 @@ data RemoteCtrlError
| RCECertificateExpired {remoteCtrlId :: RemoteCtrlId} -- ^ A connection or CA certificate in a chain have bad validity period | RCECertificateExpired {remoteCtrlId :: RemoteCtrlId} -- ^ A connection or CA certificate in a chain have bad validity period
| RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection | RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection
| RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB
| RCEHTTP2Error {http2Error :: String}
| RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove
| RCEInvalidResponse {responseError :: String}
deriving (Show, Exception, Generic) deriving (Show, Exception, Generic)
instance FromJSON RemoteCtrlError where instance FromJSON RemoteCtrlError where
@@ -1199,7 +1201,7 @@ data RemoteHostSession
} }
data RemoteCtrlSession = RemoteCtrlSession data RemoteCtrlSession = RemoteCtrlSession
{ -- | Server side of transport to process remote commands and forward notifications { -- | Host (mobile) side of transport to process remote commands and forward notifications
discoverer :: Async (), discoverer :: Async (),
supervisor :: Async (), supervisor :: Async (),
hostServer :: Maybe (Async ()), hostServer :: Maybe (Async ()),
@@ -1239,6 +1241,10 @@ chatFinally :: ChatMonad m => m a -> m b -> m a
chatFinally = allFinally mkChatError chatFinally = allFinally mkChatError
{-# INLINE chatFinally #-} {-# INLINE chatFinally #-}
onChatError :: ChatMonad m => m a -> m b -> m a
a `onChatError` onErr = a `catchChatError` \e -> onErr >> throwError e
{-# INLINE onChatError #-}
mkChatError :: SomeException -> ChatError mkChatError :: SomeException -> ChatError
mkChatError = ChatError . CEException . show mkChatError = ChatError . CEException . show
{-# INLINE mkChatError #-} {-# INLINE mkChatError #-}
@@ -1246,6 +1252,9 @@ mkChatError = ChatError . CEException . show
chatCmdError :: Maybe User -> String -> ChatResponse chatCmdError :: Maybe User -> String -> ChatResponse
chatCmdError user = CRChatCmdError user . ChatError . CECommandError chatCmdError user = CRChatCmdError user . ChatError . CECommandError
throwChatError :: ChatMonad m => ChatErrorType -> m a
throwChatError = throwError . ChatError
-- | Emit local events. -- | Emit local events.
toView :: ChatMonad' m => ChatResponse -> m () toView :: ChatMonad' m => ChatResponse -> m ()
toView event = do toView event = do
src/Simplex/Chat/Remote.hs
+245 -234
View File
@@ -38,8 +38,8 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Types.Status as Status import qualified Network.HTTP.Types.Status as Status
import qualified Network.HTTP2.Client as HTTP2Client import qualified Network.HTTP2.Client as HC
import qualified Network.HTTP2.Server as HTTP2Server import qualified Network.HTTP2.Server as HS
import Network.Socket (SockAddr (..), hostAddressToTuple) import Network.Socket (SockAddr (..), hostAddressToTuple)
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Messages (AChatItem (..), CIFile (..), CIFileStatus (..), ChatItem (..), chatNameStr) import Simplex.Chat.Messages (AChatItem (..), CIFile (..), CIFileStatus (..), ChatItem (..), chatNameStr)
@@ -60,103 +60,100 @@ import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), defaultHTTP2BufferSize) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), defaultHTTP2BufferSize)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, HTTP2Response (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2 import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2 import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
import Simplex.Messaging.Util (bshow, ifM, tshow, ($>>=)) import Simplex.Messaging.Util (bshow, ifM, liftEitherError, liftEitherWith, tshow, ($>>=))
import System.FilePath (isPathSeparator, takeFileName, (</>)) import System.FilePath (isPathSeparator, takeFileName, (</>))
import UnliftIO import UnliftIO
import UnliftIO.Directory (createDirectoryIfMissing, getFileSize) import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
withRemoteHostSession :: (ChatMonad m) => RemoteHostId -> (RemoteHostSession -> m a) -> m a getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession
withRemoteHostSession remoteHostId action = do getRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe err pure . M.lookup rhId
chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId
where where
err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing err = throwError $ ChatErrorRemoteHost rhId RHMissing
withRemoteHost :: (ChatMonad m) => RemoteHostId -> (RemoteHost -> m a) -> m a checkNoRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
withRemoteHost remoteHostId action = checkNoRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe (pure ()) err . M.lookup rhId
withStore' (`getRemoteHost` remoteHostId) >>= \case where
Nothing -> throwError $ ChatErrorRemoteHost remoteHostId RHMissing err _ = throwError $ ChatErrorRemoteHost rhId RHBusy
Just rh -> action rh
startRemoteHost :: (ChatMonad m) => RemoteHostId -> m () startRemoteHost :: ChatMonad m => RemoteHostId -> m ()
startRemoteHost remoteHostId = do startRemoteHost rhId = do
asks remoteHostSessions >>= atomically . TM.lookup remoteHostId >>= \case checkNoRemoteHostSession rhId
Just _ -> throwError $ ChatErrorRemoteHost remoteHostId RHBusy rh <- withStore (`getRemoteHost` rhId)
Nothing -> withRemoteHost remoteHostId $ \rh -> do announcer <- async $ do
announcer <- async $ run rh finished <- newTVarIO False
chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarting {announcer} http <- start rh finished `onChatError` cleanup finished
run rh finished http
chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarting {announcer}
where where
cleanup finished = do cleanup finished = do
logInfo "Remote host http2 client fininshed" logInfo "Remote host http2 client fininshed"
atomically $ writeTVar finished True atomically $ writeTVar finished True
M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case -- TODO why this is not an error?
Nothing -> logInfo $ "Session already closed for remote host " <> tshow remoteHostId M.lookup rhId <$> chatReadVar remoteHostSessions >>= \case
Just _ -> closeRemoteHostSession remoteHostId >> toView (CRRemoteHostStopped remoteHostId) Nothing -> logInfo $ "Session already closed for remote host " <> tshow rhId
run rh@RemoteHost {storePath, caKey, caCert} = do Just _ -> closeRemoteHostSession rhId >> toView (CRRemoteHostStopped rhId)
finished <- newTVarIO False start rh@RemoteHost {storePath, caKey, caCert} finished = do
let parent = (C.signatureKeyPair caKey, caCert) let parent = (C.signatureKeyPair caKey, caCert)
sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session" sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent] let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent]
Discovery.announceRevHTTP2 (cleanup finished) fingerprint credentials >>= \case u <- askUnliftIO
Left h2ce -> do ctrlClient <- liftHTTP2 $ Discovery.announceRevHTTP2 fingerprint credentials $ unliftIO u (cleanup finished) -- >>= \case
logError $ "Failed to set up remote host connection: " <> tshow h2ce chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarted {storePath, ctrlClient}
cleanup finished chatWriteVar currentRemoteHost $ Just rhId
Right ctrlClient -> do HTTP2Response {respBody = HTTP2Body {bodyHead}} <- sendHello ctrlClient
chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient} rcName <- chatReadVar localDeviceName
chatWriteVar currentRemoteHost $ Just remoteHostId -- TODO what sets session active?
sendHello ctrlClient >>= \case toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
Left h2ce -> do pure ctrlClient
logError $ "Failed to send initial remote host request: " <> tshow h2ce run RemoteHost {storePath} finished ctrlClient = do
cleanup finished oq <- asks outputQ
Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just rhId,)
logDebug $ "Got initial from remote host: " <> tshow bodyHead -- TODO remove REST
oq <- asks outputQ void . async $ pollRemote finished ctrlClient "/recv" $ handleFile >=> toViewRemote
let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just remoteHostId,) where
void . async $ pollRemote finished ctrlClient "/recv" $ \chatResponse -> do -- TODO move to view / terminal
case chatResponse of handleFile = \case
CRRcvFileComplete {user = ru, chatItem = AChatItem c d@SMDRcv i ci@ChatItem {file = Just ciFile}} -> do cr@CRRcvFileComplete {user, chatItem = AChatItem c SMDRcv i ci@ChatItem {file = Just ciFile@CIFile {fileStatus = CIFSRcvComplete}}} -> do
handleRcvFileComplete ctrlClient storePath ru ciFile >>= \case maybe cr update <$> handleRcvFileComplete ctrlClient storePath user ciFile
Nothing -> toViewRemote chatResponse where
Just localFile -> toViewRemote CRRcvFileComplete {user = ru, chatItem = AChatItem c d i ci {file = Just localFile}} update localFile = cr {chatItem = AChatItem c SMDRcv i ci {file = Just localFile}}
_ -> toViewRemote chatResponse cr -> pure cr
rcName <- chatReadVar localDeviceName
-- TODO what sets session active?
toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
sendHello :: (ChatMonad m) => HTTP2Client -> m (Either HTTP2.HTTP2ClientError HTTP2.HTTP2Response) sendHello :: ChatMonad m => HTTP2Client -> m HTTP2Response
sendHello http = liftIO (HTTP2.sendRequestDirect http req Nothing) sendHello http = liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
where where
req = HTTP2Client.requestNoBody "GET" "/" mempty req = HC.requestNoBody "GET" "/" mempty
pollRemote :: (ChatMonad m, J.FromJSON a) => TVar Bool -> HTTP2Client -> ByteString -> (a -> m ()) -> m () -- TODO how (on what condition) it would stop polling?
pollRemote finished http path action = loop -- TODO add JSON translation
pollRemote :: ChatMonad m => TVar Bool -> HTTP2Client -> ByteString -> (ChatResponse -> m ()) -> m ()
pollRemote finished http path action = loop `catchChatError` \e -> action (CRChatError Nothing e) >> loop
where where
loop = do loop = do
liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case -- TODO this will never load full body
Left e -> logError $ "pollRemote: " <> tshow (path, e) HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead -- of
logDebug $ "Got /recv response: " <> decodeUtf8 bodyHead action json
case J.eitherDecodeStrict' bodyHead of
Left e -> logError $ "pollRemote/decode: " <> tshow (path, e)
Right o -> action o
readTVarIO finished >>= (`unless` loop) readTVarIO finished >>= (`unless` loop)
req = HTTP2Client.requestNoBody "GET" path mempty req = HC.requestNoBody "GET" path mempty
closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m () closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do closeRemoteHostSession remoteHostId = do
session <- getRemoteHostSession remoteHostId
logInfo $ "Closing remote host session for " <> tshow remoteHostId logInfo $ "Closing remote host session for " <> tshow remoteHostId
liftIO $ cancelRemoteHostSession session liftIO $ cancelRemoteHostSession session
chatWriteVar currentRemoteHost Nothing chatWriteVar currentRemoteHost Nothing
chatModifyVar remoteHostSessions $ M.delete remoteHostId chatModifyVar remoteHostSessions $ M.delete remoteHostId
cancelRemoteHostSession :: (MonadUnliftIO m) => RemoteHostSession -> m () cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m ()
cancelRemoteHostSession = \case cancelRemoteHostSession = \case
RemoteHostSessionStarting {announcer} -> cancel announcer RemoteHostSessionStarting {announcer} -> cancel announcer
RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient
createRemoteHost :: (ChatMonad m) => m RemoteHostInfo createRemoteHost :: ChatMonad m => m RemoteHostInfo
createRemoteHost = do createRemoteHost = do
let rhName = "TODO" -- you don't have remote host name here, it will be passed from remote host let rhName = "TODO" -- you don't have remote host name here, it will be passed from remote host
((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) rhName ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) rhName
@@ -170,7 +167,7 @@ createRemoteHost = do
randomStorePath :: IO FilePath randomStorePath :: IO FilePath
randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12 randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
listRemoteHosts :: (ChatMonad m) => m [RemoteHostInfo] listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
listRemoteHosts = do listRemoteHosts = do
active <- chatReadVar remoteHostSessions active <- chatReadVar remoteHostSessions
rcName <- chatReadVar localDeviceName rcName <- chatReadVar localDeviceName
@@ -184,75 +181,72 @@ remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} session
let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName} let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive} in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}
deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m () deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do deleteRemoteHost rhId = do
RemoteHost {storePath} <- withStore (`getRemoteHost` rhId)
chatReadVar filesFolder >>= \case chatReadVar filesFolder >>= \case
Just baseDir -> do Just baseDir -> do
let hostStore = baseDir </> storePath let hostStore = baseDir </> storePath
logError $ "TODO: remove " <> tshow hostStore logError $ "TODO: remove " <> tshow hostStore
Nothing -> logWarn "Local file store not available while deleting remote host" Nothing -> logWarn "Local file store not available while deleting remote host"
withStore' $ \db -> deleteRemoteHostRecord db remoteHostId withStore' (`deleteRemoteHostRecord` rhId)
processRemoteCommand :: (ChatMonad m) => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
processRemoteCommand RemoteHostSessionStarting {} _ = pure . CRChatError Nothing . ChatError $ CEInternalError "sending remote commands before session started" processRemoteCommand RemoteHostSessionStarting {} _ = pure $ chatCmdError Nothing "remote command sent before session started"
processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = do processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) =
logDebug $ "processRemoteCommand: " <> tshow (s, cmd) uploadFile cmd >>= relayCommand ctrlClient
case cmd of
SendFile cn ctrlPath -> do
storeRemoteFile ctrlClient ctrlPath >>= \case
-- TODO: use Left
Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store file on remote host"
Just hostPath -> relayCommand ctrlClient $ "/file " <> utf8String (chatNameStr cn) <> " " <> utf8String hostPath
SendImage cn ctrlPath -> do
storeRemoteFile ctrlClient ctrlPath >>= \case
Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store image on remote host"
Just hostPath -> relayCommand ctrlClient $ "/image " <> utf8String (chatNameStr cn) <> " " <> utf8String hostPath
APISendMessage {composedMessage = cm@ComposedMessage {fileSource = Just CryptoFile {filePath = ctrlPath, cryptoArgs}}} -> do
storeRemoteFile ctrlClient ctrlPath >>= \case
Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store file on remote host"
Just hostPath -> do
let cm' = cm {fileSource = Just CryptoFile {filePath = hostPath, cryptoArgs}} :: ComposedMessage
relayCommand ctrlClient $ B.takeWhile (/= '{') s <> B.toStrict (J.encode cm')
_ -> relayCommand ctrlClient s
relayCommand :: (ChatMonad m) => HTTP2Client -> ByteString -> m ChatResponse
relayCommand http s =
postBytestring Nothing http "/send" mempty s >>= \case
Left e -> err $ "relayCommand/post: " <> show e
Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
logDebug $ "Got /send response: " <> decodeUtf8 bodyHead
remoteChatResponse <- case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
Left e -> err $ "relayCommand/decodeValue: " <> show e
Right json -> case J.fromJSON $ toTaggedJSON json of
J.Error e -> err $ "relayCommand/fromJSON: " <> show e
J.Success 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 where
err = pure . CRChatError Nothing . ChatError . CEInternalError fileCmd cmdPfx cn hostPath = utf8String $ unwords [cmdPfx, chatNameStr cn, hostPath]
uploadFile = \case
SendFile cn ctrlPath -> fileCmd "/file" cn <$> storeRemoteFile ctrlClient ctrlPath
SendImage cn ctrlPath -> fileCmd "/image" cn <$> storeRemoteFile ctrlClient ctrlPath
-- TODO APISendMessage should only be used with host path already, and UI has to upload file first.
-- The problem is that we cannot have different file names in host and controller, because it simply won't be able to show files.
-- So we need to ask the host to store files BEFORE storing them in the app storage and use host names in the command and to store the file locally if it has to be shown,
-- or don't even store it if it's not image/video.
-- The current approach won't work.
-- It also does not account for local file encryption.
-- Also, local file encryption setting should be tracked in the controller, as otherwise host won't be able to decide what to do having received the upload command.
APISendMessage {composedMessage = cm@ComposedMessage {fileSource = Just CryptoFile {filePath = ctrlPath, cryptoArgs}}} -> do
hostPath <- storeRemoteFile ctrlClient ctrlPath
let cm' = cm {fileSource = Just CryptoFile {filePath = hostPath, cryptoArgs}} :: ComposedMessage
-- TODO we shouldn't manipulate JSON like that
pure $ B.takeWhile (/= '{') s <> B.toStrict (J.encode cm')
_ -> pure s
relayCommand :: ChatMonad m => HTTP2Client -> ByteString -> m ChatResponse
relayCommand http s = do
-- TODO ExceptT
let timeout' = Nothing
HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
liftHTTP2 $ HTTP2.sendRequestDirect http req timeout'
-- TODO: large JSONs can overflow into buffered chunks
json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead
case J.fromJSON $ toTaggedJSON json of
J.Error e -> err $ show e
J.Success cr -> pure cr
where
err = pure . CRChatError Nothing . ChatErrorRemoteCtrl . RCEInvalidResponse
toTaggedJSON :: J.Value -> J.Value toTaggedJSON :: J.Value -> J.Value
toTaggedJSON = id -- owsf2tagged TODO: get from RemoteHost toTaggedJSON = id -- owsf2tagged TODO: get from RemoteHost
-- XXX: extract to http2 transport req = HC.requestBuilder "POST" "/send" mempty (Binary.fromByteString s)
postBytestring timeout' c path hs body = liftIO $ HTTP2.sendRequestDirect c req timeout'
where
req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body)
handleRcvFileComplete :: (ChatMonad m) => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv)) -- TODO fileName is just metadata that does not determine the actual file location for UI, or whether it is encrypted or not
handleRcvFileComplete http storePath remoteUser cif@CIFile {fileId, fileName, fileStatus} = case fileStatus of -- fileSource is the actual file location (with information whether it is locally encrypted)
CIFSRcvComplete -> handleRcvFileComplete :: ChatMonad m => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv))
chatReadVar filesFolder >>= \case handleRcvFileComplete http storePath remoteUser f@CIFile {fileId, fileName} =
Just baseDir -> do chatReadVar filesFolder >>= \case
let hostStore = baseDir </> storePath Just baseDir -> do
createDirectoryIfMissing True hostStore let hostStore = baseDir </> storePath
localPath <- uniqueCombine hostStore fileName createDirectoryIfMissing True hostStore
ok <- fetchRemoteFile http remoteUser fileId localPath -- TODO the problem here is that the name may turn out to be different and nothing will work
if ok -- file processing seems to work "accidentally", not "by design"
then pure $ Just (cif {fileName = localPath} :: CIFile 'MDRcv) localPath <- uniqueCombine hostStore fileName
else Nothing <$ logError "fetchRemoteFile failed" fetchRemoteFile http remoteUser fileId localPath
Nothing -> Nothing <$ logError "Local file store not available while fetching remote file" pure $ Just (f {fileName = localPath} :: CIFile 'MDRcv)
_ -> Nothing <$ logDebug ("Ingoring invalid file notification for file (" <> tshow fileId <> ") " <> tshow fileName) -- TODO below will not work with CLI, it should store file to download folder when not specified
-- It should not load all files when received, instead it should only load files received with /fr commands
Nothing -> Nothing <$ logError "Local file store not available while fetching remote file"
-- | Convert swift single-field sum encoding into tagged/discriminator-field -- | Convert swift single-field sum encoding into tagged/discriminator-field
owsf2tagged :: J.Value -> J.Value owsf2tagged :: J.Value -> J.Value
@@ -288,36 +282,42 @@ owsf2tagged = fst . convert
pattern OwsfTag :: (JK.Key, J.Value) pattern OwsfTag :: (JK.Key, J.Value)
pattern OwsfTag = (SingleFieldJSONTag, J.Bool True) pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
storeRemoteFile :: (MonadUnliftIO m) => HTTP2Client -> FilePath -> m (Maybe FilePath) storeRemoteFile :: ChatMonad m => HTTP2Client -> FilePath -> m FilePath
storeRemoteFile http localFile = do storeRemoteFile http localFile = do
putFile Nothing http uri mempty localFile >>= \case fileSize <- liftIO $ fromIntegral <$> getFileSize localFile
Left h2ce -> Nothing <$ logError (tshow h2ce) -- TODO configure timeout
Right HTTP2.HTTP2Response {response, respBody = HTTP2Body {bodyHead}} -> let timeout' = Nothing
case HTTP.statusCode <$> HTTP2Client.responseStatus response of r@HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
Just 200 -> pure . Just $ B.unpack bodyHead liftHTTP2 $ HTTP2.sendRequestDirect http (req fileSize) timeout'
notOk -> Nothing <$ logError ("Bad response status: " <> tshow notOk) responseStatusOK r
-- TODO what if response doesn't fit in the head?
-- it'll be solved when processing moved to POST with Command/Response types
pure $ B.unpack bodyHead
where where
-- TODO local file encryption?
uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)] uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)]
putFile timeout' c path hs file = liftIO $ do req size = HC.requestFile "PUT" uri mempty (HC.FileSpec localFile 0 size)
fileSize <- fromIntegral <$> getFileSize file
HTTP2.sendRequestDirect c (req fileSize) timeout'
where
req size = HTTP2Client.requestFile "PUT" path hs (HTTP2Client.FileSpec file 0 size)
fetchRemoteFile :: (MonadUnliftIO m) => HTTP2Client -> User -> Int64 -> FilePath -> m Bool liftHTTP2 :: ChatMonad m => IO (Either HTTP2ClientError a) -> m a
liftHTTP2 = liftEitherError $ ChatErrorRemoteCtrl . RCEHTTP2Error . show
responseStatusOK :: ChatMonad m => HTTP2Response -> m ()
responseStatusOK HTTP2Response {response} = do
let s = HC.responseStatus response
unless (s == Just Status.ok200) $
throwError $ ChatErrorRemoteCtrl $ RCEHTTP2RespStatus $ Status.statusCode <$> s
fetchRemoteFile :: ChatMonad m => HTTP2Client -> User -> Int64 -> FilePath -> m ()
fetchRemoteFile http User {userId = remoteUserId} remoteFileId localPath = do fetchRemoteFile http User {userId = remoteUserId} remoteFileId localPath = do
liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case r@HTTP2Response {respBody} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
Left h2ce -> False <$ logError (tshow h2ce) responseStatusOK r
Right HTTP2.HTTP2Response {response, respBody} -> writeBodyToFile localPath respBody
if HTTP2Client.responseStatus response == Just Status.ok200
then True <$ writeBodyToFile localPath respBody
else False <$ (logError $ "Request failed: " <> maybe "(??)" tshow (HTTP2Client.responseStatus response) <> " " <> decodeUtf8 (bodyHead respBody))
where where
req = HTTP2Client.requestNoBody "GET" path mempty req = HC.requestNoBody "GET" path mempty
path = "/fetch?" <> HTTP.renderSimpleQuery False [("user_id", bshow remoteUserId), ("file_id", bshow remoteFileId)] path = "/fetch?" <> HTTP.renderSimpleQuery False [("user_id", bshow remoteUserId), ("file_id", bshow remoteFileId)]
-- XXX: extract to Transport.HTTP2 ? -- XXX: extract to Transport.HTTP2 ?
writeBodyToFile :: (MonadUnliftIO m) => FilePath -> HTTP2Body -> m () writeBodyToFile :: MonadUnliftIO m => FilePath -> HTTP2Body -> m ()
writeBodyToFile path HTTP2Body {bodyHead, bodySize, bodyPart} = do writeBodyToFile path HTTP2Body {bodyHead, bodySize, bodyPart} = do
logInfo $ "Receiving " <> tshow bodySize <> " bytes to " <> tshow path logInfo $ "Receiving " <> tshow bodySize <> " bytes to " <> tshow path
liftIO . withFile path WriteMode $ \h -> do liftIO . withFile path WriteMode $ \h -> do
@@ -331,7 +331,8 @@ hPutBodyChunks h getChunk = do
hPut h chunk hPut h chunk
hPutBodyChunks h getChunk hPutBodyChunks h getChunk
processControllerRequest :: forall m. (ChatMonad m) => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m () -- TODO command/response pattern, remove REST conventions
processControllerRequest :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m ()
processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, sendResponse} = do processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, sendResponse} = do
logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) logDebug $ "Remote controller request: " <> tshow (method <> " " <> path)
res <- tryChatError $ case (method, ps) of res <- tryChatError $ case (method, ps) of
@@ -345,8 +346,8 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
Left e -> logError $ "Error handling remote controller request: (" <> tshow (method <> " " <> path) <> "): " <> tshow e Left e -> logError $ "Error handling remote controller request: (" <> tshow (method <> " " <> path) <> "): " <> tshow e
Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK" Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK"
where where
method = fromMaybe "" $ HTTP2Server.requestMethod request method = fromMaybe "" $ HS.requestMethod request
path = fromMaybe "/" $ HTTP2Server.requestPath request path = fromMaybe "/" $ HS.requestPath request
(ps, query) = HTTP.decodePath path (ps, query) = HTTP.decodePath path
getHello = respond "OK" getHello = respond "OK"
sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON
@@ -354,6 +355,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
chatReadVar remoteCtrlSession >>= \case chatReadVar remoteCtrlSession >>= \case
Nothing -> respondWith Status.internalServerError500 "session not active" Nothing -> respondWith Status.internalServerError500 "session not active"
Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON
-- TODO liftEither storeFileQuery
storeFile = case storeFileQuery of storeFile = case storeFileQuery of
Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err) Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
Right fileName -> do Right fileName -> do
@@ -365,6 +367,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
respond $ Binary.putStringUtf8 storeRelative respond $ Binary.putStringUtf8 storeRelative
where where
storeFileQuery = parseField "file_name" $ A.many1 (A.satisfy $ not . isPathSeparator) storeFileQuery = parseField "file_name" $ A.many1 (A.satisfy $ not . isPathSeparator)
-- TODO move to ExceptT monad, catch errors in one place, convert errors to responses
fetchFile = case fetchFileQuery of fetchFile = case fetchFileQuery of
Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err) Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
Right (userId, fileId) -> do Right (userId, fileId) -> do
@@ -372,12 +375,13 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
x <- withStore' $ \db -> runExceptT $ do x <- withStore' $ \db -> runExceptT $ do
user <- getUser db userId user <- getUser db userId
getRcvFileTransfer db user fileId getRcvFileTransfer db user fileId
-- TODO this error handling is very ad-hoc, there is no separation between Chat errors and responses
case x of case x of
Right RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> do Right RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> do
baseDir <- fromMaybe "." <$> chatReadVar filesFolder baseDir <- fromMaybe "." <$> chatReadVar filesFolder
let fullPath = baseDir </> filePath let fullPath = baseDir </> filePath
size <- fromInteger <$> getFileSize fullPath size <- fromInteger <$> getFileSize fullPath
liftIO . sendResponse . HTTP2Server.responseFile Status.ok200 mempty $ HTTP2Server.FileSpec fullPath 0 size liftIO . sendResponse . HS.responseFile Status.ok200 mempty $ HS.FileSpec fullPath 0 size
Right _ -> respondWith Status.internalServerError500 "The requested file is not complete" Right _ -> respondWith Status.internalServerError500 "The requested file is not complete"
Left SEUserNotFound {} -> respondWith Status.notFound404 "User not found" Left SEUserNotFound {} -> respondWith Status.notFound404 "User not found"
Left SERcvFileNotFound {} -> respondWith Status.notFound404 "File not found" Left SERcvFileNotFound {} -> respondWith Status.notFound404 "File not found"
@@ -395,101 +399,106 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
respondJSON = respond . Binary.fromLazyByteString . J.encode respondJSON = respond . Binary.fromLazyByteString . J.encode
respond = respondWith Status.ok200 respond = respondWith Status.ok200
respondWith status = liftIO . sendResponse . HTTP2Server.responseBuilder status [] respondWith status = liftIO . sendResponse . HS.responseBuilder status []
-- * ChatRequest handlers -- * ChatRequest handlers
startRemoteCtrl :: (ChatMonad m) => (ByteString -> m ChatResponse) -> m () startRemoteCtrl :: ChatMonad m => (ByteString -> m ChatResponse) -> m ()
startRemoteCtrl execChatCommand = startRemoteCtrl execChatCommand = do
chatReadVar remoteCtrlSession >>= \case checkNoRemoteCtrlSession
Just _busy -> throwError $ ChatErrorRemoteCtrl RCEBusy size <- asks $ tbqSize . config
Nothing -> do remoteOutputQ <- newTBQueueIO size
size <- asks $ tbqSize . config discovered <- newTVarIO mempty
remoteOutputQ <- newTBQueueIO size discoverer <- async $ discoverRemoteCtrls discovered
discovered <- newTVarIO mempty accepted <- newEmptyTMVarIO
discoverer <- async $ discoverRemoteCtrls discovered supervisor <- async $ runSupervisor discovered accepted
accepted <- newEmptyTMVarIO chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
supervisor <- async $ do
remoteCtrlId <- atomically (readTMVar accepted)
withRemoteCtrl remoteCtrlId $ \rc@RemoteCtrl {fingerprint} -> do
source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
atomically $ writeTVar discovered mempty -- flush unused sources
server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
_ <- waitCatch server
chatWriteVar remoteCtrlSession Nothing
toView CRRemoteCtrlStopped
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
discoverRemoteCtrls :: (ChatMonad m) => TM.TMap C.KeyHash TransportHost -> m ()
discoverRemoteCtrls discovered = Discovery.withListener go
where where
go sock = runSupervisor discovered accepted = do
remoteCtrlId <- atomically (readTMVar accepted)
rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
atomically $ writeTVar discovered mempty -- flush unused sources
server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
_ <- waitCatch server
chatWriteVar remoteCtrlSession Nothing
toView CRRemoteCtrlStopped
-- TODO the problem with this code was that it wasn't clear where the recursion can happen,
-- by splitting receiving and processing to two functions it becomes clear
discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m ()
discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process
where
-- TODO how would it receive more than one fingerprint?
receive sock =
Discovery.recvAnnounce sock >>= \case Discovery.recvAnnounce sock >>= \case
(SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of
Left _ -> go sock -- ignore malformed datagrams -- TODO it is probably better to report errors to view here
Right fingerprint -> do Left _ -> receive sock
let addr = THIPv4 (hostAddressToTuple sockAddr) Right fingerprint -> pure (sockAddr, fingerprint)
ifM _nonV4 -> receive sock
(atomically $ TM.member fingerprint discovered) process (sockAddr, fingerprint) = do
(logDebug $ "Fingerprint announce already knwon: " <> tshow (addr, invite)) let addr = THIPv4 (hostAddressToTuple sockAddr)
( do ifM
logInfo $ "New fingerprint announce: " <> tshow (addr, invite) (atomically $ TM.member fingerprint discovered)
atomically $ TM.insert fingerprint addr discovered (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint))
) ( do
withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint)
Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required atomically $ TM.insert fingerprint addr discovered
Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of )
Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events,
Just False -> pure () -- skipping a rejected item -- so UI now will have to check for duplicates again
Just True -> withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
chatReadVar remoteCtrlSession >>= \case Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" -- TODO Maybe Bool is very confusing - the intent is very unclear here
Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
_nonV4 -> go sock Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required
Just False -> pure () -- skipping a rejected item
Just True ->
chatReadVar remoteCtrlSession >>= \case
Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
listRemoteCtrls :: (ChatMonad m) => m [RemoteCtrlInfo] listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
listRemoteCtrls = do listRemoteCtrls = do
active <- active <-
chatReadVar remoteCtrlSession chatReadVar remoteCtrlSession
$>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted $>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted
map (rcInfo active) <$> withStore' getRemoteCtrls map (rcInfo active) <$> withStore' getRemoteCtrls
where where
rcInfo active rc@RemoteCtrl {remoteCtrlId} = rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} =
remoteCtrlInfo rc $ active == Just remoteCtrlId remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId
remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive = remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive =
RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive} RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive}
acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () acceptRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
acceptRemoteCtrl remoteCtrlId = do acceptRemoteCtrl rcId = do
withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId True -- TODO check it exists, check the ID is the same as in session
chatReadVar remoteCtrlSession >>= \case RemoteCtrlSession {accepted} <- getRemoteCtrlSession
Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive withStore' $ \db -> markRemoteCtrlResolution db rcId True
Just RemoteCtrlSession {accepted} -> atomically . void $ tryPutTMVar accepted remoteCtrlId -- the remote host can now proceed with connection atomically . void $ tryPutTMVar accepted rcId -- the remote host can now proceed with connection
rejectRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () rejectRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
rejectRemoteCtrl remoteCtrlId = do rejectRemoteCtrl rcId = do
withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId False withStore' $ \db -> markRemoteCtrlResolution db rcId False
chatReadVar remoteCtrlSession >>= \case RemoteCtrlSession {discoverer, supervisor} <- getRemoteCtrlSession
Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive cancel discoverer
Just RemoteCtrlSession {discoverer, supervisor} -> do cancel supervisor
cancel discoverer
cancel supervisor
stopRemoteCtrl :: (ChatMonad m) => m () stopRemoteCtrl :: ChatMonad m => m ()
stopRemoteCtrl = stopRemoteCtrl = do
chatReadVar remoteCtrlSession >>= \case rcs <- getRemoteCtrlSession
Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing
Just rcs -> cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing
cancelRemoteCtrlSession_ :: (MonadUnliftIO m) => RemoteCtrlSession -> m () cancelRemoteCtrlSession_ :: MonadUnliftIO m => RemoteCtrlSession -> m ()
cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure () cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure ()
cancelRemoteCtrlSession :: (MonadUnliftIO m) => RemoteCtrlSession -> m () -> m () cancelRemoteCtrlSession :: MonadUnliftIO m => RemoteCtrlSession -> m () -> m ()
cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = do cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = do
cancel discoverer -- may be gone by now cancel discoverer -- may be gone by now
case hostServer of case hostServer of
@@ -498,17 +507,19 @@ cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} c
cancel supervisor -- supervisor is blocked until session progresses cancel supervisor -- supervisor is blocked until session progresses
cleanup cleanup
deleteRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
deleteRemoteCtrl remoteCtrlId = deleteRemoteCtrl rcId = do
chatReadVar remoteCtrlSession >>= \case checkNoRemoteCtrlSession
Nothing -> withStore' $ \db -> deleteRemoteCtrlRecord db remoteCtrlId -- TODO check it exists
Just _ -> throwError $ ChatErrorRemoteCtrl RCEBusy withStore' (`deleteRemoteCtrlRecord` rcId)
withRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrl -> m a) -> m a getRemoteCtrlSession :: ChatMonad m => m RemoteCtrlSession
withRemoteCtrl remoteCtrlId action = getRemoteCtrlSession =
withStore' (`getRemoteCtrl` remoteCtrlId) >>= \case chatReadVar remoteCtrlSession >>= maybe (throwError $ ChatErrorRemoteCtrl RCEInactive) pure
Nothing -> throwError $ ChatErrorRemoteCtrl RCEMissing {remoteCtrlId}
Just rc -> action rc checkNoRemoteCtrlSession :: ChatMonad m => m ()
checkNoRemoteCtrlSession =
chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy)
utf8String :: [Char] -> ByteString utf8String :: [Char] -> ByteString
utf8String = encodeUtf8 . T.pack utf8String = encodeUtf8 . T.pack
src/Simplex/Chat/Remote/Discovery.hs
+4 -2
View File
@@ -53,8 +53,8 @@ pattern BROADCAST_PORT = "5226"
-- | Announce tls server, wait for connection and attach http2 client to it. -- | Announce tls server, wait for connection and attach http2 client to it.
-- --
-- Announcer is started when TLS server is started and stopped when a connection is made. -- Announcer is started when TLS server is started and stopped when a connection is made.
announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => m () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client) announceRevHTTP2 :: StrEncoding a => a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
announceRevHTTP2 finishAction invite credentials = do announceRevHTTP2 invite credentials finishAction = do
httpClient <- newEmptyMVar httpClient <- newEmptyMVar
started <- newEmptyTMVarIO started <- newEmptyTMVarIO
finished <- newEmptyMVar finished <- newEmptyMVar
@@ -77,6 +77,8 @@ runAnnouncer inviteBS = do
UDP.send sock inviteBS UDP.send sock inviteBS
threadDelay 1000000 threadDelay 1000000
-- TODO what prevents second client from connecting to the same server?
-- Do we need to start multiple TLS servers for different mobile hosts?
startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ()) startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
where where
src/Simplex/Chat/Store/Remote.hs
+7 -6
View File
@@ -4,14 +4,15 @@
module Simplex.Chat.Store.Remote where module Simplex.Chat.Store.Remote where
import Control.Monad.Except
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import Database.SQLite.Simple (Only (..)) import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL import qualified Database.SQLite.Simple as SQL
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Chat.Store.Shared (insertedRowId) import Simplex.Chat.Store.Shared
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId
@@ -23,9 +24,9 @@ getRemoteHosts :: DB.Connection -> IO [RemoteHost]
getRemoteHosts db = getRemoteHosts db =
map toRemoteHost <$> DB.query_ db remoteHostQuery map toRemoteHost <$> DB.query_ db remoteHostQuery
getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost) getRemoteHost :: DB.Connection -> RemoteHostId -> ExceptT StoreError IO RemoteHost
getRemoteHost db remoteHostId = getRemoteHost db remoteHostId =
maybeFirstRow toRemoteHost $ ExceptT . firstRow toRemoteHost (SERemoteHostNotFound remoteHostId) $
DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId) DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId)
remoteHostQuery :: SQL.Query remoteHostQuery :: SQL.Query
@@ -48,9 +49,9 @@ getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
getRemoteCtrls db = getRemoteCtrls db =
map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery
getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO (Maybe RemoteCtrl) getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
getRemoteCtrl db remoteCtrlId = getRemoteCtrl db remoteCtrlId =
maybeFirstRow toRemoteCtrl $ ExceptT . firstRow toRemoteCtrl (SERemoteCtrlNotFound remoteCtrlId) $
DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId) DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId)
getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl) getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl)
src/Simplex/Chat/Store/Shared.hs
+3
View File
@@ -31,6 +31,7 @@ import Database.SQLite.Simple.QQ (sql)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Remote.Types
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
@@ -100,6 +101,8 @@ data StoreError
| SEHostMemberIdNotFound {groupId :: Int64} | SEHostMemberIdNotFound {groupId :: Int64}
| SEContactNotFoundByFileId {fileId :: FileTransferId} | SEContactNotFoundByFileId {fileId :: FileTransferId}
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
deriving (Show, Exception, Generic) deriving (Show, Exception, Generic)
instance FromJSON StoreError where instance FromJSON StoreError where
tests/RemoteTests.hs
+2 -2
View File
@@ -33,7 +33,7 @@ import UnliftIO
import UnliftIO.Directory import UnliftIO.Directory
remoteTests :: SpecWith FilePath remoteTests :: SpecWith FilePath
remoteTests = describe "Handshake" $ do remoteTests = fdescribe "Handshake" $ do
it "generates usable credentials" genCredentialsTest it "generates usable credentials" genCredentialsTest
it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
it "connects desktop and mobile" remoteHandshakeTest it "connects desktop and mobile" remoteHandshakeTest
@@ -70,7 +70,7 @@ announceDiscoverHttp2Test _tmp = do
controller <- async $ do controller <- async $ do
traceM " - Controller: starting" traceM " - Controller: starting"
bracket bracket
(Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure) (Discovery.announceRevHTTP2 fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
closeHTTP2Client closeHTTP2Client
( \http -> do ( \http -> do
traceM " - Controller: got client" traceM " - Controller: got client"