{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Remote where

import Control.Applicative ((<|>))
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Reader
import Crypto.Random (getRandomBytes)
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as B64U
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Word (Word16, Word32)
import qualified Network.HTTP.Types as N
import Network.HTTP2.Server (responseStreaming)
import qualified Paths_simplex_chat as SC
import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Messages (chatNameStr)
import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Remote.Protocol
import Simplex.Chat.Remote.RevHTTP (attachHTTP2Server, attachRevHTTP2Client)
import Simplex.Chat.Remote.Transport
import Simplex.Chat.Remote.Types
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Remote
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Util (encryptFile, liftIOEither)
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TLS, TransportPeer (..), closeConnection, tlsUniq)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError, closeHTTP2Client)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
import Simplex.Messaging.Util
import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..), RCVerifiedInvitation (..), verifySignedInvitation)
import Simplex.RemoteControl.Types
import System.FilePath (takeFileName, (</>))
import UnliftIO
import UnliftIO.Concurrent (forkIO)
import UnliftIO.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive, renameFile)

remoteFilesFolder :: String
remoteFilesFolder :: FilePath
remoteFilesFolder = FilePath
"simplex_v1_files"

-- when acting as host
minRemoteCtrlVersion :: AppVersion
minRemoteCtrlVersion :: AppVersion
minRemoteCtrlVersion = Version -> AppVersion
AppVersion [SessionSeq
Item Version
6, SessionSeq
Item Version
4, SessionSeq
Item Version
6, SessionSeq
Item Version
0]

-- when acting as controller
minRemoteHostVersion :: AppVersion
minRemoteHostVersion :: AppVersion
minRemoteHostVersion = Version -> AppVersion
AppVersion [SessionSeq
Item Version
6, SessionSeq
Item Version
4, SessionSeq
Item Version
6, SessionSeq
Item Version
0]

currentAppVersion :: AppVersion
currentAppVersion :: AppVersion
currentAppVersion = Version -> AppVersion
AppVersion Version
SC.version

ctrlAppVersionRange :: AppVersionRange
ctrlAppVersionRange :: AppVersionRange
ctrlAppVersionRange = AppVersion -> AppVersion -> AppVersionRange
mkAppVersionRange AppVersion
minRemoteHostVersion AppVersion
currentAppVersion

hostAppVersionRange :: AppVersionRange
hostAppVersionRange :: AppVersionRange
hostAppVersionRange = AppVersion -> AppVersion -> AppVersionRange
mkAppVersionRange AppVersion
minRemoteCtrlVersion AppVersion
currentAppVersion

networkIOTimeout :: Int
networkIOTimeout :: SessionSeq
networkIOTimeout = SessionSeq
15000000

discoveryTimeout :: Int
discoveryTimeout :: SessionSeq
discoveryTimeout = SessionSeq
60000000

-- * Desktop side

getRemoteHostClient :: RemoteHostId -> CM RemoteHostClient
getRemoteHostClient :: RemoteCtrlId -> CM RemoteHostClient
getRemoteHostClient RemoteCtrlId
rhId = do
  TMap RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap RHKey (SessionSeq, RemoteHostSession))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  IO (Either ChatError RemoteHostClient) -> CM RemoteHostClient
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either ChatError RemoteHostClient) -> CM RemoteHostClient)
-> (STM (Either ChatError RemoteHostClient)
    -> IO (Either ChatError RemoteHostClient))
-> STM (Either ChatError RemoteHostClient)
-> CM RemoteHostClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either ChatError RemoteHostClient)
-> IO (Either ChatError RemoteHostClient)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError RemoteHostClient) -> CM RemoteHostClient)
-> STM (Either ChatError RemoteHostClient) -> CM RemoteHostClient
forall a b. (a -> b) -> a -> b
$
    RHKey
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM (Maybe (SessionSeq, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RHKey
rhKey TMap RHKey (SessionSeq, RemoteHostSession)
sessions STM (Maybe (SessionSeq, RemoteHostSession))
-> (Maybe (SessionSeq, RemoteHostSession)
    -> STM (Either ChatError RemoteHostClient))
-> STM (Either ChatError RemoteHostClient)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (SessionSeq
_, RHSessionConnected {RemoteHostClient
rhClient :: RemoteHostClient
rhClient :: RemoteHostSession -> RemoteHostClient
rhClient}) -> Either ChatError RemoteHostClient
-> STM (Either ChatError RemoteHostClient)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError RemoteHostClient
 -> STM (Either ChatError RemoteHostClient))
-> Either ChatError RemoteHostClient
-> STM (Either ChatError RemoteHostClient)
forall a b. (a -> b) -> a -> b
$ RemoteHostClient -> Either ChatError RemoteHostClient
forall a b. b -> Either a b
Right RemoteHostClient
rhClient
      Just (SessionSeq, RemoteHostSession)
_ -> Either ChatError RemoteHostClient
-> STM (Either ChatError RemoteHostClient)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError RemoteHostClient
 -> STM (Either ChatError RemoteHostClient))
-> (ChatError -> Either ChatError RemoteHostClient)
-> ChatError
-> STM (Either ChatError RemoteHostClient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError RemoteHostClient
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError RemoteHostClient))
-> ChatError -> STM (Either ChatError RemoteHostClient)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
      Maybe (SessionSeq, RemoteHostSession)
Nothing -> Either ChatError RemoteHostClient
-> STM (Either ChatError RemoteHostClient)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError RemoteHostClient
 -> STM (Either ChatError RemoteHostClient))
-> (ChatError -> Either ChatError RemoteHostClient)
-> ChatError
-> STM (Either ChatError RemoteHostClient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError RemoteHostClient
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError RemoteHostClient))
-> ChatError -> STM (Either ChatError RemoteHostClient)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEMissing
  where
    rhKey :: RHKey
rhKey = RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId

withRemoteHostSession :: RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> CM a
withRemoteHostSession :: forall a.
RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError (a, RemoteHostSession))
-> CM a
withRemoteHostSession RHKey
rhKey SessionSeq
sseq RemoteHostSession -> Either ChatError (a, RemoteHostSession)
f = do
  TMap RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap RHKey (SessionSeq, RemoteHostSession))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  Either ChatError a
r <-
    STM (Either ChatError a)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError a)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Either ChatError a))
