diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index 756ab3034f..761c1daf7c 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -1804,7 +1804,6 @@ public enum ArchiveError: Decodable { } public enum RemoteCtrlError: Decodable { - case missing(remoteCtrlId: Int64) case inactive case busy case timeout diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt index f128fcb75f..1f5cc09d47 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt @@ -4521,7 +4521,6 @@ sealed class RemoteHostError { @Serializable sealed class RemoteCtrlError { val string: String get() = when (this) { - is Missing -> "missing" is Inactive -> "inactive" is Busy -> "busy" is Timeout -> "timeout" @@ -4531,7 +4530,6 @@ sealed class RemoteCtrlError { is CertificateUntrusted -> "certificateUntrusted" is BadFingerprint -> "badFingerprint" } - @Serializable @SerialName("missing") class Missing(val remoteCtrlId: Long): RemoteCtrlError() @Serializable @SerialName("inactive") object Inactive: RemoteCtrlError() @Serializable @SerialName("busy") object Busy: RemoteCtrlError() @Serializable @SerialName("timeout") object Timeout: RemoteCtrlError() diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 9c25afbd51..e1bd795b38 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -397,7 +397,7 @@ execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd) 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 = 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) liftIO $ mapM_ hClose h_ `catchAll_` pure () -throwChatError :: ChatMonad m => ChatErrorType -> m a -throwChatError = throwError . ChatError - deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m () deleteMembersConnections user members = do let memberConns = diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 22c2649f5a..78848cca22 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1158,8 +1158,7 @@ instance ToJSON RemoteHostError where -- TODO review errors, some of it can be covered by HTTP2 errors 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 | RCETimeout -- ^ Remote operation timed out | 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 | RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB + | RCEHTTP2Error {http2Error :: String} + | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove + | RCEInvalidResponse {responseError :: String} deriving (Show, Exception, Generic) instance FromJSON RemoteCtrlError where @@ -1199,7 +1201,7 @@ data RemoteHostSession } 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 (), supervisor :: Async (), hostServer :: Maybe (Async ()), @@ -1239,6 +1241,10 @@ chatFinally :: ChatMonad m => m a -> m b -> m a chatFinally = allFinally mkChatError {-# 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 = ChatError . CEException . show {-# INLINE mkChatError #-} @@ -1246,6 +1252,9 @@ mkChatError = ChatError . CEException . show chatCmdError :: Maybe User -> String -> ChatResponse chatCmdError user = CRChatCmdError user . ChatError . CECommandError +throwChatError :: ChatMonad m => ChatErrorType -> m a +throwChatError = throwError . ChatError + -- | Emit local events. toView :: ChatMonad' m => ChatResponse -> m () toView event = do diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 256e00d6d4..336b5d2cf9 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -38,8 +38,8 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types.Status as Status -import qualified Network.HTTP2.Client as HTTP2Client -import qualified Network.HTTP2.Server as HTTP2Server +import qualified Network.HTTP2.Client as HC +import qualified Network.HTTP2.Server as HS import Network.Socket (SockAddr (..), hostAddressToTuple) import Simplex.Chat.Controller 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.Credentials (genCredentials, tlsCredentials) 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.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 UnliftIO import UnliftIO.Directory (createDirectoryIfMissing, getFileSize) -withRemoteHostSession :: (ChatMonad m) => RemoteHostId -> (RemoteHostSession -> m a) -> m a -withRemoteHostSession remoteHostId action = do - chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId +getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession +getRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe err pure . M.lookup rhId where - err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing + err = throwError $ ChatErrorRemoteHost rhId RHMissing -withRemoteHost :: (ChatMonad m) => RemoteHostId -> (RemoteHost -> m a) -> m a -withRemoteHost remoteHostId action = - withStore' (`getRemoteHost` remoteHostId) >>= \case - Nothing -> throwError $ ChatErrorRemoteHost remoteHostId RHMissing - Just rh -> action rh +checkNoRemoteHostSession :: ChatMonad m => RemoteHostId -> m () +checkNoRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe (pure ()) err . M.lookup rhId + where + err _ = throwError $ ChatErrorRemoteHost rhId RHBusy -startRemoteHost :: (ChatMonad m) => RemoteHostId -> m () -startRemoteHost remoteHostId = do - asks remoteHostSessions >>= atomically . TM.lookup remoteHostId >>= \case - Just _ -> throwError $ ChatErrorRemoteHost remoteHostId RHBusy - Nothing -> withRemoteHost remoteHostId $ \rh -> do - announcer <- async $ run rh - chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarting {announcer} +startRemoteHost :: ChatMonad m => RemoteHostId -> m () +startRemoteHost rhId = do + checkNoRemoteHostSession rhId + rh <- withStore (`getRemoteHost` rhId) + announcer <- async $ do + finished <- newTVarIO False + http <- start rh finished `onChatError` cleanup finished + run rh finished http + chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarting {announcer} where cleanup finished = do logInfo "Remote host http2 client fininshed" atomically $ writeTVar finished True - M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case - Nothing -> logInfo $ "Session already closed for remote host " <> tshow remoteHostId - Just _ -> closeRemoteHostSession remoteHostId >> toView (CRRemoteHostStopped remoteHostId) - run rh@RemoteHost {storePath, caKey, caCert} = do - finished <- newTVarIO False + -- TODO why this is not an error? + M.lookup rhId <$> chatReadVar remoteHostSessions >>= \case + Nothing -> logInfo $ "Session already closed for remote host " <> tshow rhId + Just _ -> closeRemoteHostSession rhId >> toView (CRRemoteHostStopped rhId) + start rh@RemoteHost {storePath, caKey, caCert} finished = do let parent = (C.signatureKeyPair caKey, caCert) sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session" let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent] - Discovery.announceRevHTTP2 (cleanup finished) fingerprint credentials >>= \case - Left h2ce -> do - logError $ "Failed to set up remote host connection: " <> tshow h2ce - cleanup finished - Right ctrlClient -> do - chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient} - chatWriteVar currentRemoteHost $ Just remoteHostId - sendHello ctrlClient >>= \case - Left h2ce -> do - logError $ "Failed to send initial remote host request: " <> tshow h2ce - cleanup finished - Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do - logDebug $ "Got initial from remote host: " <> tshow bodyHead - oq <- asks outputQ - let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just remoteHostId,) - void . async $ pollRemote finished ctrlClient "/recv" $ \chatResponse -> do - case chatResponse of - CRRcvFileComplete {user = ru, chatItem = AChatItem c d@SMDRcv i ci@ChatItem {file = Just ciFile}} -> do - handleRcvFileComplete ctrlClient storePath ru ciFile >>= \case - Nothing -> toViewRemote chatResponse - Just localFile -> toViewRemote CRRcvFileComplete {user = ru, chatItem = AChatItem c d i ci {file = Just localFile}} - _ -> toViewRemote chatResponse - rcName <- chatReadVar localDeviceName - -- TODO what sets session active? - toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName} + u <- askUnliftIO + ctrlClient <- liftHTTP2 $ Discovery.announceRevHTTP2 fingerprint credentials $ unliftIO u (cleanup finished) -- >>= \case + chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarted {storePath, ctrlClient} + chatWriteVar currentRemoteHost $ Just rhId + HTTP2Response {respBody = HTTP2Body {bodyHead}} <- sendHello ctrlClient + rcName <- chatReadVar localDeviceName + -- TODO what sets session active? + toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName} + pure ctrlClient + run RemoteHost {storePath} finished ctrlClient = do + oq <- asks outputQ + let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just rhId,) + -- TODO remove REST + void . async $ pollRemote finished ctrlClient "/recv" $ handleFile >=> toViewRemote + where + -- TODO move to view / terminal + handleFile = \case + cr@CRRcvFileComplete {user, chatItem = AChatItem c SMDRcv i ci@ChatItem {file = Just ciFile@CIFile {fileStatus = CIFSRcvComplete}}} -> do + maybe cr update <$> handleRcvFileComplete ctrlClient storePath user ciFile + where + update localFile = cr {chatItem = AChatItem c SMDRcv i ci {file = Just localFile}} + cr -> pure cr -sendHello :: (ChatMonad m) => HTTP2Client -> m (Either HTTP2.HTTP2ClientError HTTP2.HTTP2Response) -sendHello http = liftIO (HTTP2.sendRequestDirect http req Nothing) +sendHello :: ChatMonad m => HTTP2Client -> m HTTP2Response +sendHello http = liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing where - req = HTTP2Client.requestNoBody "GET" "/" mempty + req = HC.requestNoBody "GET" "/" mempty -pollRemote :: (ChatMonad m, J.FromJSON a) => TVar Bool -> HTTP2Client -> ByteString -> (a -> m ()) -> m () -pollRemote finished http path action = loop +-- TODO how (on what condition) it would stop polling? +-- 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 loop = do - liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case - Left e -> logError $ "pollRemote: " <> tshow (path, e) - Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do - logDebug $ "Got /recv response: " <> decodeUtf8 bodyHead - case J.eitherDecodeStrict' bodyHead of - Left e -> logError $ "pollRemote/decode: " <> tshow (path, e) - Right o -> action o + -- TODO this will never load full body + HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing + json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead -- of + action json readTVarIO finished >>= (`unless` loop) - req = HTTP2Client.requestNoBody "GET" path mempty + req = HC.requestNoBody "GET" path mempty -closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m () -closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do +closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m () +closeRemoteHostSession remoteHostId = do + session <- getRemoteHostSession remoteHostId logInfo $ "Closing remote host session for " <> tshow remoteHostId liftIO $ cancelRemoteHostSession session chatWriteVar currentRemoteHost Nothing chatModifyVar remoteHostSessions $ M.delete remoteHostId -cancelRemoteHostSession :: (MonadUnliftIO m) => RemoteHostSession -> m () +cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m () cancelRemoteHostSession = \case RemoteHostSessionStarting {announcer} -> cancel announcer RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient -createRemoteHost :: (ChatMonad m) => m RemoteHostInfo +createRemoteHost :: ChatMonad m => m RemoteHostInfo createRemoteHost = do 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 @@ -170,7 +167,7 @@ createRemoteHost = do randomStorePath :: IO FilePath randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12 -listRemoteHosts :: (ChatMonad m) => m [RemoteHostInfo] +listRemoteHosts :: ChatMonad m => m [RemoteHostInfo] listRemoteHosts = do active <- chatReadVar remoteHostSessions rcName <- chatReadVar localDeviceName @@ -184,75 +181,72 @@ remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} session let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName} in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive} -deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m () -deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do +deleteRemoteHost :: ChatMonad m => RemoteHostId -> m () +deleteRemoteHost rhId = do + RemoteHost {storePath} <- withStore (`getRemoteHost` rhId) chatReadVar filesFolder >>= \case Just baseDir -> do let hostStore = baseDir storePath logError $ "TODO: remove " <> tshow hostStore 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 RemoteHostSessionStarting {} _ = pure . CRChatError Nothing . ChatError $ CEInternalError "sending remote commands before session started" -processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = do - logDebug $ "processRemoteCommand: " <> tshow (s, cmd) - 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 +processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse +processRemoteCommand RemoteHostSessionStarting {} _ = pure $ chatCmdError Nothing "remote command sent before session started" +processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = + uploadFile cmd >>= relayCommand ctrlClient 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 = id -- owsf2tagged TODO: get from RemoteHost - -- XXX: extract to http2 transport - postBytestring timeout' c path hs body = liftIO $ HTTP2.sendRequestDirect c req timeout' - where - req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body) + req = HC.requestBuilder "POST" "/send" mempty (Binary.fromByteString s) -handleRcvFileComplete :: (ChatMonad m) => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv)) -handleRcvFileComplete http storePath remoteUser cif@CIFile {fileId, fileName, fileStatus} = case fileStatus of - CIFSRcvComplete -> - chatReadVar filesFolder >>= \case - Just baseDir -> do - let hostStore = baseDir storePath - createDirectoryIfMissing True hostStore - localPath <- uniqueCombine hostStore fileName - ok <- fetchRemoteFile http remoteUser fileId localPath - if ok - then pure $ Just (cif {fileName = localPath} :: CIFile 'MDRcv) - else Nothing <$ logError "fetchRemoteFile failed" - Nothing -> Nothing <$ logError "Local file store not available while fetching remote file" - _ -> Nothing <$ logDebug ("Ingoring invalid file notification for file (" <> tshow fileId <> ") " <> tshow fileName) +-- TODO fileName is just metadata that does not determine the actual file location for UI, or whether it is encrypted or not +-- fileSource is the actual file location (with information whether it is locally encrypted) +handleRcvFileComplete :: ChatMonad m => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv)) +handleRcvFileComplete http storePath remoteUser f@CIFile {fileId, fileName} = + chatReadVar filesFolder >>= \case + Just baseDir -> do + let hostStore = baseDir storePath + createDirectoryIfMissing True hostStore + -- TODO the problem here is that the name may turn out to be different and nothing will work + -- file processing seems to work "accidentally", not "by design" + localPath <- uniqueCombine hostStore fileName + fetchRemoteFile http remoteUser fileId localPath + pure $ Just (f {fileName = localPath} :: CIFile 'MDRcv) + -- 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 owsf2tagged :: J.Value -> J.Value @@ -288,36 +282,42 @@ owsf2tagged = fst . convert pattern OwsfTag :: (JK.Key, J.Value) 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 - putFile Nothing http uri mempty localFile >>= \case - Left h2ce -> Nothing <$ logError (tshow h2ce) - Right HTTP2.HTTP2Response {response, respBody = HTTP2Body {bodyHead}} -> - case HTTP.statusCode <$> HTTP2Client.responseStatus response of - Just 200 -> pure . Just $ B.unpack bodyHead - notOk -> Nothing <$ logError ("Bad response status: " <> tshow notOk) + fileSize <- liftIO $ fromIntegral <$> getFileSize localFile + -- TODO configure timeout + let timeout' = Nothing + r@HTTP2Response {respBody = HTTP2Body {bodyHead}} <- + liftHTTP2 $ HTTP2.sendRequestDirect http (req fileSize) timeout' + 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 + -- TODO local file encryption? uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)] - putFile timeout' c path hs file = liftIO $ do - fileSize <- fromIntegral <$> getFileSize file - HTTP2.sendRequestDirect c (req fileSize) timeout' - where - req size = HTTP2Client.requestFile "PUT" path hs (HTTP2Client.FileSpec file 0 size) + req size = HC.requestFile "PUT" uri mempty (HC.FileSpec localFile 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 - liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case - Left h2ce -> False <$ logError (tshow h2ce) - Right HTTP2.HTTP2Response {response, 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)) + r@HTTP2Response {respBody} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing + responseStatusOK r + writeBodyToFile localPath respBody 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)] -- XXX: extract to Transport.HTTP2 ? -writeBodyToFile :: (MonadUnliftIO m) => FilePath -> HTTP2Body -> m () +writeBodyToFile :: MonadUnliftIO m => FilePath -> HTTP2Body -> m () writeBodyToFile path HTTP2Body {bodyHead, bodySize, bodyPart} = do logInfo $ "Receiving " <> tshow bodySize <> " bytes to " <> tshow path liftIO . withFile path WriteMode $ \h -> do @@ -331,7 +331,8 @@ hPutBodyChunks h getChunk = do hPut h chunk 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 logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) 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 Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK" where - method = fromMaybe "" $ HTTP2Server.requestMethod request - path = fromMaybe "/" $ HTTP2Server.requestPath request + method = fromMaybe "" $ HS.requestMethod request + path = fromMaybe "/" $ HS.requestPath request (ps, query) = HTTP.decodePath path getHello = respond "OK" sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON @@ -354,6 +355,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s chatReadVar remoteCtrlSession >>= \case Nothing -> respondWith Status.internalServerError500 "session not active" Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON + -- TODO liftEither storeFileQuery storeFile = case storeFileQuery of Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err) Right fileName -> do @@ -365,6 +367,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s respond $ Binary.putStringUtf8 storeRelative where 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 Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err) Right (userId, fileId) -> do @@ -372,12 +375,13 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s x <- withStore' $ \db -> runExceptT $ do user <- getUser db userId getRcvFileTransfer db user fileId + -- TODO this error handling is very ad-hoc, there is no separation between Chat errors and responses case x of Right RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> do baseDir <- fromMaybe "." <$> chatReadVar filesFolder let fullPath = baseDir filePath 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" Left SEUserNotFound {} -> respondWith Status.notFound404 "User 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 respond = respondWith Status.ok200 - respondWith status = liftIO . sendResponse . HTTP2Server.responseBuilder status [] + respondWith status = liftIO . sendResponse . HS.responseBuilder status [] -- * ChatRequest handlers -startRemoteCtrl :: (ChatMonad m) => (ByteString -> m ChatResponse) -> m () -startRemoteCtrl execChatCommand = - chatReadVar remoteCtrlSession >>= \case - Just _busy -> throwError $ ChatErrorRemoteCtrl RCEBusy - Nothing -> do - size <- asks $ tbqSize . config - remoteOutputQ <- newTBQueueIO size - discovered <- newTVarIO mempty - discoverer <- async $ discoverRemoteCtrls discovered - accepted <- newEmptyTMVarIO - 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 +startRemoteCtrl :: ChatMonad m => (ByteString -> m ChatResponse) -> m () +startRemoteCtrl execChatCommand = do + checkNoRemoteCtrlSession + size <- asks $ tbqSize . config + remoteOutputQ <- newTBQueueIO size + discovered <- newTVarIO mempty + discoverer <- async $ discoverRemoteCtrls discovered + accepted <- newEmptyTMVarIO + supervisor <- async $ runSupervisor discovered accepted + chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ} 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 (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of - Left _ -> go sock -- ignore malformed datagrams - Right fingerprint -> do - let addr = THIPv4 (hostAddressToTuple sockAddr) - ifM - (atomically $ TM.member fingerprint discovered) - (logDebug $ "Fingerprint announce already knwon: " <> tshow (addr, invite)) - ( do - logInfo $ "New fingerprint announce: " <> tshow (addr, invite) - atomically $ TM.insert fingerprint addr discovered - ) - withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case - Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required - Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of - 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 - _nonV4 -> go sock + -- TODO it is probably better to report errors to view here + Left _ -> receive sock + Right fingerprint -> pure (sockAddr, fingerprint) + _nonV4 -> receive sock + process (sockAddr, fingerprint) = do + let addr = THIPv4 (hostAddressToTuple sockAddr) + ifM + (atomically $ TM.member fingerprint discovered) + (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint)) + ( do + logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint) + atomically $ TM.insert fingerprint addr discovered + ) + -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events, + -- so UI now will have to check for duplicates again + withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case + Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required + -- TODO Maybe Bool is very confusing - the intent is very unclear here + Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of + 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 active <- chatReadVar remoteCtrlSession $>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted map (rcInfo active) <$> withStore' getRemoteCtrls where - rcInfo active rc@RemoteCtrl {remoteCtrlId} = - remoteCtrlInfo rc $ active == Just remoteCtrlId + rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} = + remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive = RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive} -acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () -acceptRemoteCtrl remoteCtrlId = do - withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId True - chatReadVar remoteCtrlSession >>= \case - Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive - Just RemoteCtrlSession {accepted} -> atomically . void $ tryPutTMVar accepted remoteCtrlId -- the remote host can now proceed with connection +acceptRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () +acceptRemoteCtrl rcId = do + -- TODO check it exists, check the ID is the same as in session + RemoteCtrlSession {accepted} <- getRemoteCtrlSession + withStore' $ \db -> markRemoteCtrlResolution db rcId True + atomically . void $ tryPutTMVar accepted rcId -- the remote host can now proceed with connection -rejectRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () -rejectRemoteCtrl remoteCtrlId = do - withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId False - chatReadVar remoteCtrlSession >>= \case - Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive - Just RemoteCtrlSession {discoverer, supervisor} -> do - cancel discoverer - cancel supervisor +rejectRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () +rejectRemoteCtrl rcId = do + withStore' $ \db -> markRemoteCtrlResolution db rcId False + RemoteCtrlSession {discoverer, supervisor} <- getRemoteCtrlSession + cancel discoverer + cancel supervisor -stopRemoteCtrl :: (ChatMonad m) => m () -stopRemoteCtrl = - chatReadVar remoteCtrlSession >>= \case - Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive - Just rcs -> cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing +stopRemoteCtrl :: ChatMonad m => m () +stopRemoteCtrl = do + rcs <- getRemoteCtrlSession + cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing -cancelRemoteCtrlSession_ :: (MonadUnliftIO m) => RemoteCtrlSession -> m () +cancelRemoteCtrlSession_ :: MonadUnliftIO m => RemoteCtrlSession -> m () cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure () -cancelRemoteCtrlSession :: (MonadUnliftIO m) => RemoteCtrlSession -> m () -> m () +cancelRemoteCtrlSession :: MonadUnliftIO m => RemoteCtrlSession -> m () -> m () cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = do cancel discoverer -- may be gone by now case hostServer of @@ -498,17 +507,19 @@ cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} c cancel supervisor -- supervisor is blocked until session progresses cleanup -deleteRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m () -deleteRemoteCtrl remoteCtrlId = - chatReadVar remoteCtrlSession >>= \case - Nothing -> withStore' $ \db -> deleteRemoteCtrlRecord db remoteCtrlId - Just _ -> throwError $ ChatErrorRemoteCtrl RCEBusy +deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () +deleteRemoteCtrl rcId = do + checkNoRemoteCtrlSession + -- TODO check it exists + withStore' (`deleteRemoteCtrlRecord` rcId) -withRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrl -> m a) -> m a -withRemoteCtrl remoteCtrlId action = - withStore' (`getRemoteCtrl` remoteCtrlId) >>= \case - Nothing -> throwError $ ChatErrorRemoteCtrl RCEMissing {remoteCtrlId} - Just rc -> action rc +getRemoteCtrlSession :: ChatMonad m => m RemoteCtrlSession +getRemoteCtrlSession = + chatReadVar remoteCtrlSession >>= maybe (throwError $ ChatErrorRemoteCtrl RCEInactive) pure + +checkNoRemoteCtrlSession :: ChatMonad m => m () +checkNoRemoteCtrlSession = + chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy) utf8String :: [Char] -> ByteString utf8String = encodeUtf8 . T.pack diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs index 40314b4cb5..01c6d12c6e 100644 --- a/src/Simplex/Chat/Remote/Discovery.hs +++ b/src/Simplex/Chat/Remote/Discovery.hs @@ -53,8 +53,8 @@ pattern BROADCAST_PORT = "5226" -- | 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. -announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => m () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client) -announceRevHTTP2 finishAction invite credentials = do +announceRevHTTP2 :: StrEncoding a => a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client) +announceRevHTTP2 invite credentials finishAction = do httpClient <- newEmptyMVar started <- newEmptyTMVarIO finished <- newEmptyMVar @@ -77,6 +77,8 @@ runAnnouncer inviteBS = do UDP.send sock inviteBS 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 started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig where diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index 9189a27769..a4c2ef85e1 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -4,14 +4,15 @@ module Simplex.Chat.Store.Remote where +import Control.Monad.Except import Data.Int (Int64) import Data.Text (Text) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL 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.Messaging.Agent.Store.SQLite (maybeFirstRow) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Crypto as C insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId @@ -23,9 +24,9 @@ getRemoteHosts :: DB.Connection -> IO [RemoteHost] getRemoteHosts db = map toRemoteHost <$> DB.query_ db remoteHostQuery -getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost) +getRemoteHost :: DB.Connection -> RemoteHostId -> ExceptT StoreError IO RemoteHost getRemoteHost db remoteHostId = - maybeFirstRow toRemoteHost $ + ExceptT . firstRow toRemoteHost (SERemoteHostNotFound remoteHostId) $ DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId) remoteHostQuery :: SQL.Query @@ -48,9 +49,9 @@ getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl] getRemoteCtrls db = map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery -getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO (Maybe RemoteCtrl) +getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl getRemoteCtrl db remoteCtrlId = - maybeFirstRow toRemoteCtrl $ + ExceptT . firstRow toRemoteCtrl (SERemoteCtrlNotFound remoteCtrlId) $ DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId) getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl) diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index fabe5b9962..5cc1e87d58 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -31,6 +31,7 @@ import Database.SQLite.Simple.QQ (sql) import GHC.Generics (Generic) import Simplex.Chat.Messages import Simplex.Chat.Protocol +import Simplex.Chat.Remote.Types import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) @@ -100,6 +101,8 @@ data StoreError | SEHostMemberIdNotFound {groupId :: Int64} | SEContactNotFoundByFileId {fileId :: FileTransferId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} + | SERemoteHostNotFound {remoteHostId :: RemoteHostId} + | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} deriving (Show, Exception, Generic) instance FromJSON StoreError where diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 5bc1845803..b739c19882 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -33,7 +33,7 @@ import UnliftIO import UnliftIO.Directory remoteTests :: SpecWith FilePath -remoteTests = describe "Handshake" $ do +remoteTests = fdescribe "Handshake" $ do it "generates usable credentials" genCredentialsTest it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test it "connects desktop and mobile" remoteHandshakeTest @@ -70,7 +70,7 @@ announceDiscoverHttp2Test _tmp = do controller <- async $ do traceM " - Controller: starting" bracket - (Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure) + (Discovery.announceRevHTTP2 fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure) closeHTTP2Client ( \http -> do traceM " - Controller: got client"