-> STM (Either ChatError a)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError a)
forall a b. (a -> b) -> a -> b
$
      RHKey
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM (Maybe (SessionSeq, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RHKey
rhKey TMap RHKey (SessionSeq, RemoteHostSession)
sessions STM (Maybe (SessionSeq, RemoteHostSession))
-> (Maybe (SessionSeq, RemoteHostSession)
    -> STM (Either ChatError a))
-> STM (Either ChatError a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (SessionSeq, RemoteHostSession)
Nothing -> Either ChatError a -> STM (Either ChatError a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError a -> STM (Either ChatError a))
-> (ChatError -> Either ChatError a)
-> ChatError
-> STM (Either ChatError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError a
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError a))
-> ChatError -> STM (Either ChatError a)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEMissing
        Just (SessionSeq
stateSeq, RemoteHostSession
state)
          | SessionSeq
stateSeq SessionSeq -> SessionSeq -> Bool
forall a. Eq a => a -> a -> Bool
/= SessionSeq
sseq -> Either ChatError a -> STM (Either ChatError a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError a -> STM (Either ChatError a))
-> (ChatError -> Either ChatError a)
-> ChatError
-> STM (Either ChatError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError a
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError a))
-> ChatError -> STM (Either ChatError a)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
          | Bool
otherwise -> case RemoteHostSession -> Either ChatError (a, RemoteHostSession)
f RemoteHostSession
state of
              Right (a
r, RemoteHostSession
newState) -> a -> Either ChatError a
forall a b. b -> Either a b
Right a
r Either ChatError a -> STM () -> STM (Either ChatError a)
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RHKey
-> (SessionSeq, RemoteHostSession)
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RHKey
rhKey (SessionSeq
sseq, RemoteHostSession
newState) TMap RHKey (SessionSeq, RemoteHostSession)
sessions
              Left ChatError
ce -> Either ChatError a -> STM (Either ChatError a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError a -> STM (Either ChatError a))
-> Either ChatError a -> STM (Either ChatError a)
forall a b. (a -> b) -> a -> b
$ ChatError -> Either ChatError a
forall a b. a -> Either a b
Left ChatError
ce
  Either ChatError a -> CM a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either ChatError a
r

-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
setNewRemoteHostId :: SessionSeq -> RemoteHostId -> CM ()
setNewRemoteHostId :: SessionSeq -> RemoteCtrlId -> CM ()
setNewRemoteHostId SessionSeq
sseq RemoteCtrlId
rhId = do
  TMap RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap RHKey (SessionSeq, RemoteHostSession))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  IO (Either ChatError ()) -> CM ()
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either ChatError ()) -> CM ())
-> (STM (Either ChatError ()) -> IO (Either ChatError ()))
-> STM (Either ChatError ())
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either ChatError ()) -> IO (Either ChatError ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError ()) -> CM ())
-> STM (Either ChatError ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    RHKey
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM (Maybe (SessionSeq, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RHKey
RHNew TMap RHKey (SessionSeq, RemoteHostSession)
sessions STM (Maybe (SessionSeq, RemoteHostSession))
-> (Maybe (SessionSeq, RemoteHostSession)
    -> STM (Either ChatError ()))
-> STM (Either ChatError ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (SessionSeq, RemoteHostSession)
Nothing -> RemoteHostError -> STM (Either ChatError ())
forall {b}. RemoteHostError -> STM (Either ChatError b)
err RemoteHostError
RHEMissing
      Just sess :: (SessionSeq, RemoteHostSession)
sess@(SessionSeq
stateSeq, RemoteHostSession
_)
        | SessionSeq
stateSeq SessionSeq -> SessionSeq -> Bool
forall a. Eq a => a -> a -> Bool
/= SessionSeq
sseq -> RemoteHostError -> STM (Either ChatError ())
forall {b}. RemoteHostError -> STM (Either ChatError b)
err RemoteHostError
RHEBadState
        | Bool
otherwise -> do
            RHKey -> TMap RHKey (SessionSeq, RemoteHostSession) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RHKey
RHNew TMap RHKey (SessionSeq, RemoteHostSession)
sessions
            RHKey
-> (SessionSeq, RemoteHostSession)
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert (RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId) (SessionSeq, RemoteHostSession)
sess TMap RHKey (SessionSeq, RemoteHostSession)
sessions
            Either ChatError () -> STM (Either ChatError ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError () -> STM (Either ChatError ()))
-> Either ChatError () -> STM (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ChatError ()
forall a b. b -> Either a b
Right ()
  where
    err :: RemoteHostError -> STM (Either ChatError b)
err = Either ChatError b -> STM (Either ChatError b)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError b -> STM (Either ChatError b))
-> (RemoteHostError -> Either ChatError b)
-> RemoteHostError
-> STM (Either ChatError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError b
forall a b. a -> Either a b
Left (ChatError -> Either ChatError b)
-> (RemoteHostError -> ChatError)
-> RemoteHostError
-> Either ChatError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
RHNew

startRemoteHost :: Maybe (RemoteHostId, Bool) -> Maybe RCCtrlAddress -> Maybe Word16 -> CM (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
startRemoteHost :: Maybe (RemoteCtrlId, Bool)
-> Maybe RCCtrlAddress
-> Maybe Word16
-> CM
     (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
startRemoteHost Maybe (RemoteCtrlId, Bool)
rh_ Maybe RCCtrlAddress
rcAddrPrefs_ Maybe Word16
port_ = do
  (RHKey
rhKey, Bool
multicast, Maybe RemoteHostInfo
remoteHost_, RCHostPairing
pairing) <- case Maybe (RemoteCtrlId, Bool)
rh_ of
    Just (RemoteCtrlId
rhId, Bool
multicast) -> do
      rh :: RemoteHost
rh@RemoteHost {RCHostPairing
hostPairing :: RCHostPairing
hostPairing :: RemoteHost -> RCHostPairing
hostPairing} <- (Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost)
-> (Connection -> ExceptT StoreError IO RemoteHost)
-> CM RemoteHost
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteHost
getRemoteHost Connection
db RemoteCtrlId
rhId
      (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId, Bool
multicast, RemoteHostInfo -> Maybe RemoteHostInfo
forall a. a -> Maybe a
Just (RemoteHostInfo -> Maybe RemoteHostInfo)
-> RemoteHostInfo -> Maybe RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost
rh (Maybe RemoteHostSessionState -> RemoteHostInfo)
-> Maybe RemoteHostSessionState -> RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHostSessionState -> Maybe RemoteHostSessionState
forall a. a -> Maybe a
Just RemoteHostSessionState
RHSStarting, RCHostPairing
hostPairing) -- get from the database, start multicast if requested
    Maybe (RemoteCtrlId, Bool)
Nothing -> ReaderT
  ChatController
  IO
  (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT
   ChatController
   IO
   (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> ((AgentClient
     -> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
    -> ReaderT
         ChatController
         IO
         (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> (AgentClient
    -> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgentClient
 -> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> ReaderT
     ChatController
     IO
     (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall a. (AgentClient -> IO a) -> CM' a
withAgent' ((AgentClient
  -> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> (AgentClient
    -> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> (RHKey
RHNew,Bool
False,Maybe RemoteHostInfo
forall a. Maybe a
Nothing,) (RCHostPairing
 -> (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing))
-> IO RCHostPairing
-> IO (RHKey, Bool, Maybe RemoteHostInfo, RCHostPairing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> IO RCHostPairing
rcNewHostPairing AgentClient
a
  SessionSeq
sseq <- RHKey -> CM SessionSeq
startRemoteHostSession RHKey
rhKey
  CtrlAppInfo
ctrlAppInfo <- ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
mkCtrlAppInfo
  (NonEmpty RCCtrlAddress
localAddrs, RCSignedInvitation
invitation, RCHostClient
rchClient, RCStepTMVar
  (ByteString, TLS 'TServer,
   RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
vars) <- RHKey
-> SessionSeq
-> CM
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> CM
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
forall a. RHKey -> SessionSeq -> CM a -> CM a
handleConnectError RHKey
rhKey SessionSeq
sseq (CM
   (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
    RCStepTMVar
      (ByteString, TLS 'TServer,
       RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
 -> CM
      (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
       RCStepTMVar
         (ByteString, TLS 'TServer,
          RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> ((AgentClient
     -> ExceptT
          AgentErrorType
          IO
          (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
           RCStepTMVar
             (ByteString, TLS 'TServer,
              RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
    -> CM
         (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
          RCStepTMVar
            (ByteString, TLS 'TServer,
             RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> (AgentClient
    -> ExceptT
         AgentErrorType
         IO
         (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
          RCStepTMVar
            (ByteString, TLS 'TServer,
             RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> CM
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgentClient
 -> ExceptT
      AgentErrorType
      IO
      (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
       RCStepTMVar
         (ByteString, TLS 'TServer,
          RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> CM
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient
  -> ExceptT
       AgentErrorType
       IO
       (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
        RCStepTMVar
          (ByteString, TLS 'TServer,
           RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
 -> CM
      (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
       RCStepTMVar
         (ByteString, TLS 'TServer,
          RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> (AgentClient
    -> ExceptT
         AgentErrorType
         IO
         (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
          RCStepTMVar
            (ByteString, TLS 'TServer,
             RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
-> CM
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> RCHostPairing
-> Value
-> Bool
-> Maybe RCCtrlAddress
-> Maybe Word16
-> ExceptT
     AgentErrorType
     IO
     (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient,
      RCStepTMVar
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
rcConnectHost AgentClient
a RCHostPairing
pairing (CtrlAppInfo -> Value
forall a. ToJSON a => a -> Value
J.toJSON CtrlAppInfo
ctrlAppInfo) Bool
multicast Maybe RCCtrlAddress
rcAddrPrefs_ Maybe Word16
port_
  let rcAddr_ :: Maybe RCCtrlAddress
rcAddr_ = NonEmpty RCCtrlAddress -> RCCtrlAddress
forall a. NonEmpty a -> a
L.head NonEmpty RCCtrlAddress
localAddrs RCCtrlAddress -> Maybe RCCtrlAddress -> Maybe RCCtrlAddress
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe RCCtrlAddress
rcAddrPrefs_
  TMVar ()
cmdOk <- ExceptT ChatError (ReaderT ChatController IO) (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  Async ()
rhsWaitSession <- CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> CM ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a b. (a -> b) -> a -> b
$ do
    TVar RHKey
rhKeyVar <- RHKey -> ExceptT ChatError (ReaderT ChatController IO) (TVar RHKey)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO RHKey
rhKey
    STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
cmdOk
    SessionSeq -> TVar RHKey -> CM () -> CM ()
handleHostError SessionSeq
sseq TVar RHKey
rhKeyVar (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe RemoteHostInfo
-> RHKey
-> SessionSeq
-> Maybe RCCtrlAddress
-> TVar RHKey
-> RCStepTMVar
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> CM ()
waitForHostSession Maybe RemoteHostInfo
remoteHost_ RHKey
rhKey SessionSeq
sseq Maybe RCCtrlAddress
rcAddr_ TVar RHKey
rhKeyVar RCStepTMVar
  (ByteString, TLS 'TServer,
   RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
vars
  let rhs :: RHPendingSession
rhs = RHPendingSession {RHKey
rhKey :: RHKey
rhKey :: RHKey
rhKey, RCHostClient
rchClient :: RCHostClient
rchClient :: RCHostClient
rchClient, Async ()
rhsWaitSession :: Async ()
rhsWaitSession :: Async ()
rhsWaitSession, Maybe RemoteHostInfo
remoteHost_ :: Maybe RemoteHostInfo
remoteHost_ :: Maybe RemoteHostInfo
remoteHost_}
  RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a.
RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError (a, RemoteHostSession))
-> CM a
withRemoteHostSession RHKey
rhKey SessionSeq
sseq ((RemoteHostSession -> Either ChatError ((), RemoteHostSession))
 -> CM ())
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
    RemoteHostSession
RHSessionStarting ->
      let inv :: Text
inv = ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ RCSignedInvitation -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode RCSignedInvitation
invitation
       in ((), RemoteHostSession) -> Either ChatError ((), RemoteHostSession)
forall a b. b -> Either a b
Right ((), Text -> RHPendingSession -> RemoteHostSession
RHSessionConnecting Text
inv RHPendingSession
rhs)
    RemoteHostSession
_ -> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. a -> Either a b
Left (ChatError -> Either ChatError ((), RemoteHostSession))
-> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
  (NonEmpty RCCtrlAddress
localAddrs, Maybe RemoteHostInfo
remoteHost_, RCSignedInvitation
invitation) (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
-> CM ()
-> CM
     (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
cmdOk ())
  where
    mkCtrlAppInfo :: ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
mkCtrlAppInfo = do
      Text
deviceName <- (ChatController -> TVar Text) -> CM Text
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar Text
localDeviceName
      CtrlAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CtrlAppInfo {appVersionRange :: AppVersionRange
appVersionRange = AppVersionRange
ctrlAppVersionRange, Text
deviceName :: Text
deviceName :: Text
deviceName}
    parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo
    parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo
parseHostAppInfo RCHostHello {app :: RCHostHello -> Value
app = Value
hostAppInfo} = do
      hostInfo :: HostAppInfo
hostInfo@HostAppInfo {AppVersion
appVersion :: AppVersion
appVersion :: HostAppInfo -> AppVersion
appVersion, PlatformEncoding
encoding :: PlatformEncoding
encoding :: HostAppInfo -> PlatformEncoding
encoding} <-
        (FilePath -> RemoteHostError)
-> Either FilePath HostAppInfo
-> ExceptT RemoteHostError IO HostAppInfo
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RemoteProtocolError -> RemoteHostError
RHEProtocolError (RemoteProtocolError -> RemoteHostError)
-> (FilePath -> RemoteProtocolError) -> FilePath -> RemoteHostError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> RemoteProtocolError
RPEInvalidJSON) (Either FilePath HostAppInfo
 -> ExceptT RemoteHostError IO HostAppInfo)
-> Either FilePath HostAppInfo
-> ExceptT RemoteHostError IO HostAppInfo
forall a b. (a -> b) -> a -> b
$ (Value -> Parser HostAppInfo)
-> Value -> Either FilePath HostAppInfo
forall a b. (a -> Parser b) -> a -> Either FilePath b
JT.parseEither Value -> Parser HostAppInfo
forall a. FromJSON a => Value -> Parser a
J.parseJSON Value
hostAppInfo
      Bool
-> ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AppVersion -> AppVersionRange -> Bool
isAppCompatible AppVersion
appVersion AppVersionRange
ctrlAppVersionRange) (ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ())
-> ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteHostError -> ExceptT RemoteHostError IO ()
forall a. RemoteHostError -> ExceptT RemoteHostError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RemoteHostError -> ExceptT RemoteHostError IO ())
-> RemoteHostError -> ExceptT RemoteHostError IO ()
forall a b. (a -> b) -> a -> b
$ AppVersion -> RemoteHostError
RHEBadVersion AppVersion
appVersion
      Bool
-> ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PlatformEncoding
encoding PlatformEncoding -> PlatformEncoding -> Bool
forall a. Eq a => a -> a -> Bool
== PlatformEncoding
PEKotlin Bool -> Bool -> Bool
&& PlatformEncoding
localEncoding PlatformEncoding -> PlatformEncoding -> Bool
forall a. Eq a => a -> a -> Bool
== PlatformEncoding
PESwift) (ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ())
-> ExceptT RemoteHostError IO () -> ExceptT RemoteHostError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteHostError -> ExceptT RemoteHostError IO ()
forall a. RemoteHostError -> ExceptT RemoteHostError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RemoteHostError -> ExceptT RemoteHostError IO ())
-> RemoteHostError -> ExceptT RemoteHostError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> RemoteHostError
RHEProtocolError RemoteProtocolError
RPEIncompatibleEncoding
      HostAppInfo -> ExceptT RemoteHostError IO HostAppInfo
forall a. a -> ExceptT RemoteHostError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HostAppInfo
hostInfo
    handleConnectError :: RHKey -> SessionSeq -> CM a -> CM a
    handleConnectError :: forall a. RHKey -> SessionSeq -> CM a -> CM a
handleConnectError RHKey
rhKey SessionSeq
sessSeq CM a
action =
      CM a
action CM a -> (ChatError -> CM a) -> CM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
err -> do
        Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"startRemoteHost.rcConnectHost crashed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
err
        Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession ((SessionSeq, RemoteHostStopReason)
-> Maybe (SessionSeq, RemoteHostStopReason)
forall a. a -> Maybe a
Just (SessionSeq
sessSeq, ChatError -> RemoteHostStopReason
RHSRConnectionFailed ChatError
err)) RHKey
rhKey
        ChatError -> CM a
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
err
    handleHostError :: SessionSeq -> TVar RHKey -> CM () -> CM ()
    handleHostError :: SessionSeq -> TVar RHKey -> CM () -> CM ()
handleHostError SessionSeq
sessSeq TVar RHKey
rhKeyVar CM ()
action =
      CM ()
action CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
err -> do
        Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"startRemoteHost.waitForHostSession crashed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
err
        TVar RHKey -> ExceptT ChatError (ReaderT ChatController IO) RHKey
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar RHKey
rhKeyVar ExceptT ChatError (ReaderT ChatController IO) RHKey
-> (RHKey -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession ((SessionSeq, RemoteHostStopReason)
-> Maybe (SessionSeq, RemoteHostStopReason)
forall a. a -> Maybe a
Just (SessionSeq
sessSeq, ChatError -> RemoteHostStopReason
RHSRCrashed ChatError
err))
    waitForHostSession :: Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> CM ()
    waitForHostSession :: Maybe RemoteHostInfo
-> RHKey
-> SessionSeq
-> Maybe RCCtrlAddress
-> TVar RHKey
-> RCStepTMVar
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> CM ()
waitForHostSession Maybe RemoteHostInfo
remoteHost_ RHKey
rhKey SessionSeq
sseq Maybe RCCtrlAddress
rcAddr_ TVar RHKey
rhKeyVar RCStepTMVar
  (ByteString, TLS 'TServer,
   RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
vars = do
      (ByteString
sessId, TLS 'TServer
tls, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
vars') <- ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHETimeout) SessionSeq
60000000 (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (ByteString, TLS 'TServer,
    RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (ByteString, TLS 'TServer,
       RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
forall a b. (a -> b) -> a -> b
$ RCStepTMVar
  (ByteString, TLS 'TServer,
   RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
forall a. RCStepTMVar a -> CM a
takeRCStep RCStepTMVar
  (ByteString, TLS 'TServer,
   RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
vars
      let sessionCode :: Text
sessionCode = ByteString -> Text
verificationCode ByteString
sessId
      RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a.
RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError (a, RemoteHostSession))
-> CM a
withRemoteHostSession RHKey
rhKey SessionSeq
sseq ((RemoteHostSession -> Either ChatError ((), RemoteHostSession))
 -> CM ())
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
        RHSessionConnecting Text
_inv RHPendingSession
rhs' -> ((), RemoteHostSession) -> Either ChatError ((), RemoteHostSession)
forall a b. b -> Either a b
Right ((), Text -> TLS 'TServer -> RHPendingSession -> RemoteHostSession
RHSessionPendingConfirmation Text
sessionCode TLS 'TServer
tls RHPendingSession
rhs')
        RemoteHostSession
_ -> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. a -> Either a b
Left (ChatError -> Either ChatError ((), RemoteHostSession))
-> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
      let rh_' :: Maybe RemoteHostInfo
rh_' = (\RemoteHostInfo
rh -> (RemoteHostInfo
rh :: RemoteHostInfo) {sessionState = Just RHSPendingConfirmation {sessionCode}}) (RemoteHostInfo -> RemoteHostInfo)
-> Maybe RemoteHostInfo -> Maybe RemoteHostInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteHostInfo
remoteHost_
      ChatEvent -> CM ()
toView CEvtRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo
remoteHost_ = Maybe RemoteHostInfo
rh_', Text
sessionCode :: Text
sessionCode :: Text
sessionCode}
      (RCHostSession {HostSessKeys
sessionKeys :: HostSessKeys
sessionKeys :: RCHostSession -> HostSessKeys
sessionKeys}, RCHostHello
rhHello, RCHostPairing
pairing') <- ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCHostSession, RCHostHello, RCHostPairing)
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHETimeout) SessionSeq
60000000 (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (RCHostSession, RCHostHello, RCHostPairing)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCHostSession, RCHostHello, RCHostPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCHostSession, RCHostHello, RCHostPairing)
forall a b. (a -> b) -> a -> b
$ RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCHostSession, RCHostHello, RCHostPairing)
forall a. RCStepTMVar a -> CM a
takeRCStep RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
vars'
      hostInfo :: HostAppInfo
hostInfo@HostAppInfo {deviceName :: HostAppInfo -> Text
deviceName = Text
hostDeviceName} <-
        (RemoteHostError -> ChatError)
-> ExceptT RemoteHostError IO HostAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey) (ExceptT RemoteHostError IO HostAppInfo
 -> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo)
-> ExceptT RemoteHostError IO HostAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo
forall a b. (a -> b) -> a -> b
$ RCHostHello -> ExceptT RemoteHostError IO HostAppInfo
parseHostAppInfo RCHostHello
rhHello
      RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a.
RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError (a, RemoteHostSession))
-> CM a
withRemoteHostSession RHKey
rhKey SessionSeq
sseq ((RemoteHostSession -> Either ChatError ((), RemoteHostSession))
 -> CM ())
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
        RHSessionPendingConfirmation Text
_ TLS 'TServer
tls' RHPendingSession
rhs' -> ((), RemoteHostSession) -> Either ChatError ((), RemoteHostSession)
forall a b. b -> Either a b
Right ((), TLS 'TServer -> RHPendingSession -> RemoteHostSession
RHSessionConfirmed TLS 'TServer
tls' RHPendingSession
rhs')
        RemoteHostSession
_ -> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. a -> Either a b
Left (ChatError -> Either ChatError ((), RemoteHostSession))
-> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
      rhi :: RemoteHostInfo
rhi@RemoteHostInfo {RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId :: RemoteHostInfo -> RemoteCtrlId
remoteHostId, FilePath
storePath :: FilePath
storePath :: RemoteHostInfo -> FilePath
storePath} <- RCHostPairing
-> Maybe RemoteHostInfo
-> Maybe RCCtrlAddress
-> Text
-> SessionSeq
-> RemoteHostSessionState
-> CM RemoteHostInfo
upsertRemoteHost RCHostPairing
pairing' Maybe RemoteHostInfo
rh_' Maybe RCCtrlAddress
rcAddr_ Text
hostDeviceName SessionSeq
sseq RHSConfirmed {Text
sessionCode :: Text
sessionCode :: Text
sessionCode}
      let rhKey' :: RHKey
rhKey' = RemoteCtrlId -> RHKey
RHId RemoteCtrlId
remoteHostId -- rhKey may be invalid after upserting on RHNew
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RHKey
rhKey' RHKey -> RHKey -> Bool
forall a. Eq a => a -> a -> Bool
/= RHKey
rhKey) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TVar RHKey -> RHKey -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar RHKey
rhKeyVar RHKey
rhKey'
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteHostInfo -> ChatEvent
CEvtNewRemoteHost RemoteHostInfo
rhi
      -- set up HTTP transport and remote profile protocol
      IO ()
disconnected <- CM () -> ExceptT ChatError (ReaderT ChatController IO) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (CM () -> ExceptT ChatError (ReaderT ChatController IO) (IO ()))
-> CM () -> ExceptT ChatError (ReaderT ChatController IO) (IO ())
forall a b. (a -> b) -> a -> b
$ RHKey -> SessionSeq -> CM ()
onDisconnected RHKey
rhKey' SessionSeq
sseq
      HTTP2Client
httpClient <- (HTTP2ClientError -> ChatError)
-> IO (Either HTTP2ClientError HTTP2Client)
-> ExceptT ChatError (ReaderT ChatController IO) HTTP2Client
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' (RemoteCtrlId -> HTTP2ClientError -> ChatError
httpError RemoteCtrlId
remoteHostId) (IO (Either HTTP2ClientError HTTP2Client)
 -> ExceptT ChatError (ReaderT ChatController IO) HTTP2Client)
-> IO (Either HTTP2ClientError HTTP2Client)
-> ExceptT ChatError (ReaderT ChatController IO) HTTP2Client
forall a b. (a -> b) -> a -> b
$ IO () -> TLS 'TServer -> IO (Either HTTP2ClientError HTTP2Client)
attachRevHTTP2Client IO ()
disconnected TLS 'TServer
tls
      RemoteHostClient
rhClient <- HTTP2Client
-> HostSessKeys
-> ByteString
-> FilePath
-> HostAppInfo
-> CM RemoteHostClient
mkRemoteHostClient HTTP2Client
httpClient HostSessKeys
sessionKeys ByteString
sessId FilePath
storePath HostAppInfo
hostInfo
      Async ()
pollAction <- CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> CM ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a b. (a -> b) -> a -> b
$ RemoteCtrlId -> RemoteHostClient -> CM ()
pollEvents RemoteCtrlId
remoteHostId RemoteHostClient
rhClient
      RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a.
RHKey
-> SessionSeq
-> (RemoteHostSession -> Either ChatError (a, RemoteHostSession))
-> CM a
withRemoteHostSession RHKey
rhKey' SessionSeq
sseq ((RemoteHostSession -> Either ChatError ((), RemoteHostSession))
 -> CM ())
-> (RemoteHostSession -> Either ChatError ((), RemoteHostSession))
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
        RHSessionConfirmed TLS 'TServer
_ RHPendingSession {RCHostClient
rchClient :: RHPendingSession -> RCHostClient
rchClient :: RCHostClient
rchClient} -> ((), RemoteHostSession) -> Either ChatError ((), RemoteHostSession)
forall a b. b -> Either a b
Right ((), RHSessionConnected {RCHostClient
rchClient :: RCHostClient
rchClient :: RCHostClient
rchClient, TLS 'TServer
tls :: TLS 'TServer
tls :: TLS 'TServer
tls, RemoteHostClient
rhClient :: RemoteHostClient
rhClient :: RemoteHostClient
rhClient, Async ()
pollAction :: Async ()
pollAction :: Async ()
pollAction, FilePath
storePath :: FilePath
storePath :: FilePath
storePath})
        RemoteHostSession
_ -> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. a -> Either a b
Left (ChatError -> Either ChatError ((), RemoteHostSession))
-> ChatError -> Either ChatError ((), RemoteHostSession)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBadState
      (ChatController -> TVar (Maybe RemoteCtrlId))
-> Maybe RemoteCtrlId -> CM ()
forall a. (ChatController -> TVar a) -> a -> CM ()
chatWriteVar ChatController -> TVar (Maybe RemoteCtrlId)
currentRemoteHost (Maybe RemoteCtrlId -> CM ()) -> Maybe RemoteCtrlId -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
remoteHostId -- this is required for commands to be passed to remote host
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteHostInfo -> ChatEvent
CEvtRemoteHostConnected RemoteHostInfo
rhi {sessionState = Just RHSConnected {sessionCode}}
    upsertRemoteHost :: RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> CM RemoteHostInfo
    upsertRemoteHost :: RCHostPairing
-> Maybe RemoteHostInfo
-> Maybe RCCtrlAddress
-> Text
-> SessionSeq
-> RemoteHostSessionState
-> CM RemoteHostInfo
upsertRemoteHost pairing' :: RCHostPairing
pairing'@RCHostPairing {knownHost :: RCHostPairing -> Maybe KnownHostPairing
knownHost = Maybe KnownHostPairing
kh_} Maybe RemoteHostInfo
rhi_ Maybe RCCtrlAddress
rcAddr_ Text
hostDeviceName SessionSeq
sseq RemoteHostSessionState
state = do
      KnownHostPairing {hostDhPubKey :: KnownHostPairing -> PublicKeyX25519
hostDhPubKey = PublicKeyX25519
hostDhPubKey'} <- ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
-> (KnownHostPairing
    -> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing)
-> Maybe KnownHostPairing
-> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChatError
-> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing)
-> (ChatErrorType -> ChatError)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatErrorType -> ChatError
ChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
forall a b. (a -> b) -> a -> b
$ FilePath -> ChatErrorType
CEInternalError FilePath
"KnownHost is known after verification") KnownHostPairing
-> ExceptT ChatError (ReaderT ChatController IO) KnownHostPairing
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe KnownHostPairing
kh_
      case Maybe RemoteHostInfo
rhi_ of
        Maybe RemoteHostInfo
Nothing -> do
          FilePath
storePath <- IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
randomStorePath
          rh :: RemoteHost
rh@RemoteHost {RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId :: RemoteHost -> RemoteCtrlId
remoteHostId} <- (Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost)
-> (Connection -> ExceptT StoreError IO RemoteHost)
-> CM RemoteHost
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> Text
-> FilePath
-> Maybe RCCtrlAddress
-> Maybe Word16
-> RCHostPairing
-> ExceptT StoreError IO RemoteCtrlId
insertRemoteHost Connection
db Text
hostDeviceName FilePath
storePath Maybe RCCtrlAddress
rcAddr_ Maybe Word16
port_ RCHostPairing
pairing' ExceptT StoreError IO RemoteCtrlId
-> (RemoteCtrlId -> ExceptT StoreError IO RemoteHost)
-> ExceptT StoreError IO RemoteHost
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteHost
getRemoteHost Connection
db
          SessionSeq -> RemoteCtrlId -> CM ()
setNewRemoteHostId SessionSeq
sseq RemoteCtrlId
remoteHostId
          RemoteHostInfo -> CM RemoteHostInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteHostInfo -> CM RemoteHostInfo)
-> RemoteHostInfo -> CM RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost
rh (Maybe RemoteHostSessionState -> RemoteHostInfo)
-> Maybe RemoteHostSessionState -> RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHostSessionState -> Maybe RemoteHostSessionState
forall a. a -> Maybe a
Just RemoteHostSessionState
state
        Just rhi :: RemoteHostInfo
rhi@RemoteHostInfo {RemoteCtrlId
remoteHostId :: RemoteHostInfo -> RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId} -> do
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> RemoteCtrlId
-> Text
-> PublicKeyX25519
-> Maybe RCCtrlAddress
-> Maybe Word16
-> IO ()
updateHostPairing Connection
db RemoteCtrlId
remoteHostId Text
hostDeviceName PublicKeyX25519
hostDhPubKey' Maybe RCCtrlAddress
rcAddr_ Maybe Word16
port_
          RemoteHostInfo -> CM RemoteHostInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteHostInfo
rhi :: RemoteHostInfo) {sessionState = Just state}
    onDisconnected :: RHKey -> SessionSeq -> CM ()
    onDisconnected :: RHKey -> SessionSeq -> CM ()
onDisconnected RHKey
rhKey SessionSeq
sseq = do
      Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"HTTP2 client disconnected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (RHKey, SessionSeq) -> Text
forall a. Show a => a -> Text
tshow (RHKey
rhKey, SessionSeq
sseq)
      Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession ((SessionSeq, RemoteHostStopReason)
-> Maybe (SessionSeq, RemoteHostStopReason)
forall a. a -> Maybe a
Just (SessionSeq
sseq, RemoteHostStopReason
RHSRDisconnected)) RHKey
rhKey
    pollEvents :: RemoteHostId -> RemoteHostClient -> CM ()
    pollEvents :: RemoteCtrlId -> RemoteHostClient -> CM ()
pollEvents RemoteCtrlId
rhId RemoteHostClient
rhClient = do
      TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
oq <- (ChatController
 -> TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController
-> TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
outputQ
      CM () -> CM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
        TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
-> CM () -> CM ()
handlePollError TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
oq (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
          Maybe (Either ChatError ChatEvent)
r_ <- RemoteCtrlId
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
-> CM (Maybe (Either ChatError ChatEvent))
forall a. RemoteCtrlId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH RemoteCtrlId
rhId (ExceptT
   RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
 -> CM (Maybe (Either ChatError ChatEvent)))
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
-> CM (Maybe (Either ChatError ChatEvent))
forall a b. (a -> b) -> a -> b
$ RemoteHostClient
-> SessionSeq
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
remoteRecv RemoteHostClient
rhClient SessionSeq
10000000
          Maybe (Either ChatError ChatEvent)
-> (Either ChatError ChatEvent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Either ChatError ChatEvent)
r_ ((Either ChatError ChatEvent -> CM ()) -> CM ())
-> (Either ChatError ChatEvent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Either ChatError ChatEvent
r -> STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
-> (Maybe RemoteCtrlId, Either ChatError ChatEvent) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
oq (RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
rhId, Either ChatError ChatEvent
r)
      where
        handlePollError :: TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
-> CM () -> CM ()
handlePollError TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
oq CM ()
a = CM ()
a CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e ->
          STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
-> (Maybe RemoteCtrlId, Either ChatError ChatEvent) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe RemoteCtrlId, Either ChatError ChatEvent)
oq (RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
rhId, ChatError -> Either ChatError ChatEvent
forall a b. a -> Either a b
Left ChatError
e)
    httpError :: RemoteHostId -> HTTP2ClientError -> ChatError
    httpError :: RemoteCtrlId -> HTTP2ClientError -> ChatError
httpError RemoteCtrlId
rhId = RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost (RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId) (RemoteHostError -> ChatError)
-> (HTTP2ClientError -> RemoteHostError)
-> HTTP2ClientError
-> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteProtocolError -> RemoteHostError
RHEProtocolError (RemoteProtocolError -> RemoteHostError)
-> (HTTP2ClientError -> RemoteProtocolError)
-> HTTP2ClientError
-> RemoteHostError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RemoteProtocolError
RPEHTTP2 (Text -> RemoteProtocolError)
-> (HTTP2ClientError -> Text)
-> HTTP2ClientError
-> RemoteProtocolError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTTP2ClientError -> Text
forall a. Show a => a -> Text
tshow

startRemoteHostSession :: RHKey -> CM SessionSeq
startRemoteHostSession :: RHKey -> CM SessionSeq
startRemoteHostSession RHKey
rhKey = do
  TMap RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap RHKey (SessionSeq, RemoteHostSession))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  TVar SessionSeq
nextSessionSeq <- (ChatController -> TVar SessionSeq)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar SessionSeq)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar SessionSeq
remoteSessionSeq
  IO (Either ChatError SessionSeq) -> CM SessionSeq
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either ChatError SessionSeq) -> CM SessionSeq)
-> (STM (Either ChatError SessionSeq)
    -> IO (Either ChatError SessionSeq))
-> STM (Either ChatError SessionSeq)
-> CM SessionSeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either ChatError SessionSeq)
-> IO (Either ChatError SessionSeq)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError SessionSeq) -> CM SessionSeq)
-> STM (Either ChatError SessionSeq) -> CM SessionSeq
forall a b. (a -> b) -> a -> b
$
    RHKey
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM (Maybe (SessionSeq, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RHKey
rhKey TMap RHKey (SessionSeq, RemoteHostSession)
sessions STM (Maybe (SessionSeq, RemoteHostSession))
-> (Maybe (SessionSeq, RemoteHostSession)
    -> STM (Either ChatError SessionSeq))
-> STM (Either ChatError SessionSeq)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (SessionSeq, RemoteHostSession)
_ -> Either ChatError SessionSeq -> STM (Either ChatError SessionSeq)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError SessionSeq -> STM (Either ChatError SessionSeq))
-> (ChatError -> Either ChatError SessionSeq)
-> ChatError
-> STM (Either ChatError SessionSeq)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError SessionSeq
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError SessionSeq))
-> ChatError -> STM (Either ChatError SessionSeq)
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEBusy
      Maybe (SessionSeq, RemoteHostSession)
Nothing -> do
        SessionSeq
sessionSeq <- TVar SessionSeq
-> (SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SessionSeq
nextSessionSeq ((SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq)
-> (SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq
forall a b. (a -> b) -> a -> b
$ \SessionSeq
s -> (SessionSeq
s, SessionSeq
s SessionSeq -> SessionSeq -> SessionSeq
forall a. Num a => a -> a -> a
+ SessionSeq
1)
        SessionSeq -> Either ChatError SessionSeq
forall a b. b -> Either a b
Right SessionSeq
sessionSeq Either ChatError SessionSeq
-> STM () -> STM (Either ChatError SessionSeq)
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RHKey
-> (SessionSeq, RemoteHostSession)
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RHKey
rhKey (SessionSeq
sessionSeq, RemoteHostSession
RHSessionStarting) TMap RHKey (SessionSeq, RemoteHostSession)
sessions

closeRemoteHost :: RHKey -> CM ()
closeRemoteHost :: RHKey -> CM ()
closeRemoteHost RHKey
rhKey = do
  Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"Closing remote host session for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RHKey -> Text
forall a. Show a => a -> Text
tshow RHKey
rhKey
  Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession Maybe (SessionSeq, RemoteHostStopReason)
forall a. Maybe a
Nothing RHKey
rhKey

cancelRemoteHostSession :: Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession :: Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM ()
cancelRemoteHostSession Maybe (SessionSeq, RemoteHostStopReason)
handlerInfo_ RHKey
rhKey = do
  TMap RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap RHKey (SessionSeq, RemoteHostSession))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  TVar (Maybe RemoteCtrlId)
crh <- (ChatController -> TVar (Maybe RemoteCtrlId))
-> ExceptT
     ChatError (ReaderT ChatController IO) (TVar (Maybe RemoteCtrlId))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe RemoteCtrlId)
currentRemoteHost
  Maybe RemoteHostSession
deregistered <-
    STM (Maybe RemoteHostSession)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe RemoteHostSession)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RemoteHostSession)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe RemoteHostSession))
-> STM (Maybe RemoteHostSession)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe RemoteHostSession)
forall a b. (a -> b) -> a -> b
$
      RHKey
-> TMap RHKey (SessionSeq, RemoteHostSession)
-> STM (Maybe (SessionSeq, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RHKey
rhKey TMap RHKey (SessionSeq, RemoteHostSession)
sessions STM (Maybe (SessionSeq, RemoteHostSession))
-> (Maybe (SessionSeq, RemoteHostSession)
    -> STM (Maybe RemoteHostSession))
-> STM (Maybe RemoteHostSession)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (SessionSeq, RemoteHostSession)
Nothing -> Maybe RemoteHostSession -> STM (Maybe RemoteHostSession)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteHostSession
forall a. Maybe a
Nothing
        Just (SessionSeq
sessSeq, RemoteHostSession
_) | Bool
-> ((SessionSeq, RemoteHostStopReason) -> Bool)
-> Maybe (SessionSeq, RemoteHostStopReason)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((SessionSeq
sessSeq SessionSeq -> SessionSeq -> Bool
forall a. Eq a => a -> a -> Bool
/=) (SessionSeq -> Bool)
-> ((SessionSeq, RemoteHostStopReason) -> SessionSeq)
-> (SessionSeq, RemoteHostStopReason)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionSeq, RemoteHostStopReason) -> SessionSeq
forall a b. (a, b) -> a
fst) Maybe (SessionSeq, RemoteHostStopReason)
handlerInfo_ -> Maybe RemoteHostSession -> STM (Maybe RemoteHostSession)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteHostSession
forall a. Maybe a
Nothing -- ignore cancel from a ghost session handler
        Just (SessionSeq
_, RemoteHostSession
rhs) -> do
          RHKey -> TMap RHKey (SessionSeq, RemoteHostSession) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RHKey
rhKey TMap RHKey (SessionSeq, RemoteHostSession)
sessions
          TVar (Maybe RemoteCtrlId)
-> (Maybe RemoteCtrlId -> Maybe RemoteCtrlId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Maybe RemoteCtrlId)
crh ((Maybe RemoteCtrlId -> Maybe RemoteCtrlId) -> STM ())
-> (Maybe RemoteCtrlId -> Maybe RemoteCtrlId) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Maybe RemoteCtrlId
cur -> if (RemoteCtrlId -> RHKey
RHId (RemoteCtrlId -> RHKey) -> Maybe RemoteCtrlId -> Maybe RHKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrlId
cur) Maybe RHKey -> Maybe RHKey -> Bool
forall a. Eq a => a -> a -> Bool
== RHKey -> Maybe RHKey
forall a. a -> Maybe a
Just RHKey
rhKey then Maybe RemoteCtrlId
forall a. Maybe a
Nothing else Maybe RemoteCtrlId
cur -- only wipe the closing RH
          Maybe RemoteHostSession -> STM (Maybe RemoteHostSession)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RemoteHostSession -> STM (Maybe RemoteHostSession))
-> Maybe RemoteHostSession -> STM (Maybe RemoteHostSession)
forall a b. (a -> b) -> a -> b
$ RemoteHostSession -> Maybe RemoteHostSession
forall a. a -> Maybe a
Just RemoteHostSession
rhs
  Maybe RemoteHostSession -> (RemoteHostSession -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe RemoteHostSession
deregistered ((RemoteHostSession -> CM ()) -> CM ())
-> (RemoteHostSession -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \RemoteHostSession
session -> do
    IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ Bool -> RemoteHostSession -> IO ()
cancelRemoteHost Bool
handlingError RemoteHostSession
session IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)
    Maybe RemoteHostStopReason
-> (RemoteHostStopReason -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((SessionSeq, RemoteHostStopReason) -> RemoteHostStopReason
forall a b. (a, b) -> b
snd ((SessionSeq, RemoteHostStopReason) -> RemoteHostStopReason)
-> Maybe (SessionSeq, RemoteHostStopReason)
-> Maybe RemoteHostStopReason
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SessionSeq, RemoteHostStopReason)
handlerInfo_) ((RemoteHostStopReason -> CM ()) -> CM ())
-> (RemoteHostStopReason -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \RemoteHostStopReason
rhStopReason ->
      ChatEvent -> CM ()
toView CEvtRemoteHostStopped {Maybe RemoteCtrlId
remoteHostId_ :: Maybe RemoteCtrlId
remoteHostId_ :: Maybe RemoteCtrlId
remoteHostId_, rhsState :: RemoteHostSessionState
rhsState = RemoteHostSession -> RemoteHostSessionState
rhsSessionState RemoteHostSession
session, RemoteHostStopReason
rhStopReason :: RemoteHostStopReason
rhStopReason :: RemoteHostStopReason
rhStopReason}
  where
    handlingError :: Bool
handlingError = Maybe (SessionSeq, RemoteHostStopReason) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SessionSeq, RemoteHostStopReason)
handlerInfo_
    remoteHostId_ :: Maybe RemoteCtrlId
remoteHostId_ = case RHKey
rhKey of
      RHKey
RHNew -> Maybe RemoteCtrlId
forall a. Maybe a
Nothing
      RHId RemoteCtrlId
rhId -> RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
rhId

cancelRemoteHost :: Bool -> RemoteHostSession -> IO ()
cancelRemoteHost :: Bool -> RemoteHostSession -> IO ()
cancelRemoteHost Bool
handlingError = \case
  RemoteHostSession
RHSessionStarting -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  RHSessionConnecting Text
_inv RHPendingSession
rhs -> RHPendingSession -> IO ()
cancelPendingSession RHPendingSession
rhs
  RHSessionPendingConfirmation Text
_sessCode TLS 'TServer
tls RHPendingSession
rhs -> do
    RHPendingSession -> IO ()
cancelPendingSession RHPendingSession
rhs
    TLS 'TServer -> IO ()
forall (p :: TransportPeer). TLS p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection TLS 'TServer
tls
  RHSessionConfirmed TLS 'TServer
tls RHPendingSession
rhs -> do
    RHPendingSession -> IO ()
cancelPendingSession RHPendingSession
rhs
    TLS 'TServer -> IO ()
forall (p :: TransportPeer). TLS p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection TLS 'TServer
tls
  RHSessionConnected {RCHostClient
rchClient :: RemoteHostSession -> RCHostClient
rchClient :: RCHostClient
rchClient, TLS 'TServer
tls :: RemoteHostSession -> TLS 'TServer
tls :: TLS 'TServer
tls, rhClient :: RemoteHostSession -> RemoteHostClient
rhClient = RemoteHostClient {HTTP2Client
httpClient :: HTTP2Client
httpClient :: RemoteHostClient -> HTTP2Client
httpClient}, Async ()
pollAction :: RemoteHostSession -> Async ()
pollAction :: Async ()
pollAction} -> do
    Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
pollAction
    RCHostClient -> IO ()
cancelHostClient RCHostClient
rchClient IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)
    TLS 'TServer -> IO ()
forall (p :: TransportPeer). TLS p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection TLS 'TServer
tls IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Client -> IO ()
closeHTTP2Client HTTP2Client
httpClient IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)
  where
    cancelPendingSession :: RHPendingSession -> IO ()
cancelPendingSession RHPendingSession {RCHostClient
rchClient :: RHPendingSession -> RCHostClient
rchClient :: RCHostClient
rchClient, Async ()
rhsWaitSession :: RHPendingSession -> Async ()
rhsWaitSession :: Async ()
rhsWaitSession} = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
rhsWaitSession IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)
      RCHostClient -> IO ()
cancelHostClient RCHostClient
rchClient IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow)

-- | Generate a random 16-char filepath without / in it by using base64url encoding.
randomStorePath :: IO FilePath
randomStorePath :: IO FilePath
randomStorePath = ByteString -> FilePath
B.unpack (ByteString -> FilePath)
-> (ByteString -> ByteString) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64U.encode (ByteString -> FilePath) -> IO ByteString -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SessionSeq -> IO ByteString
forall byteArray. ByteArray byteArray => SessionSeq -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
SessionSeq -> m byteArray
getRandomBytes SessionSeq
12

listRemoteHosts :: CM [RemoteHostInfo]
listRemoteHosts :: CM [RemoteHostInfo]
listRemoteHosts = do
  Map RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> CM (Map RHKey (SessionSeq, RemoteHostSession))
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
  (RemoteHost -> RemoteHostInfo) -> [RemoteHost] -> [RemoteHostInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Map RHKey (SessionSeq, RemoteHostSession)
-> RemoteHost -> RemoteHostInfo
forall {a}.
Map RHKey (a, RemoteHostSession) -> RemoteHost -> RemoteHostInfo
rhInfo Map RHKey (SessionSeq, RemoteHostSession)
sessions) ([RemoteHost] -> [RemoteHostInfo])
-> ExceptT ChatError (ReaderT ChatController IO) [RemoteHost]
-> CM [RemoteHostInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO [RemoteHost])
-> ExceptT ChatError (ReaderT ChatController IO) [RemoteHost]
forall a. (Connection -> IO a) -> CM a
withStore' Connection -> IO [RemoteHost]
getRemoteHosts
  where
    rhInfo :: Map RHKey (a, RemoteHostSession) -> RemoteHost -> RemoteHostInfo
rhInfo Map RHKey (a, RemoteHostSession)
sessions rh :: RemoteHost
rh@RemoteHost {RemoteCtrlId
remoteHostId :: RemoteHost -> RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId} =
      RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost
rh (Maybe RemoteHostSessionState -> RemoteHostInfo)
-> Maybe RemoteHostSessionState -> RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHostSession -> RemoteHostSessionState
rhsSessionState (RemoteHostSession -> RemoteHostSessionState)
-> ((a, RemoteHostSession) -> RemoteHostSession)
-> (a, RemoteHostSession)
-> RemoteHostSessionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, RemoteHostSession) -> RemoteHostSession
forall a b. (a, b) -> b
snd ((a, RemoteHostSession) -> RemoteHostSessionState)
-> Maybe (a, RemoteHostSession) -> Maybe RemoteHostSessionState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RHKey
-> Map RHKey (a, RemoteHostSession) -> Maybe (a, RemoteHostSession)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (RemoteCtrlId -> RHKey
RHId RemoteCtrlId
remoteHostId) Map RHKey (a, RemoteHostSession)
sessions

switchRemoteHost :: Maybe RemoteHostId -> CM (Maybe RemoteHostInfo)
switchRemoteHost :: Maybe RemoteCtrlId -> CM (Maybe RemoteHostInfo)
switchRemoteHost Maybe RemoteCtrlId
rhId_ = do
  Maybe RemoteHostInfo
rhi_ <- Maybe RemoteCtrlId
-> (RemoteCtrlId -> CM RemoteHostInfo) -> CM (Maybe RemoteHostInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe RemoteCtrlId
rhId_ ((RemoteCtrlId -> CM RemoteHostInfo) -> CM (Maybe RemoteHostInfo))
-> (RemoteCtrlId -> CM RemoteHostInfo) -> CM (Maybe RemoteHostInfo)
forall a b. (a -> b) -> a -> b
$ \RemoteCtrlId
rhId -> do
    let rhKey :: RHKey
rhKey = RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId
    RemoteHost
rh <- (Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteHost
`getRemoteHost` RemoteCtrlId
rhId)
    Map RHKey (SessionSeq, RemoteHostSession)
sessions <- (ChatController -> TMap RHKey (SessionSeq, RemoteHostSession))
-> CM (Map RHKey (SessionSeq, RemoteHostSession))
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TMap RHKey (SessionSeq, RemoteHostSession)
remoteHostSessions
    case RHKey
-> Map RHKey (SessionSeq, RemoteHostSession)
-> Maybe (SessionSeq, RemoteHostSession)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RHKey
rhKey Map RHKey (SessionSeq, RemoteHostSession)
sessions of
      Just (SessionSeq
_, RHSessionConnected {TLS 'TServer
tls :: RemoteHostSession -> TLS 'TServer
tls :: TLS 'TServer
tls}) -> RemoteHostInfo -> CM RemoteHostInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteHostInfo -> CM RemoteHostInfo)
-> RemoteHostInfo -> CM RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost
rh (Maybe RemoteHostSessionState -> RemoteHostInfo)
-> Maybe RemoteHostSessionState -> RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RemoteHostSessionState -> Maybe RemoteHostSessionState
forall a. a -> Maybe a
Just RHSConnected {sessionCode :: Text
sessionCode = TLS 'TServer -> Text
forall (p :: TransportPeer). TLS p -> Text
tlsSessionCode TLS 'TServer
tls}
      Maybe (SessionSeq, RemoteHostSession)
_ -> ChatError -> CM RemoteHostInfo
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM RemoteHostInfo) -> ChatError -> CM RemoteHostInfo
forall a b. (a -> b) -> a -> b
$ RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost RHKey
rhKey RemoteHostError
RHEInactive
  Maybe RemoteHostInfo
rhi_ Maybe RemoteHostInfo -> CM () -> CM (Maybe RemoteHostInfo)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ChatController -> TVar (Maybe RemoteCtrlId))
-> Maybe RemoteCtrlId -> CM ()
forall a. (ChatController -> TVar a) -> a -> CM ()
chatWriteVar ChatController -> TVar (Maybe RemoteCtrlId)
currentRemoteHost Maybe RemoteCtrlId
rhId_

remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost {RemoteCtrlId
remoteHostId :: RemoteHost -> RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId, FilePath
storePath :: FilePath
storePath :: RemoteHost -> FilePath
storePath, Text
hostDeviceName :: Text
hostDeviceName :: RemoteHost -> Text
hostDeviceName, Maybe RCCtrlAddress
bindAddress_ :: Maybe RCCtrlAddress
bindAddress_ :: RemoteHost -> Maybe RCCtrlAddress
bindAddress_, Maybe Word16
bindPort_ :: Maybe Word16
bindPort_ :: RemoteHost -> Maybe Word16
bindPort_} Maybe RemoteHostSessionState
sessionState =
  RemoteHostInfo {RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId, FilePath
storePath :: FilePath
storePath :: FilePath
storePath, Text
hostDeviceName :: Text
hostDeviceName :: Text
hostDeviceName, Maybe RCCtrlAddress
bindAddress_ :: Maybe RCCtrlAddress
bindAddress_ :: Maybe RCCtrlAddress
bindAddress_, Maybe Word16
bindPort_ :: Maybe Word16
bindPort_ :: Maybe Word16
bindPort_, Maybe RemoteHostSessionState
sessionState :: Maybe RemoteHostSessionState
sessionState :: Maybe RemoteHostSessionState
sessionState}

deleteRemoteHost :: RemoteHostId -> CM ()
deleteRemoteHost :: RemoteCtrlId -> CM ()
deleteRemoteHost RemoteCtrlId
rhId = do
  RemoteHost {FilePath
storePath :: RemoteHost -> FilePath
storePath :: FilePath
storePath} <- (Connection -> ExceptT StoreError IO RemoteHost) -> CM RemoteHost
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteHost
`getRemoteHost` RemoteCtrlId
rhId)
  (ChatController -> TVar (Maybe FilePath)) -> CM (Maybe FilePath)
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe FilePath)
remoteHostsFolder CM (Maybe FilePath) -> (Maybe FilePath -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
baseDir -> do
      let hostStore :: FilePath
hostStore = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
storePath
      Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"removing host store at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Show a => a -> Text
tshow FilePath
hostStore
      ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
hostStore) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CM ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
removeDirectoryRecursive FilePath
hostStore
    Maybe FilePath
Nothing -> Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"Local file store not available while deleting remote host"
  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> RemoteCtrlId -> IO ()
`deleteRemoteHostRecord` RemoteCtrlId
rhId)

storeRemoteFile :: RemoteHostId -> Maybe Bool -> FilePath -> CM CryptoFile
storeRemoteFile :: RemoteCtrlId -> Maybe Bool -> FilePath -> CM CryptoFile
storeRemoteFile RemoteCtrlId
rhId Maybe Bool
encrypted_ FilePath
localPath = do
  c :: RemoteHostClient
c@RemoteHostClient {Bool
encryptHostFiles :: Bool
encryptHostFiles :: RemoteHostClient -> Bool
encryptHostFiles, FilePath
storePath :: FilePath
storePath :: RemoteHostClient -> FilePath
storePath} <- RemoteCtrlId -> CM RemoteHostClient
getRemoteHostClient RemoteCtrlId
rhId
  let encrypt :: Bool
encrypt = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
encryptHostFiles Maybe Bool
encrypted_
  cf :: CryptoFile
cf@CryptoFile {FilePath
filePath :: FilePath
filePath :: CryptoFile -> FilePath
filePath} <- if Bool
encrypt then CM CryptoFile
encryptLocalFile else CryptoFile -> CM CryptoFile
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CryptoFile -> CM CryptoFile) -> CryptoFile -> CM CryptoFile
forall a b. (a -> b) -> a -> b
$ FilePath -> CryptoFile
CF.plain FilePath
localPath
  FilePath
filePath' <- RemoteCtrlId
-> ExceptT RemoteProtocolError IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a. RemoteCtrlId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH RemoteCtrlId
rhId (ExceptT RemoteProtocolError IO FilePath
 -> ExceptT ChatError (ReaderT ChatController IO) FilePath)
-> ExceptT RemoteProtocolError IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a b. (a -> b) -> a -> b
$ RemoteHostClient
-> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
remoteStoreFile RemoteHostClient
c FilePath
filePath (FilePath -> FilePath
takeFileName FilePath
localPath)
  Maybe FilePath
hf_ <- (ChatController -> TVar (Maybe FilePath)) -> CM (Maybe FilePath)
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe FilePath)
remoteHostsFolder
  Maybe FilePath -> (FilePath -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe FilePath
hf_ ((FilePath -> CM ()) -> CM ()) -> (FilePath -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
hf -> do
    let rhf :: FilePath
rhf = FilePath
hf FilePath -> FilePath -> FilePath
</> FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
remoteFilesFolder
        hPath :: FilePath
hPath = FilePath
rhf FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
filePath'
    Bool -> FilePath -> CM ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
rhf
    (if Bool
encrypt then FilePath -> FilePath -> CM ()
forall (m :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
renameFile else FilePath -> FilePath -> CM ()
forall (m :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
copyFile) FilePath
filePath FilePath
hPath
  CryptoFile -> CM CryptoFile
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CryptoFile
cf :: CryptoFile) {filePath = filePath'}
  where
    encryptLocalFile :: CM CryptoFile
    encryptLocalFile :: CM CryptoFile
encryptLocalFile = do
      FilePath
tmpDir <- ReaderT ChatController IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT ChatController IO FilePath
getChatTempDirectory
      Bool -> FilePath -> CM ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
tmpDir
      FilePath
tmpFile <- IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath
 -> ExceptT ChatError (ReaderT ChatController IO) FilePath)
-> IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
tmpDir FilePath -> FilePath -> IO FilePath
`uniqueCombine` FilePath -> FilePath
takeFileName FilePath
localPath
      CryptoFileArgs
cfArgs <- STM CryptoFileArgs
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CryptoFileArgs
 -> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs)
-> (TVar ChaChaDRG -> STM CryptoFileArgs)
-> TVar ChaChaDRG
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM CryptoFileArgs
CF.randomArgs (TVar ChaChaDRG
 -> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
      (FilePath -> ChatError) -> ExceptT FilePath IO () -> CM ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (FilePath -> ChatErrorType) -> FilePath -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> ChatErrorType
CEFileWrite FilePath
tmpFile) (ExceptT FilePath IO () -> CM ())
-> ExceptT FilePath IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> CryptoFileArgs -> ExceptT FilePath IO ()
encryptFile FilePath
localPath FilePath
tmpFile CryptoFileArgs
cfArgs
      CryptoFile -> CM CryptoFile
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CryptoFile -> CM CryptoFile) -> CryptoFile -> CM CryptoFile
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile FilePath
tmpFile (Maybe CryptoFileArgs -> CryptoFile)
-> Maybe CryptoFileArgs -> CryptoFile
forall a b. (a -> b) -> a -> b
$ CryptoFileArgs -> Maybe CryptoFileArgs
forall a. a -> Maybe a
Just CryptoFileArgs
cfArgs

getRemoteFile :: RemoteHostId -> RemoteFile -> CM ()
getRemoteFile :: RemoteCtrlId -> RemoteFile -> CM ()
getRemoteFile RemoteCtrlId
rhId RemoteFile
rf = do
  c :: RemoteHostClient
c@RemoteHostClient {FilePath
storePath :: RemoteHostClient -> FilePath
storePath :: FilePath
storePath} <- RemoteCtrlId -> CM RemoteHostClient
getRemoteHostClient RemoteCtrlId
rhId
  FilePath
dir <- ReaderT ChatController IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO FilePath
 -> ExceptT ChatError (ReaderT ChatController IO) FilePath)
-> ReaderT ChatController IO FilePath
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> FilePath
</> FilePath
storePath FilePath -> FilePath -> FilePath
</> FilePath
remoteFilesFolder) (FilePath -> FilePath)
-> ReaderT ChatController IO FilePath
-> ReaderT ChatController IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderT ChatController IO FilePath
-> (FilePath -> ReaderT ChatController IO FilePath)
-> Maybe FilePath
-> ReaderT ChatController IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReaderT ChatController IO FilePath
getDefaultFilesFolder FilePath -> ReaderT ChatController IO FilePath
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> ReaderT ChatController IO FilePath)
-> ReaderT ChatController IO (Maybe FilePath)
-> ReaderT ChatController IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar (Maybe FilePath))
-> ReaderT ChatController IO (Maybe FilePath)
forall a. (ChatController -> TVar a) -> CM' a
chatReadVar' ChatController -> TVar (Maybe FilePath)
remoteHostsFolder)
  Bool -> FilePath -> CM ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
dir
  RemoteCtrlId -> ExceptT RemoteProtocolError IO () -> CM ()
forall a. RemoteCtrlId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH RemoteCtrlId
rhId (ExceptT RemoteProtocolError IO () -> CM ())
-> ExceptT RemoteProtocolError IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteHostClient
-> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile RemoteHostClient
c FilePath
dir RemoteFile
rf

processRemoteCommand :: RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> Int -> CM ChatResponse
processRemoteCommand :: RemoteCtrlId
-> RemoteHostClient
-> ChatCommand
-> ByteString
-> SessionSeq
-> CM ChatResponse
processRemoteCommand RemoteCtrlId
remoteHostId RemoteHostClient
c ChatCommand
cmd ByteString
s SessionSeq
retryNum = case ChatCommand
cmd of
  SendFile ChatName
chatName CryptoFile
f -> ByteString -> ChatName -> CryptoFile -> CM ChatResponse
sendFile ByteString
"/f" ChatName
chatName CryptoFile
f
  SendImage ChatName
chatName CryptoFile
f -> ByteString -> ChatName -> CryptoFile -> CM ChatResponse
sendFile ByteString
"/img" ChatName
chatName CryptoFile
f
  ChatCommand
_ -> ByteString -> CM ChatResponse
chatRemoteSend ByteString
s
  where
    sendFile :: ByteString -> ChatName -> CryptoFile -> CM ChatResponse
sendFile ByteString
cmdName ChatName
chatName (CryptoFile FilePath
path Maybe CryptoFileArgs
cfArgs) = do
      -- don't encrypt in host if already encrypted locally
      CryptoFile FilePath
path' Maybe CryptoFileArgs
cfArgs' <- RemoteCtrlId -> Maybe Bool -> FilePath -> CM CryptoFile
storeRemoteFile RemoteCtrlId
remoteHostId (Maybe CryptoFileArgs
cfArgs Maybe CryptoFileArgs -> Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False) FilePath
path
      let f :: CryptoFile
f = FilePath -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile FilePath
path' (Maybe CryptoFileArgs
cfArgs Maybe CryptoFileArgs
-> Maybe CryptoFileArgs -> Maybe CryptoFileArgs
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CryptoFileArgs
cfArgs') -- use local or host encryption
      ByteString -> CM ChatResponse
chatRemoteSend (ByteString -> CM ChatResponse) -> ByteString -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unwords [ByteString
Item [ByteString]
cmdName, FilePath -> ByteString
B.pack (ChatName -> FilePath
chatNameStr ChatName
chatName), CryptoFile -> ByteString
cryptoFileStr CryptoFile
f]
    cryptoFileStr :: CryptoFile -> ByteString
cryptoFileStr CryptoFile {FilePath
filePath :: CryptoFile -> FilePath
filePath :: FilePath
filePath, Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs :: CryptoFile -> Maybe CryptoFileArgs
cryptoArgs} =
      ByteString
-> (CryptoFileArgs -> ByteString)
-> Maybe CryptoFileArgs
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (\(CFArgs SbKey
key CbNonce
nonce) -> ByteString
"key=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SbKey -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SbKey
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" nonce=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CbNonce -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode CbNonce
nonce ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ") Maybe CryptoFileArgs
cryptoArgs
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (FilePath -> Text
T.pack FilePath
filePath)
    chatRemoteSend :: ByteString -> CM ChatResponse
chatRemoteSend ByteString
cmd' = (ChatError -> CM ChatResponse)
-> (ChatResponse -> CM ChatResponse)
-> Either ChatError ChatResponse
-> CM ChatResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ChatError -> CM ChatResponse
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatResponse -> CM ChatResponse
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError ChatResponse -> CM ChatResponse)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either ChatError ChatResponse)
-> CM ChatResponse
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteCtrlId
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either ChatError ChatResponse)
forall a. RemoteCtrlId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH RemoteCtrlId
remoteHostId (RemoteHostClient
-> ByteString
-> SessionSeq
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
remoteSend RemoteHostClient
c ByteString
cmd' SessionSeq
retryNum)

liftRH :: RemoteHostId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH :: forall a. RemoteCtrlId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH RemoteCtrlId
rhId = (RemoteProtocolError -> ChatError)
-> ExceptT RemoteProtocolError IO a
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (RHKey -> RemoteHostError -> ChatError
ChatErrorRemoteHost (RemoteCtrlId -> RHKey
RHId RemoteCtrlId
rhId) (RemoteHostError -> ChatError)
-> (RemoteProtocolError -> RemoteHostError)
-> RemoteProtocolError
-> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteProtocolError -> RemoteHostError
RHEProtocolError)

-- * Mobile side

-- ** QR/link

-- | Use provided OOB link as an annouce
connectRemoteCtrlURI :: RCSignedInvitation -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrlURI :: RCSignedInvitation -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrlURI RCSignedInvitation
signedInv = do
  RCVerifiedInvitation
verifiedInv <- ExceptT ChatError (ReaderT ChatController IO) RCVerifiedInvitation
-> (RCVerifiedInvitation
    -> ExceptT
         ChatError (ReaderT ChatController IO) RCVerifiedInvitation)
-> Maybe RCVerifiedInvitation
-> ExceptT
     ChatError (ReaderT ChatController IO) RCVerifiedInvitation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) RCVerifiedInvitation
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT
      ChatError (ReaderT ChatController IO) RCVerifiedInvitation)
-> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) RCVerifiedInvitation
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadInvitation) RCVerifiedInvitation
-> ExceptT
     ChatError (ReaderT ChatController IO) RCVerifiedInvitation
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RCVerifiedInvitation
 -> ExceptT
      ChatError (ReaderT ChatController IO) RCVerifiedInvitation)
-> Maybe RCVerifiedInvitation
-> ExceptT
     ChatError (ReaderT ChatController IO) RCVerifiedInvitation
forall a b. (a -> b) -> a -> b
$ RCSignedInvitation -> Maybe RCVerifiedInvitation
verifySignedInvitation RCSignedInvitation
signedInv
  SessionSeq
sseq <- CM SessionSeq
startRemoteCtrlSession
  RCVerifiedInvitation
-> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrl RCVerifiedInvitation
verifiedInv SessionSeq
sseq

-- ** Multicast

findKnownRemoteCtrl :: CM ()
findKnownRemoteCtrl :: CM ()
findKnownRemoteCtrl = do
  [RemoteCtrl]
knownCtrls <- (Connection -> IO [RemoteCtrl]) -> CM [RemoteCtrl]
forall a. (Connection -> IO a) -> CM a
withStore' Connection -> IO [RemoteCtrl]
getRemoteCtrls
  NonEmpty RCCtrlPairing
pairings <- case [RemoteCtrl] -> Maybe (NonEmpty RemoteCtrl)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [RemoteCtrl]
knownCtrls of
    Maybe (NonEmpty RemoteCtrl)
Nothing -> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT
      ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing))
-> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing)
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCENoKnownControllers
    Just NonEmpty RemoteCtrl
ne -> NonEmpty RCCtrlPairing
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty RCCtrlPairing
 -> ExceptT
      ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing))
-> NonEmpty RCCtrlPairing
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty RCCtrlPairing)
forall a b. (a -> b) -> a -> b
$ (RemoteCtrl -> RCCtrlPairing)
-> NonEmpty RemoteCtrl -> NonEmpty RCCtrlPairing
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RemoteCtrl {RCCtrlPairing
ctrlPairing :: RCCtrlPairing
ctrlPairing :: RemoteCtrl -> RCCtrlPairing
ctrlPairing} -> RCCtrlPairing
ctrlPairing) NonEmpty RemoteCtrl
ne
  SessionSeq
sseq <- CM SessionSeq
startRemoteCtrlSession
  TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl <- ExceptT
  ChatError
  (ReaderT ChatController IO)
  (TMVar (RemoteCtrl, RCVerifiedInvitation))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar ()
cmdOk <- ExceptT ChatError (ReaderT ChatController IO) (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  Async ()
action <- CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> CM ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a b. (a -> b) -> a -> b
$ SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM () -> CM ()
forall a.
SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError SessionSeq
sseq ChatError -> RemoteCtrlStopReason
RCSRDiscoveryFailed Text
"findKnownRemoteCtrl.discover" (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
cmdOk
    (RCCtrlPairing {KeyHash
ctrlFingerprint :: KeyHash
ctrlFingerprint :: RCCtrlPairing -> KeyHash
ctrlFingerprint}, inv :: RCVerifiedInvitation
inv@(RCVerifiedInvitation RCInvitation {Value
app :: Value
app :: RCInvitation -> Value
app})) <-
      ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlPairing, RCVerifiedInvitation)
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCETimeout) SessionSeq
discoveryTimeout (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (RCCtrlPairing, RCVerifiedInvitation)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCCtrlPairing, RCVerifiedInvitation))
-> ((AgentClient
     -> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (RCCtrlPairing, RCVerifiedInvitation))
-> (AgentClient
    -> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlPairing, RCVerifiedInvitation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgentClient
 -> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlPairing, RCVerifiedInvitation)
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient
  -> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCCtrlPairing, RCVerifiedInvitation))
-> (AgentClient
    -> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlPairing, RCVerifiedInvitation)
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> NonEmpty RCCtrlPairing
-> ExceptT AgentErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
rcDiscoverCtrl AgentClient
a NonEmpty RCCtrlPairing
pairings
    Maybe CtrlAppInfo
ctrlAppInfo_ <- (CtrlAppInfo -> Maybe CtrlAppInfo
forall a. a -> Maybe a
Just (CtrlAppInfo -> Maybe CtrlAppInfo)
-> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
parseCtrlAppInfo Value
app) ExceptT ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
-> (ChatError
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ExceptT ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
-> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
forall a b. a -> b -> a
const (Maybe CtrlAppInfo
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe CtrlAppInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CtrlAppInfo
forall a. Maybe a
Nothing)
    RemoteCtrl
rc <-
      (Connection -> IO (Maybe RemoteCtrl)) -> CM (Maybe RemoteCtrl)
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> KeyHash -> IO (Maybe RemoteCtrl)
`getRemoteCtrlByFingerprint` KeyHash
ctrlFingerprint) CM (Maybe RemoteCtrl)
-> (Maybe RemoteCtrl
    -> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl)
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe RemoteCtrl
Nothing -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a b. (a -> b) -> a -> b
$ FilePath -> ChatErrorType
CEInternalError FilePath
"connecting with a stored ctrl"
        Just RemoteCtrl
rc -> RemoteCtrl
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteCtrl
rc
    STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar (RemoteCtrl, RCVerifiedInvitation)
-> (RemoteCtrl, RCVerifiedInvitation) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl (RemoteCtrl
rc, RCVerifiedInvitation
inv)
    let compatible :: Bool
compatible = Maybe (AppCompatible AppVersion) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AppCompatible AppVersion) -> Bool)
-> Maybe (AppCompatible AppVersion) -> Bool
forall a b. (a -> b) -> a -> b
$ AppVersionRange
-> AppVersionRange -> Maybe (AppCompatible AppVersion)
compatibleAppVersion AppVersionRange
hostAppVersionRange (AppVersionRange -> Maybe (AppCompatible AppVersion))
-> (CtrlAppInfo -> AppVersionRange)
-> CtrlAppInfo
-> Maybe (AppCompatible AppVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtrlAppInfo -> AppVersionRange
appVersionRange (CtrlAppInfo -> Maybe (AppCompatible AppVersion))
-> Maybe CtrlAppInfo -> Maybe (AppCompatible AppVersion)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe CtrlAppInfo
ctrlAppInfo_
    ChatEvent -> CM ()
toView CEvtRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo
remoteCtrl = RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl
rc (RemoteCtrlSessionState -> Maybe RemoteCtrlSessionState
forall a. a -> Maybe a
Just RemoteCtrlSessionState
RCSSearching), Maybe CtrlAppInfo
ctrlAppInfo_ :: Maybe CtrlAppInfo
ctrlAppInfo_ :: Maybe CtrlAppInfo
ctrlAppInfo_, appVersion :: AppVersion
appVersion = AppVersion
currentAppVersion, Bool
compatible :: Bool
compatible :: Bool
compatible}
  SessionSeq
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
updateRemoteCtrlSession SessionSeq
sseq ((RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
 -> CM ())
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
    RemoteCtrlSession
RCSessionStarting -> RemoteCtrlSession -> Either ChatError RemoteCtrlSession
forall a b. b -> Either a b
Right RCSessionSearching {Async ()
action :: Async ()
action :: Async ()
action, TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl :: TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl :: TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl}
    RemoteCtrlSession
_ -> ChatError -> Either ChatError RemoteCtrlSession
forall a b. a -> Either a b
Left (ChatError -> Either ChatError RemoteCtrlSession)
-> ChatError -> Either ChatError RemoteCtrlSession
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
  STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
cmdOk ()

confirmRemoteCtrl :: RemoteCtrlId -> CM (RemoteCtrlInfo, CtrlAppInfo)
confirmRemoteCtrl :: RemoteCtrlId -> CM (RemoteCtrlInfo, CtrlAppInfo)
confirmRemoteCtrl RemoteCtrlId
rcId = do
  TVar (Maybe (SessionSeq, RemoteCtrlSession))
session <- (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TVar (Maybe (SessionSeq, RemoteCtrlSession)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession
  (SessionSeq
sseq, Async ()
listener, TMVar (RemoteCtrl, RCVerifiedInvitation)
found) <- IO
  (Either
     ChatError
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO
   (Either
      ChatError
      (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> IO
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
forall a b. (a -> b) -> a -> b
$ STM
  (Either
     ChatError
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> IO
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM
   (Either
      ChatError
      (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
 -> IO
      (Either
         ChatError
         (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))))
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> IO
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a b. (a -> b) -> a -> b
$ do
    TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> STM (Maybe (SessionSeq, RemoteCtrlSession))
forall a. TVar a -> STM a
readTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session STM (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession)
    -> STM
         (Either
            ChatError
            (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))))
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (SessionSeq
sseq, RCSessionSearching {Async ()
action :: RemoteCtrlSession -> Async ()
action :: Async ()
action, TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl :: RemoteCtrlSession -> TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl :: TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl}) -> do
        TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> Maybe (SessionSeq, RemoteCtrlSession) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session (Maybe (SessionSeq, RemoteCtrlSession) -> STM ())
-> Maybe (SessionSeq, RemoteCtrlSession) -> STM ()
forall a b. (a -> b) -> a -> b
$ (SessionSeq, RemoteCtrlSession)
-> Maybe (SessionSeq, RemoteCtrlSession)
forall a. a -> Maybe a
Just (SessionSeq
sseq, RemoteCtrlSession
RCSessionStarting) -- drop intermediate "Searching" state so connectRemoteCtrl can proceed
        Either
  ChatError
  (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   ChatError
   (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
 -> STM
      (Either
         ChatError
         (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))))
-> Either
     ChatError
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a b. (a -> b) -> a -> b
$ (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
-> Either
     ChatError
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
forall a b. b -> Either a b
Right (SessionSeq
sseq, Async ()
action, TMVar (RemoteCtrl, RCVerifiedInvitation)
foundCtrl)
      Maybe (SessionSeq, RemoteCtrlSession)
_ -> Either
  ChatError
  (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   ChatError
   (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
 -> STM
      (Either
         ChatError
         (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))))
-> (ChatError
    -> Either
         ChatError
         (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
-> ChatError
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError
-> Either
     ChatError
     (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))
forall a b. a -> Either a b
Left (ChatError
 -> STM
      (Either
         ChatError
         (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation))))
-> ChatError
-> STM
     (Either
        ChatError
        (SessionSeq, Async (), TMVar (RemoteCtrl, RCVerifiedInvitation)))
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
  Async () -> CM ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
listener
  (RemoteCtrl {remoteCtrlId :: RemoteCtrl -> RemoteCtrlId
remoteCtrlId = RemoteCtrlId
foundRcId}, RCVerifiedInvitation
verifiedInv) <- STM (RemoteCtrl, RCVerifiedInvitation)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RemoteCtrl, RCVerifiedInvitation)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (RemoteCtrl, RCVerifiedInvitation)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RemoteCtrl, RCVerifiedInvitation))
-> STM (RemoteCtrl, RCVerifiedInvitation)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RemoteCtrl, RCVerifiedInvitation)
forall a b. (a -> b) -> a -> b
$ TMVar (RemoteCtrl, RCVerifiedInvitation)
-> STM (RemoteCtrl, RCVerifiedInvitation)
forall a. TMVar a -> STM a
takeTMVar TMVar (RemoteCtrl, RCVerifiedInvitation)
found
  Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RemoteCtrlId
rcId RemoteCtrlId -> RemoteCtrlId -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteCtrlId
foundRcId) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadController
  RCVerifiedInvitation
-> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrl RCVerifiedInvitation
verifiedInv SessionSeq
sseq CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
-> ((Maybe RemoteCtrlInfo, CtrlAppInfo)
    -> CM (RemoteCtrlInfo, CtrlAppInfo))
-> CM (RemoteCtrlInfo, CtrlAppInfo)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Maybe RemoteCtrlInfo
Nothing, CtrlAppInfo
_) -> ChatErrorType -> CM (RemoteCtrlInfo, CtrlAppInfo)
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM (RemoteCtrlInfo, CtrlAppInfo))
-> ChatErrorType -> CM (RemoteCtrlInfo, CtrlAppInfo)
forall a b. (a -> b) -> a -> b
$ FilePath -> ChatErrorType
CEInternalError FilePath
"connecting with a stored ctrl"
    (Just RemoteCtrlInfo
rci, CtrlAppInfo
appInfo) -> (RemoteCtrlInfo, CtrlAppInfo) -> CM (RemoteCtrlInfo, CtrlAppInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteCtrlInfo
rci, CtrlAppInfo
appInfo)

-- ** Common

startRemoteCtrlSession :: CM SessionSeq
startRemoteCtrlSession :: CM SessionSeq
startRemoteCtrlSession = do
  TVar (Maybe (SessionSeq, RemoteCtrlSession))
session <- (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TVar (Maybe (SessionSeq, RemoteCtrlSession)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession
  TVar SessionSeq
nextSessionSeq <- (ChatController -> TVar SessionSeq)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar SessionSeq)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar SessionSeq
remoteSessionSeq
  IO (Either ChatError SessionSeq) -> CM SessionSeq
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either ChatError SessionSeq) -> CM SessionSeq)
-> (STM (Either ChatError SessionSeq)
    -> IO (Either ChatError SessionSeq))
-> STM (Either ChatError SessionSeq)
-> CM SessionSeq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either ChatError SessionSeq)
-> IO (Either ChatError SessionSeq)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError SessionSeq) -> CM SessionSeq)
-> STM (Either ChatError SessionSeq) -> CM SessionSeq
forall a b. (a -> b) -> a -> b
$
    TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> STM (Maybe (SessionSeq, RemoteCtrlSession))
forall a. TVar a -> STM a
readTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session STM (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession)
    -> STM (Either ChatError SessionSeq))
-> STM (Either ChatError SessionSeq)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (SessionSeq, RemoteCtrlSession)
_ -> Either ChatError SessionSeq -> STM (Either ChatError SessionSeq)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError SessionSeq -> STM (Either ChatError SessionSeq))
-> (ChatError -> Either ChatError SessionSeq)
-> ChatError
-> STM (Either ChatError SessionSeq)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError SessionSeq
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError SessionSeq))
-> ChatError -> STM (Either ChatError SessionSeq)
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBusy
      Maybe (SessionSeq, RemoteCtrlSession)
Nothing -> do
        SessionSeq
sseq <- TVar SessionSeq
-> (SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SessionSeq
nextSessionSeq ((SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq)
-> (SessionSeq -> (SessionSeq, SessionSeq)) -> STM SessionSeq
forall a b. (a -> b) -> a -> b
$ \SessionSeq
s -> (SessionSeq
s, SessionSeq
s SessionSeq -> SessionSeq -> SessionSeq
forall a. Num a => a -> a -> a
+ SessionSeq
1)
        SessionSeq -> Either ChatError SessionSeq
forall a b. b -> Either a b
Right SessionSeq
sseq Either ChatError SessionSeq
-> STM () -> STM (Either ChatError SessionSeq)
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> Maybe (SessionSeq, RemoteCtrlSession) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session ((SessionSeq, RemoteCtrlSession)
-> Maybe (SessionSeq, RemoteCtrlSession)
forall a. a -> Maybe a
Just (SessionSeq
sseq, RemoteCtrlSession
RCSessionStarting))

connectRemoteCtrl :: RCVerifiedInvitation -> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrl :: RCVerifiedInvitation
-> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
connectRemoteCtrl verifiedInv :: RCVerifiedInvitation
verifiedInv@(RCVerifiedInvitation inv :: RCInvitation
inv@RCInvitation {KeyHash
ca :: KeyHash
ca :: RCInvitation -> KeyHash
ca, Value
app :: RCInvitation -> Value
app :: Value
app}) SessionSeq
sseq = SessionSeq
-> (ChatError -> RemoteCtrlStopReason)
-> Text
-> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
-> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
forall a.
SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError SessionSeq
sseq ChatError -> RemoteCtrlStopReason
RCSRConnectionFailed Text
"connectRemoteCtrl" (CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
 -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo))
-> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
-> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
forall a b. (a -> b) -> a -> b
$ do
  ctrlInfo :: CtrlAppInfo
ctrlInfo@CtrlAppInfo {deviceName :: CtrlAppInfo -> Text
deviceName = Text
ctrlDeviceName} <- Value -> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
parseCtrlAppInfo Value
app
  AppVersion
v <- CtrlAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) AppVersion
forall {f :: * -> *}.
MonadError ChatError f =>
CtrlAppInfo -> f AppVersion
checkAppVersion CtrlAppInfo
ctrlInfo
  Maybe RemoteCtrl
rc_ <- (Connection -> IO (Maybe RemoteCtrl)) -> CM (Maybe RemoteCtrl)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe RemoteCtrl)) -> CM (Maybe RemoteCtrl))
-> (Connection -> IO (Maybe RemoteCtrl)) -> CM (Maybe RemoteCtrl)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> KeyHash -> IO (Maybe RemoteCtrl)
getRemoteCtrlByFingerprint Connection
db KeyHash
ca
  (RemoteCtrl -> CM ()) -> Maybe RemoteCtrl -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RCInvitation -> RemoteCtrl -> CM ()
forall {f :: * -> *}.
MonadError ChatError f =>
RCInvitation -> RemoteCtrl -> f ()
validateRemoteCtrl RCInvitation
inv) Maybe RemoteCtrl
rc_
  HostAppInfo
hostAppInfo <- AppVersion
-> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo
getHostAppInfo AppVersion
v
  (RCCtrlClient
rcsClient, RCStepTMVar
  (ByteString, TLS 'TClient,
   RCStepTMVar (RCCtrlSession, RCCtrlPairing))
vars) <- ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCETimeout) SessionSeq
networkIOTimeout (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (RCCtrlClient,
    RCStepTMVar
      (ByteString, TLS 'TClient,
       RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCCtrlClient,
       RCStepTMVar
         (ByteString, TLS 'TClient,
          RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> ((AgentClient
     -> ExceptT
          AgentErrorType
          IO
          (RCCtrlClient,
           RCStepTMVar
             (ByteString, TLS 'TClient,
              RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (RCCtrlClient,
          RCStepTMVar
            (ByteString, TLS 'TClient,
             RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> (AgentClient
    -> ExceptT
         AgentErrorType
         IO
         (RCCtrlClient,
          RCStepTMVar
            (ByteString, TLS 'TClient,
             RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AgentClient
 -> ExceptT
      AgentErrorType
      IO
      (RCCtrlClient,
       RCStepTMVar
         (ByteString, TLS 'TClient,
          RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient
  -> ExceptT
       AgentErrorType
       IO
       (RCCtrlClient,
        RCStepTMVar
          (ByteString, TLS 'TClient,
           RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCCtrlClient,
       RCStepTMVar
         (ByteString, TLS 'TClient,
          RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> (AgentClient
    -> ExceptT
         AgentErrorType
         IO
         (RCCtrlClient,
          RCStepTMVar
            (ByteString, TLS 'TClient,
             RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
forall a b. (a -> b) -> a -> b
$ \AgentClient
a ->
    AgentClient
-> RCVerifiedInvitation
-> Maybe RCCtrlPairing
-> Value
-> ExceptT
     AgentErrorType
     IO
     (RCCtrlClient,
      RCStepTMVar
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
rcConnectCtrl AgentClient
a RCVerifiedInvitation
verifiedInv (RemoteCtrl -> RCCtrlPairing
ctrlPairing (RemoteCtrl -> RCCtrlPairing)
-> Maybe RemoteCtrl -> Maybe RCCtrlPairing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrl
rc_) (HostAppInfo -> Value
forall a. ToJSON a => a -> Value
J.toJSON HostAppInfo
hostAppInfo)
  TMVar ()
cmdOk <- ExceptT ChatError (ReaderT ChatController IO) (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  Async ()
rcsWaitSession <- CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (CM () -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> CM ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a b. (a -> b) -> a -> b
$ do
    STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
cmdOk
    SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM () -> CM ()
forall a.
SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError SessionSeq
sseq ChatError -> RemoteCtrlStopReason
RCSRConnectionFailed Text
"waitForCtrlSession" (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe RemoteCtrl
-> Text
-> RCCtrlClient
-> RCStepTMVar
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> CM ()
waitForCtrlSession Maybe RemoteCtrl
rc_ Text
ctrlDeviceName RCCtrlClient
rcsClient RCStepTMVar
  (ByteString, TLS 'TClient,
   RCStepTMVar (RCCtrlSession, RCCtrlPairing))
vars
  SessionSeq
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
updateRemoteCtrlSession SessionSeq
sseq ((RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
 -> CM ())
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
    RemoteCtrlSession
RCSessionStarting -> RemoteCtrlSession -> Either ChatError RemoteCtrlSession
forall a b. b -> Either a b
Right RCSessionConnecting {remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_ = RemoteCtrl -> RemoteCtrlId
remoteCtrlId' (RemoteCtrl -> RemoteCtrlId)
-> Maybe RemoteCtrl -> Maybe RemoteCtrlId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrl
rc_, RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, Async ()
rcsWaitSession :: Async ()
rcsWaitSession :: Async ()
rcsWaitSession}
    RemoteCtrlSession
_ -> ChatError -> Either ChatError RemoteCtrlSession
forall a b. a -> Either a b
Left (ChatError -> Either ChatError RemoteCtrlSession)
-> ChatError -> Either ChatError RemoteCtrlSession
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
  STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
cmdOk ()
  (Maybe RemoteCtrlInfo, CtrlAppInfo)
-> CM (Maybe RemoteCtrlInfo, CtrlAppInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
`remoteCtrlInfo` RemoteCtrlSessionState -> Maybe RemoteCtrlSessionState
forall a. a -> Maybe a
Just RemoteCtrlSessionState
RCSConnecting) (RemoteCtrl -> RemoteCtrlInfo)
-> Maybe RemoteCtrl -> Maybe RemoteCtrlInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrl
rc_, CtrlAppInfo
ctrlInfo)
  where
    validateRemoteCtrl :: RCInvitation -> RemoteCtrl -> f ()
validateRemoteCtrl RCInvitation {PublicKeyEd25519
idkey :: PublicKeyEd25519
idkey :: RCInvitation -> PublicKeyEd25519
idkey} RemoteCtrl {ctrlPairing :: RemoteCtrl -> RCCtrlPairing
ctrlPairing = RCCtrlPairing {PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey :: RCCtrlPairing -> PublicKeyEd25519
idPubKey}} =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKeyEd25519
idkey PublicKeyEd25519 -> PublicKeyEd25519 -> Bool
forall a. Eq a => a -> a -> Bool
== PublicKeyEd25519
idPubKey) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ ChatError -> f ()
forall a. ChatError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> f ()) -> ChatError -> f ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl (RemoteCtrlError -> ChatError) -> RemoteCtrlError -> ChatError
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> RemoteCtrlError
RCEProtocolError (RemoteProtocolError -> RemoteCtrlError)
-> RemoteProtocolError -> RemoteCtrlError
forall a b. (a -> b) -> a -> b
$ RCErrorType -> RemoteProtocolError
PRERemoteControl RCErrorType
RCEIdentity
    waitForCtrlSession :: Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> CM ()
    waitForCtrlSession :: Maybe RemoteCtrl
-> Text
-> RCCtrlClient
-> RCStepTMVar
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> CM ()
waitForCtrlSession Maybe RemoteCtrl
rc_ Text
ctrlName RCCtrlClient
rcsClient RCStepTMVar
  (ByteString, TLS 'TClient,
   RCStepTMVar (RCCtrlSession, RCCtrlPairing))
vars = do
      (ByteString
uniq, TLS 'TClient
tls, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation) <- ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCETimeout) SessionSeq
networkIOTimeout (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (ByteString, TLS 'TClient,
    RCStepTMVar (RCCtrlSession, RCCtrlPairing))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (ByteString, TLS 'TClient,
       RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a b. (a -> b) -> a -> b
$ RCStepTMVar
  (ByteString, TLS 'TClient,
   RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a. RCStepTMVar a -> CM a
takeRCStep RCStepTMVar
  (ByteString, TLS 'TClient,
   RCStepTMVar (RCCtrlSession, RCCtrlPairing))
vars
      let sessionCode :: Text
sessionCode = ByteString -> Text
verificationCode ByteString
uniq
      SessionSeq
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
updateRemoteCtrlSession SessionSeq
sseq ((RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
 -> CM ())
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
        RCSessionConnecting {Async ()
rcsWaitSession :: RemoteCtrlSession -> Async ()
rcsWaitSession :: Async ()
rcsWaitSession} ->
          let remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_ = RemoteCtrl -> RemoteCtrlId
remoteCtrlId' (RemoteCtrl -> RemoteCtrlId)
-> Maybe RemoteCtrl -> Maybe RemoteCtrlId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrl
rc_
           in RemoteCtrlSession -> Either ChatError RemoteCtrlSession
forall a b. b -> Either a b
Right RCSessionPendingConfirmation {Maybe RemoteCtrlId
remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_, ctrlDeviceName :: Text
ctrlDeviceName = Text
ctrlName, RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, TLS 'TClient
tls :: TLS 'TClient
tls :: TLS 'TClient
tls, Text
sessionCode :: Text
sessionCode :: Text
sessionCode, Async ()
rcsWaitSession :: Async ()
rcsWaitSession :: Async ()
rcsWaitSession, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation :: RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation :: RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation}
        RemoteCtrlSession
_ -> ChatError -> Either ChatError RemoteCtrlSession
forall a b. a -> Either a b
Left (ChatError -> Either ChatError RemoteCtrlSession)
-> ChatError -> Either ChatError RemoteCtrlSession
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
      ChatEvent -> CM ()
toView CEvtRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo
remoteCtrl_ = (RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
`remoteCtrlInfo` RemoteCtrlSessionState -> Maybe RemoteCtrlSessionState
forall a. a -> Maybe a
Just RCSPendingConfirmation {Text
sessionCode :: Text
sessionCode :: Text
sessionCode}) (RemoteCtrl -> RemoteCtrlInfo)
-> Maybe RemoteCtrl -> Maybe RemoteCtrlInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrl
rc_, Text
sessionCode :: Text
sessionCode :: Text
sessionCode}
    checkAppVersion :: CtrlAppInfo -> f AppVersion
checkAppVersion CtrlAppInfo {AppVersionRange
appVersionRange :: CtrlAppInfo -> AppVersionRange
appVersionRange :: AppVersionRange
appVersionRange} =
      case AppVersionRange
-> AppVersionRange -> Maybe (AppCompatible AppVersion)
compatibleAppVersion AppVersionRange
hostAppVersionRange AppVersionRange
appVersionRange of
        Just (AppCompatible AppVersion
v) -> AppVersion -> f AppVersion
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppVersion
v
        Maybe (AppCompatible AppVersion)
Nothing -> ChatError -> f AppVersion
forall a. ChatError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> f AppVersion) -> ChatError -> f AppVersion
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl (RemoteCtrlError -> ChatError) -> RemoteCtrlError -> ChatError
forall a b. (a -> b) -> a -> b
$ AppVersion -> RemoteCtrlError
RCEBadVersion (AppVersion -> RemoteCtrlError) -> AppVersion -> RemoteCtrlError
forall a b. (a -> b) -> a -> b
$ AppVersionRange -> AppVersion
maxVersion AppVersionRange
appVersionRange
    getHostAppInfo :: AppVersion
-> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo
getHostAppInfo AppVersion
appVersion = do
      Text
hostDeviceName <- (ChatController -> TVar Text) -> CM Text
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar Text
localDeviceName
      Bool
encryptFiles <- (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar Bool
encryptLocalFiles
      HostAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) HostAppInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HostAppInfo {AppVersion
appVersion :: AppVersion
appVersion :: AppVersion
appVersion, deviceName :: Text
deviceName = Text
hostDeviceName, encoding :: PlatformEncoding
encoding = PlatformEncoding
localEncoding, Bool
encryptFiles :: Bool
encryptFiles :: Bool
encryptFiles}

parseCtrlAppInfo :: JT.Value -> CM CtrlAppInfo
parseCtrlAppInfo :: Value -> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
parseCtrlAppInfo Value
ctrlAppInfo = do
  (FilePath -> ChatError)
-> Either FilePath CtrlAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (ChatError -> FilePath -> ChatError
forall a b. a -> b -> a
const (ChatError -> FilePath -> ChatError)
-> ChatError -> FilePath -> ChatError
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadInvitation) (Either FilePath CtrlAppInfo
 -> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo)
-> Either FilePath CtrlAppInfo
-> ExceptT ChatError (ReaderT ChatController IO) CtrlAppInfo
forall a b. (a -> b) -> a -> b
$ (Value -> Parser CtrlAppInfo)
-> Value -> Either FilePath CtrlAppInfo
forall a b. (a -> Parser b) -> a -> Either FilePath b
JT.parseEither Value -> Parser CtrlAppInfo
forall a. FromJSON a => Value -> Parser a
J.parseJSON Value
ctrlAppInfo

handleRemoteCommand :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> RemoteCrypto -> TBQueue (Either ChatError ChatEvent) -> HTTP2Request -> CM' ()
handleRemoteCommand :: (ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse))
-> RemoteCrypto
-> TBQueue (Either ChatError ChatEvent)
-> HTTP2Request
-> CM' ()
handleRemoteCommand ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC RemoteCrypto
encryption TBQueue (Either ChatError ChatEvent)
remoteOutputQ HTTP2Request {Request
request :: Request
request :: HTTP2Request -> Request
request, HTTP2Body
reqBody :: HTTP2Body
reqBody :: HTTP2Request -> HTTP2Body
reqBody, Response -> IO ()
sendResponse :: Response -> IO ()
sendResponse :: HTTP2Request -> Response -> IO ()
sendResponse} = do
  Text -> CM' ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"handleRemoteCommand"
  IO
  (Either
     RemoteProtocolError
     (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand))
-> ReaderT
     ChatController
     IO
     (Either
        RemoteProtocolError
        (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand))
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT
  RemoteProtocolError
  IO
  (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand)
-> IO
     (Either
        RemoteProtocolError
        (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' ExceptT
  RemoteProtocolError
  IO
  (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand)
parseRequest) ReaderT
  ChatController
  IO
  (Either
     RemoteProtocolError
     (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand))
-> (Either
      RemoteProtocolError
      (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand)
    -> CM' ())
-> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (SbKeyNonce
rfKN, SessionSeq -> IO ByteString
getNext, RemoteCommand
rc) -> do
      (ChatController -> TVar (Maybe User)) -> CM' (Maybe User)
forall a. (ChatController -> TVar a) -> CM' a
chatReadVar' ChatController -> TVar (Maybe User)
currentUser CM' (Maybe User) -> (Maybe User -> CM' ()) -> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe User
Nothing -> ChatError -> CM' ()
replyError (ChatError -> CM' ()) -> ChatError -> CM' ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ChatError
ChatError ChatErrorType
CENoActiveUser
        Just User
user -> User
-> SbKeyNonce
-> (SessionSeq -> IO ByteString)
-> RemoteCommand
-> CM ()
processCommand User
user SbKeyNonce
rfKN SessionSeq -> IO ByteString
getNext RemoteCommand
rc CM () -> (ChatError -> CM' ()) -> CM' ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> m a) -> m a
`catchAllErrors'` ChatError -> CM' ()
replyError
    Left RemoteProtocolError
e -> RemoteResponse -> CM' ()
reply (RemoteResponse -> CM' ()) -> RemoteResponse -> CM' ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> RemoteResponse
RRProtocolError RemoteProtocolError
e
  where
    parseRequest :: ExceptT RemoteProtocolError IO (C.SbKeyNonce, GetChunk, RemoteCommand)
    parseRequest :: ExceptT
  RemoteProtocolError
  IO
  (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand)
parseRequest = do
      (SbKeyNonce
rfKN, LazyByteString
header, SessionSeq -> IO ByteString
getNext) <- RemoteCrypto
-> Request
-> HTTP2Body
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, SessionSeq -> IO ByteString)
forall a.
HTTP2BodyChunk a =>
RemoteCrypto
-> a
-> HTTP2Body
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, SessionSeq -> IO ByteString)
parseDecryptHTTP2Body RemoteCrypto
encryption Request
request HTTP2Body
reqBody
      (SbKeyNonce
rfKN,SessionSeq -> IO ByteString
getNext,) (RemoteCommand
 -> (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand))
-> ExceptT RemoteProtocolError IO RemoteCommand
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, SessionSeq -> IO ByteString, RemoteCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> RemoteProtocolError)
-> Either FilePath RemoteCommand
-> ExceptT RemoteProtocolError IO RemoteCommand
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith FilePath -> RemoteProtocolError
RPEInvalidJSON (LazyByteString -> Either FilePath RemoteCommand
forall a. FromJSON a => LazyByteString -> Either FilePath a
J.eitherDecode LazyByteString
header)
    replyError :: ChatError -> CM' ()
replyError = RemoteResponse -> CM' ()
reply (RemoteResponse -> CM' ())
-> (ChatError -> RemoteResponse) -> ChatError -> CM' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRResult ChatResponse -> RemoteResponse
RRChatResponse (RRResult ChatResponse -> RemoteResponse)
-> (ChatError -> RRResult ChatResponse)
-> ChatError
-> RemoteResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> RRResult ChatResponse
forall r. ChatError -> RRResult r
RRError
    processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM ()
    processCommand :: User
-> SbKeyNonce
-> (SessionSeq -> IO ByteString)
-> RemoteCommand
-> CM ()
processCommand User
user SbKeyNonce
rfKN SessionSeq -> IO ByteString
getNext = \case
      RCSend {Text
command :: Text
command :: RemoteCommand -> Text
command, SessionSeq
retryNumber :: SessionSeq
retryNumber :: RemoteCommand -> SessionSeq
retryNumber} -> CM' () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CM' () -> CM ()) -> CM' () -> CM ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse))
-> Text -> SessionSeq -> CM' RemoteResponse
handleSend ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC Text
command SessionSeq
retryNumber CM' RemoteResponse -> (RemoteResponse -> CM' ()) -> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RemoteResponse -> CM' ()
reply
      RCRecv {wait :: RemoteCommand -> SessionSeq
wait = SessionSeq
time} -> CM' () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CM' () -> CM ()) -> CM' () -> CM ()
forall a b. (a -> b) -> a -> b
$ IO RemoteResponse -> CM' RemoteResponse
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SessionSeq
-> TBQueue (Either ChatError ChatEvent) -> IO RemoteResponse
handleRecv SessionSeq
time TBQueue (Either ChatError ChatEvent)
remoteOutputQ) CM' RemoteResponse -> (RemoteResponse -> CM' ()) -> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RemoteResponse -> CM' ()
reply
      RCStoreFile {FilePath
fileName :: FilePath
fileName :: RemoteCommand -> FilePath
fileName, Word32
fileSize :: Word32
fileSize :: RemoteCommand -> Word32
fileSize, FileDigest
fileDigest :: FileDigest
fileDigest :: RemoteCommand -> FileDigest
fileDigest} -> CM' () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CM' () -> CM ()) -> CM' () -> CM ()
forall a b. (a -> b) -> a -> b
$ SbKeyNonce
-> FilePath
-> Word32
-> FileDigest
-> (SessionSeq -> IO ByteString)
-> CM' RemoteResponse
handleStoreFile SbKeyNonce
rfKN FilePath
fileName Word32
fileSize FileDigest
fileDigest SessionSeq -> IO ByteString
getNext CM' RemoteResponse -> (RemoteResponse -> CM' ()) -> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RemoteResponse -> CM' ()
reply
      RCGetFile {RemoteFile
file :: RemoteFile
file :: RemoteCommand -> RemoteFile
file} -> User -> RemoteFile -> Respond -> CM ()
handleGetFile User
user RemoteFile
file Respond
replyWith
    reply :: RemoteResponse -> CM' ()
    reply :: RemoteResponse -> CM' ()
reply = (Respond
`replyWith` \SbKeyNonce
_ SendChunk
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    replyWith :: Respond
    replyWith :: Respond
replyWith RemoteResponse
rr SbKeyNonce -> SendChunk -> IO ()
attach = do
      (Word32
corrId, SbKeyNonce
cmdKN, SbKeyNonce
sfKN) <- STM (Word32, SbKeyNonce, SbKeyNonce)
-> ReaderT ChatController IO (Word32, SbKeyNonce, SbKeyNonce)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Word32, SbKeyNonce, SbKeyNonce)
 -> ReaderT ChatController IO (Word32, SbKeyNonce, SbKeyNonce))
-> STM (Word32, SbKeyNonce, SbKeyNonce)
-> ReaderT ChatController IO (Word32, SbKeyNonce, SbKeyNonce)
forall a b. (a -> b) -> a -> b
$ RemoteCrypto -> STM (Word32, SbKeyNonce, SbKeyNonce)
getRemoteSndKeys RemoteCrypto
encryption
      IO (Either RemoteProtocolError Builder)
-> ReaderT ChatController IO (Either RemoteProtocolError Builder)
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT RemoteProtocolError IO Builder
-> IO (Either RemoteProtocolError Builder)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (ExceptT RemoteProtocolError IO Builder
 -> IO (Either RemoteProtocolError Builder))
-> (LazyByteString -> ExceptT RemoteProtocolError IO Builder)
-> LazyByteString
-> IO (Either RemoteProtocolError Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32
-> SbKeyNonce
-> RemoteCrypto
-> LazyByteString
-> ExceptT RemoteProtocolError IO Builder
encryptEncodeHTTP2Body Word32
corrId SbKeyNonce
cmdKN RemoteCrypto
encryption (LazyByteString -> IO (Either RemoteProtocolError Builder))
-> LazyByteString -> IO (Either RemoteProtocolError Builder)
forall a b. (a -> b) -> a -> b
$ RemoteResponse -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
J.encode RemoteResponse
rr) ReaderT ChatController IO (Either RemoteProtocolError Builder)
-> (Either RemoteProtocolError Builder -> CM' ()) -> CM' ()
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Builder
resp -> IO () -> CM' ()
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM' ())
-> ((SendChunk -> IO () -> IO ()) -> IO ())
-> (SendChunk -> IO () -> IO ())
-> CM' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ()
sendResponse (Response -> IO ())
-> ((SendChunk -> IO () -> IO ()) -> Response)
-> (SendChunk -> IO () -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status
-> ResponseHeaders -> (SendChunk -> IO () -> IO ()) -> Response
responseStreaming Status
N.status200 [] ((SendChunk -> IO () -> IO ()) -> CM' ())
-> (SendChunk -> IO () -> IO ()) -> CM' ()
forall a b. (a -> b) -> a -> b
$ \SendChunk
send IO ()
flush -> do
          SendChunk
send Builder
resp
          SbKeyNonce -> SendChunk -> IO ()
attach SbKeyNonce
sfKN SendChunk
send
          IO ()
flush
        Left RemoteProtocolError
e -> ChatError -> CM' ()
eToView' (ChatError -> CM' ()) -> ChatError -> CM' ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl (RemoteCtrlError -> ChatError) -> RemoteCtrlError -> ChatError
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> RemoteCtrlError
RCEProtocolError RemoteProtocolError
e

takeRCStep :: RCStepTMVar a -> CM a
takeRCStep :: forall a. RCStepTMVar a -> CM a
takeRCStep = (RCErrorType -> ChatError)
-> IO (Either RCErrorType a)
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' (\RCErrorType
e -> ChatErrorAgent {agentError :: AgentErrorType
agentError = RCErrorType -> AgentErrorType
RCP RCErrorType
e, agentConnId :: AgentConnId
agentConnId = ByteString -> AgentConnId
AgentConnId ByteString
"", connectionEntity_ :: Maybe ConnectionEntity
connectionEntity_ = Maybe ConnectionEntity
forall a. Maybe a
Nothing}) (IO (Either RCErrorType a)
 -> ExceptT ChatError (ReaderT ChatController IO) a)
-> (RCStepTMVar a -> IO (Either RCErrorType a))
-> RCStepTMVar a
-> ExceptT ChatError (ReaderT ChatController IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either RCErrorType a) -> IO (Either RCErrorType a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either RCErrorType a) -> IO (Either RCErrorType a))
-> (RCStepTMVar a -> STM (Either RCErrorType a))
-> RCStepTMVar a
-> IO (Either RCErrorType a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RCStepTMVar a -> STM (Either RCErrorType a)
forall a. TMVar a -> STM a
takeTMVar

type GetChunk = Int -> IO ByteString

type SendChunk = Builder -> IO ()

type Respond = RemoteResponse -> (C.SbKeyNonce -> SendChunk -> IO ()) -> CM' ()

liftRC :: ExceptT RemoteProtocolError IO a -> CM a
liftRC :: forall a. ExceptT RemoteProtocolError IO a -> CM a
liftRC = (RemoteProtocolError -> ChatError)
-> ExceptT RemoteProtocolError IO a
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl (RemoteCtrlError -> ChatError)
-> (RemoteProtocolError -> RemoteCtrlError)
-> RemoteProtocolError
-> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteProtocolError -> RemoteCtrlError
RCEProtocolError)

handleSend :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> Int -> CM' RemoteResponse
handleSend :: (ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse))
-> Text -> SessionSeq -> CM' RemoteResponse
handleSend ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC Text
command SessionSeq
retryNum = do
  Text -> CM' ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> CM' ()) -> Text -> CM' ()
forall a b. (a -> b) -> a -> b
$ Text
"Send: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
command
  -- execCC checks for remote-allowed commands
  -- convert errors thrown in execCC into error responses to prevent aborting the protocol wrapper
  RRResult ChatResponse -> RemoteResponse
RRChatResponse (RRResult ChatResponse -> RemoteResponse)
-> (Either ChatError ChatResponse -> RRResult ChatResponse)
-> Either ChatError ChatResponse
-> RemoteResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ChatError ChatResponse -> RRResult ChatResponse
forall r. Either ChatError r -> RRResult r
eitherToResult (Either ChatError ChatResponse -> RemoteResponse)
-> CM' (Either ChatError ChatResponse) -> CM' RemoteResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC (Text -> ByteString
encodeUtf8 Text
command) SessionSeq
retryNum

handleRecv :: Int -> TBQueue (Either ChatError ChatEvent) -> IO RemoteResponse
handleRecv :: SessionSeq
-> TBQueue (Either ChatError ChatEvent) -> IO RemoteResponse
handleRecv SessionSeq
time TBQueue (Either ChatError ChatEvent)
events = do
  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Recv: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SessionSeq -> Text
forall a. Show a => a -> Text
tshow SessionSeq
time
  Maybe (RRResult ChatEvent) -> RemoteResponse
RRChatEvent (Maybe (RRResult ChatEvent) -> RemoteResponse)
-> (Maybe (Either ChatError ChatEvent)
    -> Maybe (RRResult ChatEvent))
-> Maybe (Either ChatError ChatEvent)
-> RemoteResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ChatError ChatEvent -> RRResult ChatEvent)
-> Maybe (Either ChatError ChatEvent) -> Maybe (RRResult ChatEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either ChatError ChatEvent -> RRResult ChatEvent
forall r. Either ChatError r -> RRResult r
eitherToResult (Maybe (Either ChatError ChatEvent) -> RemoteResponse)
-> IO (Maybe (Either ChatError ChatEvent)) -> IO RemoteResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SessionSeq
-> IO (Either ChatError ChatEvent)
-> IO (Maybe (Either ChatError ChatEvent))
forall (m :: * -> *) a.
MonadUnliftIO m =>
SessionSeq -> m a -> m (Maybe a)
timeout SessionSeq
time (IO (Either ChatError ChatEvent)
 -> IO (Maybe (Either ChatError ChatEvent)))
-> (STM (Either ChatError ChatEvent)
    -> IO (Either ChatError ChatEvent))
-> STM (Either ChatError ChatEvent)
-> IO (Maybe (Either ChatError ChatEvent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either ChatError ChatEvent) -> IO (Either ChatError ChatEvent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError ChatEvent)
 -> IO (Maybe (Either ChatError ChatEvent)))
-> STM (Either ChatError ChatEvent)
-> IO (Maybe (Either ChatError ChatEvent))
forall a b. (a -> b) -> a -> b
$ TBQueue (Either ChatError ChatEvent)
-> STM (Either ChatError ChatEvent)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Either ChatError ChatEvent)
events)

-- TODO this command could remember stored files and return IDs to allow removing files that are not needed.
-- Also, there should be some process removing unused files uploaded to remote host (possibly, all unused files).
handleStoreFile :: C.SbKeyNonce -> FilePath -> Word32 -> FileDigest -> GetChunk -> CM' RemoteResponse
handleStoreFile :: SbKeyNonce
-> FilePath
-> Word32
-> FileDigest
-> (SessionSeq -> IO ByteString)
-> CM' RemoteResponse
handleStoreFile SbKeyNonce
rfKN FilePath
fileName Word32
fileSize FileDigest
fileDigest SessionSeq -> IO ByteString
getChunk =
  (RemoteProtocolError -> RemoteResponse)
-> (FilePath -> RemoteResponse)
-> Either RemoteProtocolError FilePath
-> RemoteResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RemoteProtocolError -> RemoteResponse
RRProtocolError FilePath -> RemoteResponse
RRFileStored (Either RemoteProtocolError FilePath -> RemoteResponse)
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
-> CM' RemoteResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ChatController -> TVar (Maybe FilePath))
-> ReaderT ChatController IO (Maybe FilePath)
forall a. (ChatController -> TVar a) -> CM' a
chatReadVar' ChatController -> TVar (Maybe FilePath)
filesFolder ReaderT ChatController IO (Maybe FilePath)
-> (Maybe FilePath
    -> ReaderT ChatController IO (Either RemoteProtocolError FilePath))
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
storeFile)
  where
    storeFile :: Maybe FilePath -> CM' (Either RemoteProtocolError FilePath)
    storeFile :: Maybe FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
storeFile = \case
      Just FilePath
ff -> FilePath -> FilePath
takeFileName (FilePath -> FilePath)
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
storeFileTo FilePath
ff
      Maybe FilePath
Nothing -> FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
storeFileTo (FilePath
 -> ReaderT ChatController IO (Either RemoteProtocolError FilePath))
-> ReaderT ChatController IO FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT ChatController IO FilePath
getDefaultFilesFolder
    storeFileTo :: FilePath -> CM' (Either RemoteProtocolError FilePath)
    storeFileTo :: FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
storeFileTo FilePath
dir = IO (Either RemoteProtocolError FilePath)
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either RemoteProtocolError FilePath)
 -> ReaderT ChatController IO (Either RemoteProtocolError FilePath))
-> (ExceptT RemoteProtocolError IO FilePath
    -> IO (Either RemoteProtocolError FilePath))
-> ExceptT RemoteProtocolError IO FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RemoteProtocolError IO FilePath
-> IO (Either RemoteProtocolError FilePath)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (ExceptT RemoteProtocolError IO FilePath
 -> ReaderT ChatController IO (Either RemoteProtocolError FilePath))
-> ExceptT RemoteProtocolError IO FilePath
-> ReaderT ChatController IO (Either RemoteProtocolError FilePath)
forall a b. (a -> b) -> a -> b
$ do
      FilePath
filePath <- IO FilePath -> ExceptT RemoteProtocolError IO FilePath
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT RemoteProtocolError IO FilePath)
-> IO FilePath -> ExceptT RemoteProtocolError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> IO FilePath
`uniqueCombine` FilePath
fileName
      SbKeyNonce
-> (SessionSeq -> IO ByteString)
-> Word32
-> FileDigest
-> FilePath
-> ExceptT RemoteProtocolError IO ()
receiveEncryptedFile SbKeyNonce
rfKN SessionSeq -> IO ByteString
getChunk Word32
fileSize FileDigest
fileDigest FilePath
filePath
      FilePath -> ExceptT RemoteProtocolError IO FilePath
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
filePath

handleGetFile :: User -> RemoteFile -> Respond -> CM ()
handleGetFile :: User -> RemoteFile -> Respond -> CM ()
handleGetFile User {RemoteCtrlId
userId :: RemoteCtrlId
userId :: User -> RemoteCtrlId
userId} RemoteFile {userId :: RemoteFile -> RemoteCtrlId
userId = RemoteCtrlId
commandUserId, RemoteCtrlId
fileId :: RemoteCtrlId
fileId :: RemoteFile -> RemoteCtrlId
fileId, Bool
sent :: Bool
sent :: RemoteFile -> Bool
sent, fileSource :: RemoteFile -> CryptoFile
fileSource = cf' :: CryptoFile
cf'@CryptoFile {FilePath
filePath :: CryptoFile -> FilePath
filePath :: FilePath
filePath}} Respond
reply = do
  Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"GetFile: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Show a => a -> Text
tshow FilePath
filePath
  Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RemoteCtrlId
userId RemoteCtrlId -> RemoteCtrlId -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteCtrlId
commandUserId) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ CEDifferentActiveUser {RemoteCtrlId
commandUserId :: RemoteCtrlId
commandUserId :: RemoteCtrlId
commandUserId, activeUserId :: RemoteCtrlId
activeUserId = RemoteCtrlId
userId}
  FilePath
path <- FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
filePath (FilePath -> FilePath -> FilePath
</> FilePath
filePath) (Maybe FilePath -> FilePath)
-> CM (Maybe FilePath)
-> ExceptT ChatError (ReaderT ChatController IO) FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ChatController -> TVar (Maybe FilePath)) -> CM (Maybe FilePath)
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe FilePath)
filesFolder
  (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    CryptoFile
cf <- Connection
-> RemoteCtrlId
-> RemoteCtrlId
-> Bool
-> ExceptT StoreError IO CryptoFile
getLocalCryptoFile Connection
db RemoteCtrlId
commandUserId RemoteCtrlId
fileId Bool
sent
    Bool -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptoFile
cf CryptoFile -> CryptoFile -> Bool
forall a. Eq a => a -> a -> Bool
== CryptoFile
cf') (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ StoreError -> ExceptT StoreError IO ()
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StoreError -> ExceptT StoreError IO ())
-> StoreError -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlId -> StoreError
SEFileNotFound RemoteCtrlId
fileId
  ExceptT
  RemoteProtocolError
  IO
  (Either RemoteProtocolError (Word32, FileDigest))
-> CM (Either RemoteProtocolError (Word32, FileDigest))
forall a. ExceptT RemoteProtocolError IO a -> CM a
liftRC (ExceptT RemoteProtocolError IO (Word32, FileDigest)
-> ExceptT
     RemoteProtocolError
     IO
     (Either RemoteProtocolError (Word32, FileDigest))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (ExceptT RemoteProtocolError IO (Word32, FileDigest)
 -> ExceptT
      RemoteProtocolError
      IO
      (Either RemoteProtocolError (Word32, FileDigest)))
-> ExceptT RemoteProtocolError IO (Word32, FileDigest)
-> ExceptT
     RemoteProtocolError
     IO
     (Either RemoteProtocolError (Word32, FileDigest))
forall a b. (a -> b) -> a -> b
$ FilePath -> ExceptT RemoteProtocolError IO (Word32, FileDigest)
getFileInfo FilePath
path) CM (Either RemoteProtocolError (Word32, FileDigest))
-> (Either RemoteProtocolError (Word32, FileDigest) -> CM ())
-> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left RemoteProtocolError
e -> CM' () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CM' () -> CM ()) -> CM' () -> CM ()
forall a b. (a -> b) -> a -> b
$ Respond
reply (RemoteProtocolError -> RemoteResponse
RRProtocolError RemoteProtocolError
e) ((SbKeyNonce -> SendChunk -> IO ()) -> CM' ())
-> (SbKeyNonce -> SendChunk -> IO ()) -> CM' ()
forall a b. (a -> b) -> a -> b
$ \SbKeyNonce
_ SendChunk
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right (Word32
fileSize, FileDigest
fileDigest) ->
      CM' () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CM' () -> CM ())
-> ((Handle -> CM' ()) -> CM' ()) -> (Handle -> CM' ()) -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOMode -> (Handle -> CM' ()) -> CM' ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withFile FilePath
path IOMode
ReadMode ((Handle -> CM' ()) -> CM ()) -> (Handle -> CM' ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Respond
reply RRFile {Word32
fileSize :: Word32
fileSize :: Word32
fileSize, FileDigest
fileDigest :: FileDigest
fileDigest :: FileDigest
fileDigest} ((SbKeyNonce -> SendChunk -> IO ()) -> CM' ())
-> (SbKeyNonce -> SendChunk -> IO ()) -> CM' ()
forall a b. (a -> b) -> a -> b
$ \SbKeyNonce
sfKN SendChunk
send -> IO (Either RemoteProtocolError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either RemoteProtocolError ()) -> IO ())
-> (ExceptT RemoteProtocolError IO ()
    -> IO (Either RemoteProtocolError ()))
-> ExceptT RemoteProtocolError IO ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RemoteProtocolError IO ()
-> IO (Either RemoteProtocolError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RemoteProtocolError IO () -> IO ())
-> ExceptT RemoteProtocolError IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          EncryptedFile
encFile <- SbKeyNonce
-> (Handle, Word32) -> ExceptT RemoteProtocolError IO EncryptedFile
prepareEncryptedFile SbKeyNonce
sfKN (Handle
h, Word32
fileSize)
          IO () -> ExceptT RemoteProtocolError IO ()
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT RemoteProtocolError IO ())
-> IO () -> ExceptT RemoteProtocolError IO ()
forall a b. (a -> b) -> a -> b
$ EncryptedFile -> SendChunk -> IO ()
sendEncryptedFile EncryptedFile
encFile SendChunk
send

listRemoteCtrls :: CM [RemoteCtrlInfo]
listRemoteCtrls :: CM [RemoteCtrlInfo]
listRemoteCtrls = do
  Maybe RemoteCtrlSession
session <- (SessionSeq, RemoteCtrlSession) -> RemoteCtrlSession
forall a b. (a, b) -> b
snd ((SessionSeq, RemoteCtrlSession) -> RemoteCtrlSession)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (SessionSeq, RemoteCtrlSession))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe RemoteCtrlSession)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (SessionSeq, RemoteCtrlSession))
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession
  let rcId :: Maybe RemoteCtrlId
rcId = RemoteCtrlSession -> Maybe RemoteCtrlId
sessionRcId (RemoteCtrlSession -> Maybe RemoteCtrlId)
-> Maybe RemoteCtrlSession -> Maybe RemoteCtrlId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe RemoteCtrlSession
session
      sessState :: Maybe RemoteCtrlSessionState
sessState = RemoteCtrlSession -> RemoteCtrlSessionState
rcsSessionState (RemoteCtrlSession -> RemoteCtrlSessionState)
-> Maybe RemoteCtrlSession -> Maybe RemoteCtrlSessionState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RemoteCtrlSession
session
  (RemoteCtrl -> RemoteCtrlInfo) -> [RemoteCtrl] -> [RemoteCtrlInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe RemoteCtrlId
-> Maybe RemoteCtrlSessionState -> RemoteCtrl -> RemoteCtrlInfo
rcInfo Maybe RemoteCtrlId
rcId Maybe RemoteCtrlSessionState
sessState) ([RemoteCtrl] -> [RemoteCtrlInfo])
-> CM [RemoteCtrl] -> CM [RemoteCtrlInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO [RemoteCtrl]) -> CM [RemoteCtrl]
forall a. (Connection -> IO a) -> CM a
withStore' Connection -> IO [RemoteCtrl]
getRemoteCtrls
  where
    rcInfo :: Maybe RemoteCtrlId -> Maybe RemoteCtrlSessionState -> RemoteCtrl -> RemoteCtrlInfo
    rcInfo :: Maybe RemoteCtrlId
-> Maybe RemoteCtrlSessionState -> RemoteCtrl -> RemoteCtrlInfo
rcInfo Maybe RemoteCtrlId
rcId Maybe RemoteCtrlSessionState
sessState rc :: RemoteCtrl
rc@RemoteCtrl {RemoteCtrlId
remoteCtrlId :: RemoteCtrl -> RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId} =
      RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl
rc (Maybe RemoteCtrlSessionState -> RemoteCtrlInfo)
-> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
forall a b. (a -> b) -> a -> b
$ if Maybe RemoteCtrlId
rcId Maybe RemoteCtrlId -> Maybe RemoteCtrlId -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
remoteCtrlId then Maybe RemoteCtrlSessionState
sessState else Maybe RemoteCtrlSessionState
forall a. Maybe a
Nothing
    sessionRcId :: RemoteCtrlSession -> Maybe RemoteCtrlId
sessionRcId = \case
      RCSessionConnecting {Maybe RemoteCtrlId
remoteCtrlId_ :: RemoteCtrlSession -> Maybe RemoteCtrlId
remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_} -> Maybe RemoteCtrlId
remoteCtrlId_
      RCSessionPendingConfirmation {Maybe RemoteCtrlId
remoteCtrlId_ :: RemoteCtrlSession -> Maybe RemoteCtrlId
remoteCtrlId_ :: Maybe RemoteCtrlId
remoteCtrlId_} -> Maybe RemoteCtrlId
remoteCtrlId_
      RCSessionConnected {RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId :: RemoteCtrlSession -> RemoteCtrlId
remoteCtrlId} -> RemoteCtrlId -> Maybe RemoteCtrlId
forall a. a -> Maybe a
Just RemoteCtrlId
remoteCtrlId
      RemoteCtrlSession
_ -> Maybe RemoteCtrlId
forall a. Maybe a
Nothing

remoteCtrlInfo :: RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
remoteCtrlInfo :: RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl {RemoteCtrlId
remoteCtrlId :: RemoteCtrl -> RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId, Text
ctrlDeviceName :: Text
ctrlDeviceName :: RemoteCtrl -> Text
ctrlDeviceName} Maybe RemoteCtrlSessionState
sessionState =
  RemoteCtrlInfo {RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId, Text
ctrlDeviceName :: Text
ctrlDeviceName :: Text
ctrlDeviceName, Maybe RemoteCtrlSessionState
sessionState :: Maybe RemoteCtrlSessionState
sessionState :: Maybe RemoteCtrlSessionState
sessionState}

-- | Take a look at emoji of tlsunique, commit pairing, and start session server
verifyRemoteCtrlSession :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> CM RemoteCtrlInfo
verifyRemoteCtrlSession :: (ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse))
-> Text -> CM RemoteCtrlInfo
verifyRemoteCtrlSession ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC Text
sessCode' = do
  (SessionSeq
sseq, RCCtrlClient
client, Text
ctrlName, Text
sessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
vars) <-
    (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (SessionSeq, RemoteCtrlSession))
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession ExceptT
  ChatError
  (ReaderT ChatController IO)
  (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession)
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (SessionSeq, RCCtrlClient, Text, Text,
          RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (SessionSeq, RemoteCtrlSession)
Nothing -> ChatError
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (SessionSeq, RCCtrlClient, Text, Text,
       RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ChatError
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEInactive
      Just (SessionSeq
sseq, RCSessionPendingConfirmation {RCCtrlClient
rcsClient :: RemoteCtrlSession -> RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, ctrlDeviceName :: RemoteCtrlSession -> Text
ctrlDeviceName = Text
ctrlName, Text
sessionCode :: RemoteCtrlSession -> Text
sessionCode :: Text
sessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation :: RemoteCtrlSession -> RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation :: RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation}) -> (SessionSeq, RCCtrlClient, Text, Text,
 RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionSeq
sseq, RCCtrlClient
rcsClient, Text
ctrlName, Text
sessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
rcsWaitConfirmation)
      Maybe (SessionSeq, RemoteCtrlSession)
_ -> ChatError
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (SessionSeq, RCCtrlClient, Text, Text,
       RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ChatError
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SessionSeq, RCCtrlClient, Text, Text,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
  SessionSeq
-> (ChatError -> RemoteCtrlStopReason)
-> Text
-> CM RemoteCtrlInfo
-> CM RemoteCtrlInfo
forall a.
SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError SessionSeq
sseq ChatError -> RemoteCtrlStopReason
RCSRSetupFailed Text
"verifyRemoteCtrlSession" (CM RemoteCtrlInfo -> CM RemoteCtrlInfo)
-> CM RemoteCtrlInfo -> CM RemoteCtrlInfo
forall a b. (a -> b) -> a -> b
$ do
    let verified :: Bool
verified = Text -> Text -> Bool
sameVerificationCode Text
sessCode' Text
sessionCode
    ChatError -> SessionSeq -> CM () -> CM ()
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCETimeout) SessionSeq
networkIOTimeout (CM () -> CM ()) -> (IO () -> CM ()) -> IO () -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ RCCtrlClient -> Bool -> IO ()
confirmCtrlSession RCCtrlClient
client Bool
verified -- signal verification result before crashing
    Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl (RemoteCtrlError -> ChatError) -> RemoteCtrlError -> ChatError
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> RemoteCtrlError
RCEProtocolError RemoteProtocolError
PRESessionCode
    (rcsSession :: RCCtrlSession
rcsSession@RCCtrlSession {TLS 'TClient
tls :: TLS 'TClient
tls :: RCCtrlSession -> TLS 'TClient
tls, CtrlSessKeys
sessionKeys :: CtrlSessKeys
sessionKeys :: RCCtrlSession -> CtrlSessKeys
sessionKeys}, RCCtrlPairing
rcCtrlPairing) <- ChatError
-> SessionSeq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlSession, RCCtrlPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlSession, RCCtrlPairing)
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> SessionSeq -> ExceptT e m a -> ExceptT e m a
timeoutThrow (RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCETimeout) SessionSeq
networkIOTimeout (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (RCCtrlSession, RCCtrlPairing)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (RCCtrlSession, RCCtrlPairing))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlSession, RCCtrlPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlSession, RCCtrlPairing)
forall a b. (a -> b) -> a -> b
$ RCStepTMVar (RCCtrlSession, RCCtrlPairing)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RCCtrlSession, RCCtrlPairing)
forall a. RCStepTMVar a -> CM a
takeRCStep RCStepTMVar (RCCtrlSession, RCCtrlPairing)
vars
    rc :: RemoteCtrl
rc@RemoteCtrl {RemoteCtrlId
remoteCtrlId :: RemoteCtrl -> RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId} <- Text
-> RCCtrlPairing
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
upsertRemoteCtrl Text
ctrlName RCCtrlPairing
rcCtrlPairing
    TBQueue (Either ChatError ChatEvent)
remoteOutputQ <- (ChatController -> Natural)
-> ExceptT ChatError (ReaderT ChatController IO) Natural
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChatConfig -> Natural
tbqSize (ChatConfig -> Natural)
-> (ChatController -> ChatConfig) -> ChatController -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config) ExceptT ChatError (ReaderT ChatController IO) Natural
-> (Natural
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (TBQueue (Either ChatError ChatEvent)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TBQueue (Either ChatError ChatEvent))
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Natural
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TBQueue (Either ChatError ChatEvent))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO
    RemoteCrypto
encryption <- CtrlSessKeys -> ByteString -> CM RemoteCrypto
mkCtrlRemoteCrypto CtrlSessKeys
sessionKeys (ByteString -> CM RemoteCrypto) -> ByteString -> CM RemoteCrypto
forall a b. (a -> b) -> a -> b
$ TLS 'TClient -> ByteString
forall (p :: TransportPeer). TLS p -> ByteString
tlsUniq TLS 'TClient
tls
    ChatController
cc <- ExceptT ChatError (ReaderT ChatController IO) ChatController
forall r (m :: * -> *). MonadReader r m => m r
ask
    Async ()
http2Server <- IO (Async ())
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ())
 -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> (IO () -> IO (Async ()))
-> IO ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> ExceptT ChatError (ReaderT ChatController IO) (Async ()))
-> IO ()
-> ExceptT ChatError (ReaderT ChatController IO) (Async ())
forall a b. (a -> b) -> a -> b
$ TLS 'TClient -> (HTTP2Request -> IO ()) -> IO ()
attachHTTP2Server TLS 'TClient
tls ((HTTP2Request -> IO ()) -> IO ())
-> (HTTP2Request -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HTTP2Request
req -> (ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse))
-> RemoteCrypto
-> TBQueue (Either ChatError ChatEvent)
-> HTTP2Request
-> CM' ()
handleRemoteCommand ByteString -> SessionSeq -> CM' (Either ChatError ChatResponse)
execCC RemoteCrypto
encryption TBQueue (Either ChatError ChatEvent)
remoteOutputQ HTTP2Request
req CM' () -> ChatController -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ChatController
cc
    ExceptT ChatError (ReaderT ChatController IO) ThreadId -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) ThreadId -> CM ())
-> (CM ()
    -> ExceptT ChatError (ReaderT ChatController IO) ThreadId)
-> CM ()
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CM () -> ExceptT ChatError (ReaderT ChatController IO) ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ SessionSeq -> Async () -> CM ()
monitor SessionSeq
sseq Async ()
http2Server
    SessionSeq
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
updateRemoteCtrlSession SessionSeq
sseq ((RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
 -> CM ())
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
forall a b. (a -> b) -> a -> b
$ \case
      RCSessionPendingConfirmation {} -> RemoteCtrlSession -> Either ChatError RemoteCtrlSession
forall a b. b -> Either a b
Right RCSessionConnected {RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId, rcsClient :: RCCtrlClient
rcsClient = RCCtrlClient
client, RCCtrlSession
rcsSession :: RCCtrlSession
rcsSession :: RCCtrlSession
rcsSession, TLS 'TClient
tls :: TLS 'TClient
tls :: TLS 'TClient
tls, Async ()
http2Server :: Async ()
http2Server :: Async ()
http2Server, TBQueue (Either ChatError ChatEvent)
remoteOutputQ :: TBQueue (Either ChatError ChatEvent)
remoteOutputQ :: TBQueue (Either ChatError ChatEvent)
remoteOutputQ}
      RemoteCtrlSession
_ -> ChatError -> Either ChatError RemoteCtrlSession
forall a b. a -> Either a b
Left (ChatError -> Either ChatError RemoteCtrlSession)
-> ChatError -> Either ChatError RemoteCtrlSession
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
    RemoteCtrlInfo -> CM RemoteCtrlInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteCtrlInfo -> CM RemoteCtrlInfo)
-> RemoteCtrlInfo -> CM RemoteCtrlInfo
forall a b. (a -> b) -> a -> b
$ RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl
rc (Maybe RemoteCtrlSessionState -> RemoteCtrlInfo)
-> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo
forall a b. (a -> b) -> a -> b
$ RemoteCtrlSessionState -> Maybe RemoteCtrlSessionState
forall a. a -> Maybe a
Just RCSConnected {sessionCode :: Text
sessionCode = TLS 'TClient -> Text
forall (p :: TransportPeer). TLS p -> Text
tlsSessionCode TLS 'TClient
tls}
  where
    upsertRemoteCtrl :: Text -> RCCtrlPairing -> CM RemoteCtrl
    upsertRemoteCtrl :: Text
-> RCCtrlPairing
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
upsertRemoteCtrl Text
ctrlName RCCtrlPairing
rcCtrlPairing = (Connection -> ExceptT StoreError IO RemoteCtrl)
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RemoteCtrl)
 -> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl)
-> (Connection -> ExceptT StoreError IO RemoteCtrl)
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCtrl
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
      Maybe RemoteCtrl
rc_ <- IO (Maybe RemoteCtrl) -> ExceptT StoreError IO (Maybe RemoteCtrl)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe RemoteCtrl) -> ExceptT StoreError IO (Maybe RemoteCtrl))
-> IO (Maybe RemoteCtrl)
-> ExceptT StoreError IO (Maybe RemoteCtrl)
forall a b. (a -> b) -> a -> b
$ Connection -> KeyHash -> IO (Maybe RemoteCtrl)
getRemoteCtrlByFingerprint Connection
db (RCCtrlPairing -> KeyHash
ctrlFingerprint RCCtrlPairing
rcCtrlPairing)
      case Maybe RemoteCtrl
rc_ of
        Maybe RemoteCtrl
Nothing -> Connection
-> Text -> RCCtrlPairing -> ExceptT StoreError IO RemoteCtrlId
insertRemoteCtrl Connection
db Text
ctrlName RCCtrlPairing
rcCtrlPairing ExceptT StoreError IO RemoteCtrlId
-> (RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl)
-> ExceptT StoreError IO RemoteCtrl
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
getRemoteCtrl Connection
db
        Just rc :: RemoteCtrl
rc@RemoteCtrl {RCCtrlPairing
ctrlPairing :: RemoteCtrl -> RCCtrlPairing
ctrlPairing :: RCCtrlPairing
ctrlPairing} -> do
          let dhPrivKey' :: PrivateKeyX25519
dhPrivKey' = RCCtrlPairing -> PrivateKeyX25519
dhPrivKey RCCtrlPairing
rcCtrlPairing
          IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> RemoteCtrl -> Text -> PrivateKeyX25519 -> IO ()
updateRemoteCtrl Connection
db RemoteCtrl
rc Text
ctrlName PrivateKeyX25519
dhPrivKey'
          RemoteCtrl -> ExceptT StoreError IO RemoteCtrl
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteCtrl
rc {ctrlDeviceName = ctrlName, ctrlPairing = ctrlPairing {dhPrivKey = dhPrivKey'}}
    monitor :: SessionSeq -> Async () -> CM ()
    monitor :: SessionSeq -> Async () -> CM ()
monitor SessionSeq
sseq Async ()
server = do
      Either SomeException ()
res <- Async ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either SomeException ())
forall (m :: * -> *) a.
MonadIO m =>
Async a -> m (Either SomeException a)
waitCatch Async ()
server
      Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"HTTP2 server stopped: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either SomeException () -> Text
forall a. Show a => a -> Text
tshow Either SomeException ()
res
      Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
cancelActiveRemoteCtrl (Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ())
-> Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
forall a b. (a -> b) -> a -> b
$ (SessionSeq, RemoteCtrlStopReason)
-> Maybe (SessionSeq, RemoteCtrlStopReason)
forall a. a -> Maybe a
Just (SessionSeq
sseq, RemoteCtrlStopReason
RCSRDisconnected)

stopRemoteCtrl :: CM ()
stopRemoteCtrl :: CM ()
stopRemoteCtrl = Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
cancelActiveRemoteCtrl Maybe (SessionSeq, RemoteCtrlStopReason)
forall a. Maybe a
Nothing

handleCtrlError :: SessionSeq -> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError :: forall a.
SessionSeq
-> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a
handleCtrlError SessionSeq
sseq ChatError -> RemoteCtrlStopReason
mkReason Text
name CM a
action =
  CM a
action CM a -> (ChatError -> CM a) -> CM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> do
    Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" remote ctrl error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
e
    Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
cancelActiveRemoteCtrl (Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ())
-> Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
forall a b. (a -> b) -> a -> b
$ (SessionSeq, RemoteCtrlStopReason)
-> Maybe (SessionSeq, RemoteCtrlStopReason)
forall a. a -> Maybe a
Just (SessionSeq
sseq, ChatError -> RemoteCtrlStopReason
mkReason ChatError
e)
    ChatError -> CM a
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e

-- | Stop session controller, unless session update key is present but stale
cancelActiveRemoteCtrl :: Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
cancelActiveRemoteCtrl :: Maybe (SessionSeq, RemoteCtrlStopReason) -> CM ()
cancelActiveRemoteCtrl Maybe (SessionSeq, RemoteCtrlStopReason)
handlerInfo_ = (SomeException -> CM ()) -> CM () -> CM ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (Text -> CM ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> CM ())
-> (SomeException -> Text) -> SomeException -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall a. Show a => a -> Text
tshow) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
  TVar (Maybe (SessionSeq, RemoteCtrlSession))
var <- (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TVar (Maybe (SessionSeq, RemoteCtrlSession)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession
  Maybe RemoteCtrlSession
session_ <-
    STM (Maybe RemoteCtrlSession)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe RemoteCtrlSession)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RemoteCtrlSession)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe RemoteCtrlSession))
-> STM (Maybe RemoteCtrlSession)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe RemoteCtrlSession)
forall a b. (a -> b) -> a -> b
$
      TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> STM (Maybe (SessionSeq, RemoteCtrlSession))
forall a. TVar a -> STM a
readTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
var STM (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession)
    -> STM (Maybe RemoteCtrlSession))
-> STM (Maybe RemoteCtrlSession)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (SessionSeq, RemoteCtrlSession)
Nothing -> Maybe RemoteCtrlSession -> STM (Maybe RemoteCtrlSession)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteCtrlSession
forall a. Maybe a
Nothing
        Just (SessionSeq
oldSeq, RemoteCtrlSession
_) | (Bool
-> ((SessionSeq, RemoteCtrlStopReason) -> Bool)
-> Maybe (SessionSeq, RemoteCtrlStopReason)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((SessionSeq
oldSeq SessionSeq -> SessionSeq -> Bool
forall a. Eq a => a -> a -> Bool
/=) (SessionSeq -> Bool)
-> ((SessionSeq, RemoteCtrlStopReason) -> SessionSeq)
-> (SessionSeq, RemoteCtrlStopReason)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionSeq, RemoteCtrlStopReason) -> SessionSeq
forall a b. (a, b) -> a
fst) Maybe (SessionSeq, RemoteCtrlStopReason)
handlerInfo_) -> Maybe RemoteCtrlSession -> STM (Maybe RemoteCtrlSession)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RemoteCtrlSession
forall a. Maybe a
Nothing
        Just (SessionSeq
_, RemoteCtrlSession
s) -> RemoteCtrlSession -> Maybe RemoteCtrlSession
forall a. a -> Maybe a
Just RemoteCtrlSession
s Maybe RemoteCtrlSession -> STM () -> STM (Maybe RemoteCtrlSession)
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> Maybe (SessionSeq, RemoteCtrlSession) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
var Maybe (SessionSeq, RemoteCtrlSession)
forall a. Maybe a
Nothing
  Maybe RemoteCtrlSession -> (RemoteCtrlSession -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe RemoteCtrlSession
session_ ((RemoteCtrlSession -> CM ()) -> CM ())
-> (RemoteCtrlSession -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \RemoteCtrlSession
session -> do
    IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ Bool -> RemoteCtrlSession -> IO ()
cancelRemoteCtrl Bool
handlingError RemoteCtrlSession
session
    Maybe RemoteCtrlStopReason
-> (RemoteCtrlStopReason -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((SessionSeq, RemoteCtrlStopReason) -> RemoteCtrlStopReason
forall a b. (a, b) -> b
snd ((SessionSeq, RemoteCtrlStopReason) -> RemoteCtrlStopReason)
-> Maybe (SessionSeq, RemoteCtrlStopReason)
-> Maybe RemoteCtrlStopReason
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SessionSeq, RemoteCtrlStopReason)
handlerInfo_) ((RemoteCtrlStopReason -> CM ()) -> CM ())
-> (RemoteCtrlStopReason -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \RemoteCtrlStopReason
rcStopReason ->
      ChatEvent -> CM ()
toView CEvtRemoteCtrlStopped {rcsState :: RemoteCtrlSessionState
rcsState = RemoteCtrlSession -> RemoteCtrlSessionState
rcsSessionState RemoteCtrlSession
session, RemoteCtrlStopReason
rcStopReason :: RemoteCtrlStopReason
rcStopReason :: RemoteCtrlStopReason
rcStopReason}
  where
    handlingError :: Bool
handlingError = Maybe (SessionSeq, RemoteCtrlStopReason) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SessionSeq, RemoteCtrlStopReason)
handlerInfo_

cancelRemoteCtrl :: Bool -> RemoteCtrlSession -> IO ()
cancelRemoteCtrl :: Bool -> RemoteCtrlSession -> IO ()
cancelRemoteCtrl Bool
handlingError = \case
  RemoteCtrlSession
RCSessionStarting -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  RCSessionSearching {Async ()
action :: RemoteCtrlSession -> Async ()
action :: Async ()
action} ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
action
  RCSessionConnecting {RCCtrlClient
rcsClient :: RemoteCtrlSession -> RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, Async ()
rcsWaitSession :: RemoteCtrlSession -> Async ()
rcsWaitSession :: Async ()
rcsWaitSession} -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
rcsWaitSession
    RCCtrlClient -> IO ()
cancelCtrlClient RCCtrlClient
rcsClient
  RCSessionPendingConfirmation {RCCtrlClient
rcsClient :: RemoteCtrlSession -> RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, TLS 'TClient
tls :: RemoteCtrlSession -> TLS 'TClient
tls :: TLS 'TClient
tls, Async ()
rcsWaitSession :: RemoteCtrlSession -> Async ()
rcsWaitSession :: Async ()
rcsWaitSession} -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
rcsWaitSession
    RCCtrlClient -> IO ()
cancelCtrlClient RCCtrlClient
rcsClient
    TLS 'TClient -> IO ()
forall (p :: TransportPeer). TLS p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection TLS 'TClient
tls
  RCSessionConnected {RCCtrlClient
rcsClient :: RemoteCtrlSession -> RCCtrlClient
rcsClient :: RCCtrlClient
rcsClient, TLS 'TClient
tls :: RemoteCtrlSession -> TLS 'TClient
tls :: TLS 'TClient
tls, Async ()
http2Server :: RemoteCtrlSession -> Async ()
http2Server :: Async ()
http2Server} -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handlingError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
http2Server
    RCCtrlClient -> IO ()
cancelCtrlClient RCCtrlClient
rcsClient
    TLS 'TClient -> IO ()
forall (p :: TransportPeer). TLS p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection TLS 'TClient
tls

deleteRemoteCtrl :: RemoteCtrlId -> CM ()
deleteRemoteCtrl :: RemoteCtrlId -> CM ()
deleteRemoteCtrl RemoteCtrlId
rcId = do
  CM ()
checkNoRemoteCtrlSession
  -- TODO check it exists
  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> RemoteCtrlId -> IO ()
`deleteRemoteCtrlRecord` RemoteCtrlId
rcId)

checkNoRemoteCtrlSession :: CM ()
checkNoRemoteCtrlSession :: CM ()
checkNoRemoteCtrlSession =
  (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (SessionSeq, RemoteCtrlSession))
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession ExceptT
  ChatError
  (ReaderT ChatController IO)
  (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession) -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CM ()
-> ((SessionSeq, RemoteCtrlSession) -> CM ())
-> Maybe (SessionSeq, RemoteCtrlSession)
-> CM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\(SessionSeq, RemoteCtrlSession)
_ -> ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBusy)

-- | Transition controller to a new state, unless session update key is stale
updateRemoteCtrlSession :: SessionSeq -> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession) -> CM ()
updateRemoteCtrlSession :: SessionSeq
-> (RemoteCtrlSession -> Either ChatError RemoteCtrlSession)
-> CM ()
updateRemoteCtrlSession SessionSeq
sseq RemoteCtrlSession -> Either ChatError RemoteCtrlSession
state = do
  TVar (Maybe (SessionSeq, RemoteCtrlSession))
session <- (ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TVar (Maybe (SessionSeq, RemoteCtrlSession)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (SessionSeq, RemoteCtrlSession))
remoteCtrlSession
  Either ChatError ()
r <- STM (Either ChatError ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ChatError ())
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Either ChatError ()))
-> STM (Either ChatError ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ do
    TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> STM (Maybe (SessionSeq, RemoteCtrlSession))
forall a. TVar a -> STM a
readTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session STM (Maybe (SessionSeq, RemoteCtrlSession))
-> (Maybe (SessionSeq, RemoteCtrlSession)
    -> STM (Either ChatError ()))
-> STM (Either ChatError ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (SessionSeq, RemoteCtrlSession)
Nothing -> Either ChatError () -> STM (Either ChatError ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError () -> STM (Either ChatError ()))
-> (ChatError -> Either ChatError ())
-> ChatError
-> STM (Either ChatError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError ()
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError ()))
-> ChatError -> STM (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEInactive
      Just (SessionSeq
oldSeq, RemoteCtrlSession
st)
        | SessionSeq
oldSeq SessionSeq -> SessionSeq -> Bool
forall a. Eq a => a -> a -> Bool
/= SessionSeq
sseq -> Either ChatError () -> STM (Either ChatError ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError () -> STM (Either ChatError ()))
-> (ChatError -> Either ChatError ())
-> ChatError
-> STM (Either ChatError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatError -> Either ChatError ()
forall a b. a -> Either a b
Left (ChatError -> STM (Either ChatError ()))
-> ChatError -> STM (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ RemoteCtrlError -> ChatError
ChatErrorRemoteCtrl RemoteCtrlError
RCEBadState
        | Bool
otherwise -> case RemoteCtrlSession -> Either ChatError RemoteCtrlSession
state RemoteCtrlSession
st of
            Left ChatError
ce -> Either ChatError () -> STM (Either ChatError ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError () -> STM (Either ChatError ()))
-> Either ChatError () -> STM (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ ChatError -> Either ChatError ()
forall a b. a -> Either a b
Left ChatError
ce
            Right RemoteCtrlSession
st' -> () -> Either ChatError ()
forall a b. b -> Either a b
Right () Either ChatError () -> STM () -> STM (Either ChatError ())
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Maybe (SessionSeq, RemoteCtrlSession))
-> Maybe (SessionSeq, RemoteCtrlSession) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (SessionSeq, RemoteCtrlSession))
session ((SessionSeq, RemoteCtrlSession)
-> Maybe (SessionSeq, RemoteCtrlSession)
forall a. a -> Maybe a
Just (SessionSeq
sseq, RemoteCtrlSession
st'))
  Either ChatError () -> CM ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either ChatError ()
r

utf8String :: [Char] -> ByteString
utf8String :: FilePath -> ByteString
utf8String = Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
{-# INLINE utf8String #-}