{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module Simplex.Chat.Remote.Protocol where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Crypto.Hash (SHA512)
import qualified Crypto.Hash as CH
import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Key as JK
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Builder (Builder, byteString, lazyByteString)
import qualified Data.ByteString.Lazy as LB
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Word (Word32)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Client as H
import Network.Transport.Internal (decodeWord32, encodeWord32)
import Simplex.Chat.Controller
import Simplex.Chat.Remote.Transport
import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TSbChainKeys)
import Simplex.Messaging.Transport.Buffer (getBuffered)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
import Simplex.Messaging.Util (liftError', liftEitherWith, liftError, tshow)
import Simplex.RemoteControl.Client (xrcpBlockSize)
import qualified Simplex.RemoteControl.Client as RC
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import System.FilePath (takeFileName, (</>))
import UnliftIO

data RemoteCommand
  = RCSend {RemoteCommand -> Text
command :: Text, RemoteCommand -> Int
retryNumber :: Int}
  | RCRecv {RemoteCommand -> Int
wait :: Int} -- this wait should be less than HTTP timeout
  | -- local file encryption is determined by the host, but can be overridden for videos
    RCStoreFile {RemoteCommand -> String
fileName :: String, RemoteCommand -> Word32
fileSize :: Word32, RemoteCommand -> FileDigest
fileDigest :: FileDigest} -- requires attachment
  | RCGetFile {RemoteCommand -> RemoteFile
file :: RemoteFile}
  deriving (Int -> RemoteCommand -> ShowS
[RemoteCommand] -> ShowS
RemoteCommand -> String
(Int -> RemoteCommand -> ShowS)
-> (RemoteCommand -> String)
-> ([RemoteCommand] -> ShowS)
-> Show RemoteCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RemoteCommand -> ShowS
showsPrec :: Int -> RemoteCommand -> ShowS
$cshow :: RemoteCommand -> String
show :: RemoteCommand -> String
$cshowList :: [RemoteCommand] -> ShowS
showList :: [RemoteCommand] -> ShowS
Show)

data RemoteResponse
  = RRChatResponse {RemoteResponse -> RRResult ChatResponse
chatResponse :: RRResult ChatResponse}
  | RRChatEvent {RemoteResponse -> Maybe (RRResult ChatEvent)
chatEvent :: Maybe (RRResult ChatEvent)} -- 'Nothing' on poll timeout
  | RRFileStored {RemoteResponse -> String
filePath :: String}
  | RRFile {RemoteResponse -> Word32
fileSize :: Word32, RemoteResponse -> FileDigest
fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
  | RRProtocolError {RemoteResponse -> RemoteProtocolError
remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
  deriving (Int -> RemoteResponse -> ShowS
[RemoteResponse] -> ShowS
RemoteResponse -> String
(Int -> RemoteResponse -> ShowS)
-> (RemoteResponse -> String)
-> ([RemoteResponse] -> ShowS)
-> Show RemoteResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RemoteResponse -> ShowS
showsPrec :: Int -> RemoteResponse -> ShowS
$cshow :: RemoteResponse -> String
show :: RemoteResponse -> String
$cshowList :: [RemoteResponse] -> ShowS
showList :: [RemoteResponse] -> ShowS
Show)

data RRResult r
  = RRResult {forall r. RRResult r -> r
result :: r}
  | RRError {forall r. RRResult r -> ChatError
error :: ChatError}
  deriving (Int -> RRResult r -> ShowS
[RRResult r] -> ShowS
RRResult r -> String
(Int -> RRResult r -> ShowS)
-> (RRResult r -> String)
-> ([RRResult r] -> ShowS)
-> Show (RRResult r)
forall r. Show r => Int -> RRResult r -> ShowS
forall r. Show r => [RRResult r] -> ShowS
forall r. Show r => RRResult r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> RRResult r -> ShowS
showsPrec :: Int -> RRResult r -> ShowS
$cshow :: forall r. Show r => RRResult r -> String
show :: RRResult r -> String
$cshowList :: forall r. Show r => [RRResult r] -> ShowS
showList :: [RRResult r] -> ShowS
Show)

resultToEither :: RRResult r -> Either ChatError r
resultToEither :: forall r. RRResult r -> Either ChatError r
resultToEither = \case
  RRResult r
r -> r -> Either ChatError r
forall a b. b -> Either a b
Right r
r
  RRError ChatError
e -> ChatError -> Either ChatError r
forall a b. a -> Either a b
Left ChatError
e
{-# INLINE resultToEither #-}

eitherToResult :: Either ChatError r -> RRResult r
eitherToResult :: forall r. Either ChatError r -> RRResult r
eitherToResult = (ChatError -> RRResult r)
-> (r -> RRResult r) -> Either ChatError r -> RRResult r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ChatError -> RRResult r
forall r. ChatError -> RRResult r
RRError r -> RRResult r
forall r. r -> RRResult r
RRResult
{-# INLINE eitherToResult #-}

$(pure [])

-- Force platform-independent encoding as the types aren't UI-visible
instance ToJSON r => ToJSON (RRResult r) where
  toEncoding :: RRResult r -> Encoding
toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)
  toJSON :: RRResult r -> Value
toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)

instance FromJSON r => FromJSON (RRResult r) where
  parseJSON :: Value -> Parser (RRResult r)
parseJSON = $(JQ.mkParseJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)

$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)

-- * Client side / desktop

mkRemoteHostClient :: HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> CM RemoteHostClient
mkRemoteHostClient :: HTTP2Client
-> HostSessKeys
-> ByteString
-> String
-> HostAppInfo
-> CM RemoteHostClient
mkRemoteHostClient HTTP2Client
httpClient HostSessKeys
sessionKeys ByteString
sessionCode String
storePath HostAppInfo {PlatformEncoding
encoding :: PlatformEncoding
encoding :: HostAppInfo -> PlatformEncoding
encoding, Text
deviceName :: Text
deviceName :: HostAppInfo -> Text
deviceName, Bool
encryptFiles :: Bool
encryptFiles :: HostAppInfo -> Bool
encryptFiles} = do
  let HostSessKeys {TSbChainKeys
chainKeys :: TSbChainKeys
chainKeys :: HostSessKeys -> TSbChainKeys
chainKeys, PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey :: HostSessKeys -> PrivateKeyEd25519
idPrivKey, PrivateKeyEd25519
sessPrivKey :: PrivateKeyEd25519
sessPrivKey :: HostSessKeys -> PrivateKeyEd25519
sessPrivKey} = HostSessKeys
sessionKeys
      signatures :: RemoteSignatures
signatures = RSSign {PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey, PrivateKeyEd25519
sessPrivKey :: PrivateKeyEd25519
sessPrivKey :: PrivateKeyEd25519
sessPrivKey}
  RemoteCrypto
encryption <- IO RemoteCrypto
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteCrypto
 -> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto)
-> IO RemoteCrypto
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto
forall a b. (a -> b) -> a -> b
$ ByteString -> TSbChainKeys -> RemoteSignatures -> IO RemoteCrypto
mkRemoteCrypto ByteString
sessionCode TSbChainKeys
chainKeys RemoteSignatures
signatures
  RemoteHostClient -> CM RemoteHostClient
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    RemoteHostClient
      { hostEncoding :: PlatformEncoding
hostEncoding = PlatformEncoding
encoding,
        hostDeviceName :: Text
hostDeviceName = Text
deviceName,
        HTTP2Client
httpClient :: HTTP2Client
httpClient :: HTTP2Client
httpClient,
        RemoteCrypto
encryption :: RemoteCrypto
encryption :: RemoteCrypto
encryption,
        encryptHostFiles :: Bool
encryptHostFiles = Bool
encryptFiles,
        String
storePath :: String
storePath :: String
storePath
      }

mkCtrlRemoteCrypto :: CtrlSessKeys -> SessionCode -> CM RemoteCrypto
mkCtrlRemoteCrypto :: CtrlSessKeys
-> ByteString
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto
mkCtrlRemoteCrypto CtrlSessKeys {TSbChainKeys
chainKeys :: TSbChainKeys
chainKeys :: CtrlSessKeys -> TSbChainKeys
chainKeys, PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey :: CtrlSessKeys -> PublicKeyEd25519
idPubKey, PublicKeyEd25519
sessPubKey :: PublicKeyEd25519
sessPubKey :: CtrlSessKeys -> PublicKeyEd25519
sessPubKey} ByteString
sessionCode =
  let signatures :: RemoteSignatures
signatures = RSVerify {PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey, PublicKeyEd25519
sessPubKey :: PublicKeyEd25519
sessPubKey :: PublicKeyEd25519
sessPubKey}
   in IO RemoteCrypto
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteCrypto
 -> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto)
-> IO RemoteCrypto
-> ExceptT ChatError (ReaderT ChatController IO) RemoteCrypto
forall a b. (a -> b) -> a -> b
$ ByteString -> TSbChainKeys -> RemoteSignatures -> IO RemoteCrypto
mkRemoteCrypto ByteString
sessionCode TSbChainKeys
chainKeys RemoteSignatures
signatures

mkRemoteCrypto :: SessionCode -> TSbChainKeys -> RemoteSignatures -> IO RemoteCrypto
mkRemoteCrypto :: ByteString -> TSbChainKeys -> RemoteSignatures -> IO RemoteCrypto
mkRemoteCrypto ByteString
sessionCode TSbChainKeys
chainKeys RemoteSignatures
signatures = do
  TVar Word32
sndCounter <- Word32 -> IO (TVar Word32)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Word32
0
  TVar Word32
rcvCounter <- Word32 -> IO (TVar Word32)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Word32
0
  TMap Word32 (SbKeyNonce, SbKeyNonce)
skippedKeys <- IO (TMap Word32 (SbKeyNonce, SbKeyNonce))
-> IO (TMap Word32 (SbKeyNonce, SbKeyNonce))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMap Word32 (SbKeyNonce, SbKeyNonce))
forall k a. IO (TMap k a)
TM.emptyIO
  RemoteCrypto -> IO RemoteCrypto
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteCrypto {ByteString
sessionCode :: ByteString
sessionCode :: ByteString
sessionCode, TVar Word32
sndCounter :: TVar Word32
sndCounter :: TVar Word32
sndCounter, TVar Word32
rcvCounter :: TVar Word32
rcvCounter :: TVar Word32
rcvCounter, TSbChainKeys
chainKeys :: TSbChainKeys
chainKeys :: TSbChainKeys
chainKeys, TMap Word32 (SbKeyNonce, SbKeyNonce)
skippedKeys :: TMap Word32 (SbKeyNonce, SbKeyNonce)
skippedKeys :: TMap Word32 (SbKeyNonce, SbKeyNonce)
skippedKeys, RemoteSignatures
signatures :: RemoteSignatures
signatures :: RemoteSignatures
signatures}

closeRemoteHostClient :: RemoteHostClient -> IO ()
closeRemoteHostClient :: RemoteHostClient -> IO ()
closeRemoteHostClient RemoteHostClient {HTTP2Client
httpClient :: RemoteHostClient -> HTTP2Client
httpClient :: HTTP2Client
httpClient} = HTTP2Client -> IO ()
closeHTTP2Client HTTP2Client
httpClient

-- ** Commands

remoteSend :: RemoteHostClient -> ByteString -> Int -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
remoteSend :: RemoteHostClient
-> ByteString
-> Int
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
remoteSend RemoteHostClient
c ByteString
cmd Int
retryNumber =
  RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT RemoteProtocolError IO RemoteResponse
sendRemoteCommand' RemoteHostClient
c Maybe (Handle, Word32)
forall a. Maybe a
Nothing RCSend {command :: Text
command = ByteString -> Text
decodeUtf8 ByteString
cmd, Int
retryNumber :: Int
retryNumber :: Int
retryNumber} ExceptT RemoteProtocolError IO RemoteResponse
-> (RemoteResponse
    -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse))
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
forall a b.
ExceptT RemoteProtocolError IO a
-> (a -> ExceptT RemoteProtocolError IO b)
-> ExceptT RemoteProtocolError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    RRChatResponse RRResult ChatResponse
cr -> Either ChatError ChatResponse
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ChatError ChatResponse
 -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse))
-> Either ChatError ChatResponse
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
forall a b. (a -> b) -> a -> b
$ RRResult ChatResponse -> Either ChatError ChatResponse
forall r. RRResult r -> Either ChatError r
resultToEither RRResult ChatResponse
cr
    RemoteResponse
r -> RemoteResponse
-> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
forall a. RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse RemoteResponse
r

remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
remoteRecv :: RemoteHostClient
-> Int
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
remoteRecv RemoteHostClient
c Int
ms =
  RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT RemoteProtocolError IO RemoteResponse
sendRemoteCommand' RemoteHostClient
c Maybe (Handle, Word32)
forall a. Maybe a
Nothing RCRecv {wait :: Int
wait = Int
ms} ExceptT RemoteProtocolError IO RemoteResponse
-> (RemoteResponse
    -> ExceptT
         RemoteProtocolError IO (Maybe (Either ChatError ChatEvent)))
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
forall a b.
ExceptT RemoteProtocolError IO a
-> (a -> ExceptT RemoteProtocolError IO b)
-> ExceptT RemoteProtocolError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    RRChatEvent Maybe (RRResult ChatEvent)
cEvt_ -> Maybe (Either ChatError ChatEvent)
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either ChatError ChatEvent)
 -> ExceptT
      RemoteProtocolError IO (Maybe (Either ChatError ChatEvent)))
-> Maybe (Either ChatError ChatEvent)
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
forall a b. (a -> b) -> a -> b
$ RRResult ChatEvent -> Either ChatError ChatEvent
forall r. RRResult r -> Either ChatError r
resultToEither (RRResult ChatEvent -> Either ChatError ChatEvent)
-> Maybe (RRResult ChatEvent) -> Maybe (Either ChatError ChatEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RRResult ChatEvent)
cEvt_
    RemoteResponse
r -> RemoteResponse
-> ExceptT
     RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
forall a. RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse RemoteResponse
r

remoteStoreFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
remoteStoreFile :: RemoteHostClient
-> String -> String -> ExceptT RemoteProtocolError IO String
remoteStoreFile RemoteHostClient
c String
localPath String
fileName = do
  (Word32
fileSize, FileDigest
fileDigest) <- String -> ExceptT RemoteProtocolError IO (Word32, FileDigest)
getFileInfo String
localPath
  let send :: Handle -> ExceptT RemoteProtocolError IO RemoteResponse
send Handle
h = RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT RemoteProtocolError IO RemoteResponse
sendRemoteCommand' RemoteHostClient
c ((Handle, Word32) -> Maybe (Handle, Word32)
forall a. a -> Maybe a
Just (Handle
h, Word32
fileSize)) RCStoreFile {String
fileName :: String
fileName :: String
fileName, Word32
fileSize :: Word32
fileSize :: Word32
fileSize, FileDigest
fileDigest :: FileDigest
fileDigest :: FileDigest
fileDigest}
  String
-> IOMode
-> (Handle -> ExceptT RemoteProtocolError IO RemoteResponse)
-> ExceptT RemoteProtocolError IO RemoteResponse
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
localPath IOMode
ReadMode Handle -> ExceptT RemoteProtocolError IO RemoteResponse
send ExceptT RemoteProtocolError IO RemoteResponse
-> (RemoteResponse -> ExceptT RemoteProtocolError IO String)
-> ExceptT RemoteProtocolError IO String
forall a b.
ExceptT RemoteProtocolError IO a
-> (a -> ExceptT RemoteProtocolError IO b)
-> ExceptT RemoteProtocolError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    RRFileStored {filePath :: RemoteResponse -> String
filePath = String
filePath'} -> String -> ExceptT RemoteProtocolError IO String
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
filePath'
    RemoteResponse
r -> RemoteResponse -> ExceptT RemoteProtocolError IO String
forall a. RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse RemoteResponse
r

remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile :: RemoteHostClient
-> String -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile RemoteHostClient
c String
destDir rf :: RemoteFile
rf@RemoteFile {fileSource :: RemoteFile -> CryptoFile
fileSource = CryptoFile {String
filePath :: String
filePath :: CryptoFile -> String
filePath}} =
  RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
sendRemoteCommand RemoteHostClient
c Maybe (Handle, Word32)
forall a. Maybe a
Nothing RCGetFile {file :: RemoteFile
file = RemoteFile
rf} ExceptT
  RemoteProtocolError
  IO
  (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
-> ((SbKeyNonce, Int -> IO ByteString, RemoteResponse)
    -> ExceptT RemoteProtocolError IO ())
-> ExceptT RemoteProtocolError IO ()
forall a b.
ExceptT RemoteProtocolError IO a
-> (a -> ExceptT RemoteProtocolError IO b)
-> ExceptT RemoteProtocolError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (SbKeyNonce
rfKN, Int -> IO ByteString
getChunk, RRFile {Word32
fileSize :: RemoteResponse -> Word32
fileSize :: Word32
fileSize, FileDigest
fileDigest :: RemoteResponse -> FileDigest
fileDigest :: FileDigest
fileDigest}) -> do
      -- TODO we could optimize by checking size and hash before receiving the file
      let localPath :: String
localPath = String
destDir String -> ShowS
</> ShowS
takeFileName String
filePath
      SbKeyNonce
-> (Int -> IO ByteString)
-> Word32
-> FileDigest
-> String
-> ExceptT RemoteProtocolError IO ()
receiveEncryptedFile SbKeyNonce
rfKN Int -> IO ByteString
getChunk Word32
fileSize FileDigest
fileDigest String
localPath
    (SbKeyNonce
_, Int -> IO ByteString
_, RemoteResponse
r) -> RemoteResponse -> ExceptT RemoteProtocolError IO ()
forall a. RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse RemoteResponse
r

-- TODO validate there is no attachment in response
sendRemoteCommand' :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO RemoteResponse
sendRemoteCommand' :: RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT RemoteProtocolError IO RemoteResponse
sendRemoteCommand' RemoteHostClient
c Maybe (Handle, Word32)
attachment_ RemoteCommand
rc = do
  (SbKeyNonce
_, Int -> IO ByteString
_, RemoteResponse
r) <- RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
sendRemoteCommand RemoteHostClient
c Maybe (Handle, Word32)
attachment_ RemoteCommand
rc
  RemoteResponse -> ExceptT RemoteProtocolError IO RemoteResponse
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RemoteResponse
r

sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, Int -> IO ByteString, RemoteResponse)
sendRemoteCommand :: RemoteHostClient
-> Maybe (Handle, Word32)
-> RemoteCommand
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
sendRemoteCommand RemoteHostClient {HTTP2Client
httpClient :: RemoteHostClient -> HTTP2Client
httpClient :: HTTP2Client
httpClient, PlatformEncoding
hostEncoding :: RemoteHostClient -> PlatformEncoding
hostEncoding :: PlatformEncoding
hostEncoding, RemoteCrypto
encryption :: RemoteHostClient -> RemoteCrypto
encryption :: RemoteCrypto
encryption} Maybe (Handle, Word32)
file_ RemoteCommand
cmd = do
  (Word32
corrId, SbKeyNonce
cmdKN, SbKeyNonce
sfKN) <- STM (Word32, SbKeyNonce, SbKeyNonce)
-> ExceptT RemoteProtocolError IO (Word32, SbKeyNonce, SbKeyNonce)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Word32, SbKeyNonce, SbKeyNonce)
 -> ExceptT RemoteProtocolError IO (Word32, SbKeyNonce, SbKeyNonce))
-> STM (Word32, SbKeyNonce, SbKeyNonce)
-> ExceptT RemoteProtocolError IO (Word32, SbKeyNonce, SbKeyNonce)
forall a b. (a -> b) -> a -> b
$ RemoteCrypto -> STM (Word32, SbKeyNonce, SbKeyNonce)
getRemoteSndKeys RemoteCrypto
encryption
  Builder
encCmd <- Word32
-> SbKeyNonce
-> RemoteCrypto
-> LazyByteString
-> ExceptT RemoteProtocolError IO Builder
encryptEncodeHTTP2Body Word32
corrId SbKeyNonce
cmdKN RemoteCrypto
encryption (LazyByteString -> ExceptT RemoteProtocolError IO Builder)
-> LazyByteString -> ExceptT RemoteProtocolError IO Builder
forall a b. (a -> b) -> a -> b
$ RemoteCommand -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
J.encode RemoteCommand
cmd
  Maybe EncryptedFile
encFile_ <- ((Handle, Word32) -> ExceptT RemoteProtocolError IO EncryptedFile)
-> Maybe (Handle, Word32)
-> ExceptT RemoteProtocolError IO (Maybe EncryptedFile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (SbKeyNonce
-> (Handle, Word32) -> ExceptT RemoteProtocolError IO EncryptedFile
prepareEncryptedFile SbKeyNonce
sfKN) Maybe (Handle, Word32)
file_
  let req :: Request
req = Maybe EncryptedFile -> Builder -> Request
forall {t :: * -> *}.
Foldable t =>
t EncryptedFile -> Builder -> Request
httpRequest Maybe EncryptedFile
encFile_ Builder
encCmd
  HTTP2Response {Response
response :: Response
response :: HTTP2Response -> Response
response, HTTP2Body
respBody :: HTTP2Body
respBody :: HTTP2Response -> HTTP2Body
respBody} <- (HTTP2ClientError -> RemoteProtocolError)
-> IO (Either HTTP2ClientError HTTP2Response)
-> ExceptT RemoteProtocolError IO HTTP2Response
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' (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) (IO (Either HTTP2ClientError HTTP2Response)
 -> ExceptT RemoteProtocolError IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Response)
-> ExceptT RemoteProtocolError IO HTTP2Response
forall a b. (a -> b) -> a -> b
$ HTTP2Client
-> Request
-> Maybe Int
-> IO (Either HTTP2ClientError HTTP2Response)
sendRequestDirect HTTP2Client
httpClient Request
req Maybe Int
forall a. Maybe a
Nothing
  (SbKeyNonce
rfKN, LazyByteString
header, Int -> IO ByteString
getNext) <- RemoteCrypto
-> Response
-> HTTP2Body
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, Int -> IO ByteString)
forall a.
HTTP2BodyChunk a =>
RemoteCrypto
-> a
-> HTTP2Body
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, Int -> IO ByteString)
parseDecryptHTTP2Body RemoteCrypto
encryption Response
response HTTP2Body
respBody
  RemoteResponse
rr <- (String -> RemoteProtocolError)
-> Either String RemoteResponse
-> ExceptT RemoteProtocolError IO RemoteResponse
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (String -> RemoteProtocolError
RPEInvalidJSON (String -> RemoteProtocolError)
-> ShowS -> String -> RemoteProtocolError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. IsString a => String -> a
fromString) (Either String RemoteResponse
 -> ExceptT RemoteProtocolError IO RemoteResponse)
-> Either String RemoteResponse
-> ExceptT RemoteProtocolError IO RemoteResponse
forall a b. (a -> b) -> a -> b
$ LazyByteString -> Either String Value
forall a. FromJSON a => LazyByteString -> Either String a
J.eitherDecode LazyByteString
header Either String Value
-> (Value -> Either String RemoteResponse)
-> Either String RemoteResponse
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser RemoteResponse)
-> Value -> Either String RemoteResponse
forall a b. (a -> Parser b) -> a -> Either String b
JT.parseEither Value -> Parser RemoteResponse
forall a. FromJSON a => Value -> Parser a
J.parseJSON (Value -> Either String RemoteResponse)
-> (Value -> Value) -> Value -> Either String RemoteResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlatformEncoding -> PlatformEncoding -> Value -> Value
convertJSON PlatformEncoding
hostEncoding PlatformEncoding
localEncoding
  (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, Int -> IO ByteString, RemoteResponse)
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SbKeyNonce
rfKN, Int -> IO ByteString
getNext, RemoteResponse
rr)
  where
    httpRequest :: t EncryptedFile -> Builder -> Request
httpRequest t EncryptedFile
encFile_ Builder
cmdBld = ByteString
-> ByteString
-> RequestHeaders
-> ((Builder -> IO ()) -> IO () -> IO ())
-> Request
H.requestStreaming ByteString
N.methodPost ByteString
"/" RequestHeaders
forall a. Monoid a => a
mempty (((Builder -> IO ()) -> IO () -> IO ()) -> Request)
-> ((Builder -> IO ()) -> IO () -> IO ()) -> Request
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
send IO ()
flush -> do
      Builder -> IO ()
send Builder
cmdBld
      t EncryptedFile -> (EncryptedFile -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t EncryptedFile
encFile_ (EncryptedFile -> (Builder -> IO ()) -> IO ()
`sendEncryptedFile` Builder -> IO ()
send)
      IO ()
flush

badResponse :: RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse :: forall a. RemoteResponse -> ExceptT RemoteProtocolError IO a
badResponse = \case
  RRProtocolError RemoteProtocolError
e -> RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall a. RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RemoteProtocolError
e
  -- TODO handle chat errors?
  RemoteResponse
r -> RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall a. RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RemoteProtocolError -> ExceptT RemoteProtocolError IO a)
-> RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall a b. (a -> b) -> a -> b
$ Text -> RemoteProtocolError
RPEUnexpectedResponse (Text -> RemoteProtocolError) -> Text -> RemoteProtocolError
forall a b. (a -> b) -> a -> b
$ RemoteResponse -> Text
forall a. Show a => a -> Text
tshow RemoteResponse
r

-- * Transport-level wrappers

convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value
convertJSON :: PlatformEncoding -> PlatformEncoding -> Value -> Value
convertJSON _remote :: PlatformEncoding
_remote@PlatformEncoding
PEKotlin _local :: PlatformEncoding
_local@PlatformEncoding
PEKotlin = Value -> Value
forall a. a -> a
id
convertJSON PlatformEncoding
PESwift PlatformEncoding
PESwift = Value -> Value
forall a. a -> a
id
convertJSON PlatformEncoding
PESwift PlatformEncoding
PEKotlin = Value -> Value
owsf2tagged
convertJSON PlatformEncoding
PEKotlin PlatformEncoding
PESwift = String -> Value -> Value
forall a. HasCallStack => String -> a
Prelude.error String
"unsupported convertJSON: K/S" -- guarded by handshake

-- | Convert swift single-field sum encoding into tagged/discriminator-field
owsf2tagged :: J.Value -> J.Value
owsf2tagged :: Value -> Value
owsf2tagged = (Value, Bool) -> Value
forall a b. (a, b) -> a
fst ((Value, Bool) -> Value)
-> (Value -> (Value, Bool)) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> (Value, Bool)
convert
  where
    convert :: Value -> (Value, Bool)
convert Value
val = case Value
val of
      J.Object Object
o
        | Object -> Int
forall v. KeyMap v -> Int
JM.size Object
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 ->
            case Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
JM.toList Object
o of
              [Pair
OwsfTag, Pair
o'] -> Pair -> (Value, Bool)
tagged Pair
o'
              [Pair
o', Pair
OwsfTag] -> Pair -> (Value, Bool)
tagged Pair
o'
              [Pair]
_ -> (Value, Bool)
props
        | Bool
otherwise -> (Value, Bool)
props
        where
          props :: (Value, Bool)
props = (Object -> Value
J.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> Object -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
owsf2tagged Object
o, Bool
False)
      J.Array Array
a -> (Array -> Value
J.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> Array -> Array
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
owsf2tagged Array
a, Bool
False)
      Value
_ -> (Value
val, Bool
False)
    -- `tagged` converts the pair of single-field object encoding to tagged encoding.
    -- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
    tagged :: Pair -> (Value, Bool)
tagged (Key
k, Value
v) = (Object -> Value
J.Object Object
pairs, Bool
True)
      where
        (Value
v', Bool
innerTag) = Value -> (Value, Bool)
convert Value
v
        pairs :: Object
pairs = case Value
v' of
          -- `innerTag` indicates that internal object already has tag,
          -- so the current tag cannot be inserted into it.
          J.Object Object
o
            | Bool
innerTag -> Object
pair
            | Bool
otherwise -> Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
JM.insert Key
forall a. (Eq a, IsString a) => a
TaggedObjectJSONTag Value
tag Object
o
          Value
_ -> Object
pair
        tag :: Value
tag = Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Text
JK.toText Key
k
        pair :: Object
pair = [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
JM.fromList [Key
forall a. (Eq a, IsString a) => a
TaggedObjectJSONTag Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
tag, Key
forall a. (Eq a, IsString a) => a
TaggedObjectJSONData Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v']

pattern OwsfTag :: (JK.Key, J.Value)
pattern $mOwsfTag :: forall {r}. Pair -> ((# #) -> r) -> ((# #) -> r) -> r
$bOwsfTag :: Pair
OwsfTag = (SingleFieldJSONTag, J.Bool True)

-- ```
-- commandBody = encBody sessSignature idSignature (attachment / noAttachment)
-- responseBody = encBody attachment; should match counter in the command
-- encBody = nonce encLength32 encrypted(tlsunique counter body)
-- attachment = %x01 nonce encLength32 encrypted(attachment)
-- noAttachment = %x00
-- tlsunique = length 1*OCTET
-- nonce = 24*24 OCTET
-- counter = 8*8 OCTET ; int64
-- encLength32 = 4*4 OCTET ; uint32, includes authTag
-- ```

-- See https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2023-10-25-remote-control.md for encoding

encryptEncodeHTTP2Body :: Word32 -> C.SbKeyNonce -> RemoteCrypto -> LazyByteString -> ExceptT RemoteProtocolError IO Builder
encryptEncodeHTTP2Body :: Word32
-> SbKeyNonce
-> RemoteCrypto
-> LazyByteString
-> ExceptT RemoteProtocolError IO Builder
encryptEncodeHTTP2Body Word32
corrId SbKeyNonce
cmdKN RemoteCrypto {ByteString
sessionCode :: RemoteCrypto -> ByteString
sessionCode :: ByteString
sessionCode, RemoteSignatures
signatures :: RemoteCrypto -> RemoteSignatures
signatures :: RemoteSignatures
signatures} LazyByteString
s = do
  LazyByteString
ct <- (RCErrorType -> RemoteProtocolError)
-> ExceptT RCErrorType IO LazyByteString
-> ExceptT RemoteProtocolError IO LazyByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError RCErrorType -> RemoteProtocolError
PRERemoteControl (ExceptT RCErrorType IO LazyByteString
 -> ExceptT RemoteProtocolError IO LazyByteString)
-> ExceptT RCErrorType IO LazyByteString
-> ExceptT RemoteProtocolError IO LazyByteString
forall a b. (a -> b) -> a -> b
$ SbKeyNonce
-> LazyByteString -> ExceptT RCErrorType IO LazyByteString
RC.rcEncryptBody SbKeyNonce
cmdKN (LazyByteString -> ExceptT RCErrorType IO LazyByteString)
-> LazyByteString -> ExceptT RCErrorType IO LazyByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> LazyByteString
LB.fromStrict (ByteString -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode ByteString
sessionCode) LazyByteString -> LazyByteString -> LazyByteString
forall a. Semigroup a => a -> a -> a
<> LazyByteString
s
  let ctLen :: ByteString
ctLen = Word32 -> ByteString
encodeWord32 (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ LazyByteString -> Int64
LB.length LazyByteString
ct)
      signed :: LazyByteString
signed = ByteString -> LazyByteString
LB.fromStrict (Word32 -> ByteString
encodeWord32 Word32
corrId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ctLen) LazyByteString -> LazyByteString -> LazyByteString
forall a. Semigroup a => a -> a -> a
<> LazyByteString
ct
  Builder
sigs <- LazyByteString -> ExceptT RemoteProtocolError IO Builder
bodySignatures LazyByteString
signed
  Builder -> ExceptT RemoteProtocolError IO Builder
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> ExceptT RemoteProtocolError IO Builder)
-> Builder -> ExceptT RemoteProtocolError IO Builder
forall a b. (a -> b) -> a -> b
$ LazyByteString -> Builder
lazyByteString LazyByteString
signed Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sigs
  where
    bodySignatures :: LazyByteString -> ExceptT RemoteProtocolError IO Builder
    bodySignatures :: LazyByteString -> ExceptT RemoteProtocolError IO Builder
bodySignatures LazyByteString
signed = case RemoteSignatures
signatures of
      RSSign {PrivateKeyEd25519
idPrivKey :: RemoteSignatures -> PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey, PrivateKeyEd25519
sessPrivKey :: RemoteSignatures -> PrivateKeyEd25519
sessPrivKey :: PrivateKeyEd25519
sessPrivKey} -> do
        let hc :: Context SHA512
hc = Context SHA512 -> [ByteString] -> Context SHA512
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
CH.hashUpdates (forall a. HashAlgorithm a => Context a
CH.hashInit @SHA512) (LazyByteString -> [ByteString]
LB.toChunks LazyByteString
signed)
            ssig :: ByteString
ssig = PrivateKeyEd25519 -> Context SHA512 -> ByteString
sign PrivateKeyEd25519
sessPrivKey Context SHA512
hc
            idsig :: ByteString
idsig = PrivateKeyEd25519 -> Context SHA512 -> ByteString
sign PrivateKeyEd25519
idPrivKey (Context SHA512 -> ByteString) -> Context SHA512 -> ByteString
forall a b. (a -> b) -> a -> b
$ Context SHA512 -> ByteString -> Context SHA512
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
CH.hashUpdate Context SHA512
hc ByteString
ssig
        Builder -> ExceptT RemoteProtocolError IO Builder
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> ExceptT RemoteProtocolError IO Builder)
-> Builder -> ExceptT RemoteProtocolError IO Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (ByteString
ssig, ByteString
idsig)
      RemoteSignatures
_ -> Builder -> ExceptT RemoteProtocolError IO Builder
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty
    sign :: C.PrivateKeyEd25519 -> CH.Context SHA512 -> ByteString
    sign :: PrivateKeyEd25519 -> Context SHA512 -> ByteString
sign PrivateKeyEd25519
k = Signature 'Ed25519 -> ByteString
forall s. CryptoSignature s => s -> ByteString
C.signatureBytes (Signature 'Ed25519 -> ByteString)
-> (Context SHA512 -> Signature 'Ed25519)
-> Context SHA512
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivateKeyEd25519 -> ByteString -> Signature 'Ed25519
forall (a :: Algorithm).
SignatureAlgorithm a =>
PrivateKey a -> ByteString -> Signature a
C.sign' PrivateKeyEd25519
k (ByteString -> Signature 'Ed25519)
-> (Context SHA512 -> ByteString)
-> Context SHA512
-> Signature 'Ed25519
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA512 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA512 -> ByteString)
-> (Context SHA512 -> Digest SHA512)
-> Context SHA512
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context SHA512 -> Digest SHA512
forall a. HashAlgorithm a => Context a -> Digest a
CH.hashFinalize

-- | Parse and decrypt HTTP2 request/response
parseDecryptHTTP2Body :: HTTP2BodyChunk a => RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, LazyByteString, Int -> IO ByteString)
parseDecryptHTTP2Body :: forall a.
HTTP2BodyChunk a =>
RemoteCrypto
-> a
-> HTTP2Body
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, Int -> IO ByteString)
parseDecryptHTTP2Body rc :: RemoteCrypto
rc@RemoteCrypto {ByteString
sessionCode :: RemoteCrypto -> ByteString
sessionCode :: ByteString
sessionCode, RemoteSignatures
signatures :: RemoteCrypto -> RemoteSignatures
signatures :: RemoteSignatures
signatures} a
hr HTTP2Body {TBuffer
bodyBuffer :: TBuffer
bodyBuffer :: HTTP2Body -> TBuffer
bodyBuffer} = do
  (Word32
corrId, LazyByteString
ct) <- ExceptT RemoteProtocolError IO (Word32, LazyByteString)
getBody
  (SbKeyNonce
cmdKN, SbKeyNonce
rfKN) <- IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
-> ExceptT RemoteProtocolError IO (SbKeyNonce, SbKeyNonce)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
 -> ExceptT RemoteProtocolError IO (SbKeyNonce, SbKeyNonce))
-> IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
-> ExceptT RemoteProtocolError IO (SbKeyNonce, SbKeyNonce)
forall a b. (a -> b) -> a -> b
$ STM (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
-> IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
 -> IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce)))
-> STM (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
-> IO (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
forall a b. (a -> b) -> a -> b
$ RemoteCrypto
-> Word32
-> STM (Either RemoteProtocolError (SbKeyNonce, SbKeyNonce))
getRemoteRcvKeys RemoteCrypto
rc Word32
corrId
  LazyByteString
s <- (RCErrorType -> RemoteProtocolError)
-> ExceptT RCErrorType IO LazyByteString
-> ExceptT RemoteProtocolError IO LazyByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError RCErrorType -> RemoteProtocolError
PRERemoteControl (ExceptT RCErrorType IO LazyByteString
 -> ExceptT RemoteProtocolError IO LazyByteString)
-> ExceptT RCErrorType IO LazyByteString
-> ExceptT RemoteProtocolError IO LazyByteString
forall a b. (a -> b) -> a -> b
$ SbKeyNonce
-> LazyByteString -> ExceptT RCErrorType IO LazyByteString
RC.rcDecryptBody SbKeyNonce
cmdKN LazyByteString
ct
  LazyByteString
s' <- LazyByteString -> ExceptT RemoteProtocolError IO LazyByteString
parseBody LazyByteString
s
  (SbKeyNonce, LazyByteString, Int -> IO ByteString)
-> ExceptT
     RemoteProtocolError
     IO
     (SbKeyNonce, LazyByteString, Int -> IO ByteString)
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SbKeyNonce
rfKN, LazyByteString
s', Int -> IO ByteString
getNext)
  where
    getBody :: ExceptT RemoteProtocolError IO (Word32, LazyByteString)
    getBody :: ExceptT RemoteProtocolError IO (Word32, LazyByteString)
getBody = do
      ByteString
corrIdStr <- IO ByteString -> ExceptT RemoteProtocolError IO ByteString
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT RemoteProtocolError IO ByteString)
-> IO ByteString -> ExceptT RemoteProtocolError IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString
getNext Int
4
      ByteString
ctLenStr <- IO ByteString -> ExceptT RemoteProtocolError IO ByteString
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT RemoteProtocolError IO ByteString)
-> IO ByteString -> ExceptT RemoteProtocolError IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString
getNext Int
4
      let ctLen :: Word32
ctLen = ByteString -> Word32
decodeWord32 ByteString
ctLenStr
      Bool
-> ExceptT RemoteProtocolError IO ()
-> ExceptT RemoteProtocolError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
ctLen Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)) (ExceptT RemoteProtocolError IO ()
 -> ExceptT RemoteProtocolError IO ())
-> ExceptT RemoteProtocolError IO ()
-> ExceptT RemoteProtocolError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> ExceptT RemoteProtocolError IO ()
forall a. RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RemoteProtocolError
RPEInvalidSize
      [ByteString]
chunks <- IO [ByteString] -> ExceptT RemoteProtocolError IO [ByteString]
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> ExceptT RemoteProtocolError IO [ByteString])
-> IO [ByteString] -> ExceptT RemoteProtocolError IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> IO [ByteString]
getLazy (Int -> IO [ByteString]) -> Int -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ctLen
      let hc :: Context SHA512
hc = Context SHA512 -> [ByteString] -> Context SHA512
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
CH.hashUpdates (forall a. HashAlgorithm a => Context a
CH.hashInit @SHA512) [ByteString
corrIdStr, ByteString
ctLenStr]
          hc' :: Context SHA512
hc' = Context SHA512 -> [ByteString] -> Context SHA512
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
CH.hashUpdates Context SHA512
hc [ByteString]
chunks
      Context SHA512 -> ExceptT RemoteProtocolError IO ()
verifySignatures Context SHA512
hc'
      (Word32, LazyByteString)
-> ExceptT RemoteProtocolError IO (Word32, LazyByteString)
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Word32
decodeWord32 ByteString
corrIdStr, [ByteString] -> LazyByteString
LB.fromChunks [ByteString]
chunks)
    getLazy :: Int -> IO [ByteString]
    getLazy :: Int -> IO [ByteString]
getLazy Int
0 = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    getLazy Int
n = do
      let sz :: Int
sz = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
xrcpBlockSize
      ByteString
bs <- Int -> IO ByteString
getNext Int
sz
      let n' :: Int
n' = if ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sz then Int
0 else Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xrcpBlockSize)
      (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO [ByteString]
getLazy Int
n'
    verifySignatures :: CH.Context SHA512 -> ExceptT RemoteProtocolError IO ()
    verifySignatures :: Context SHA512 -> ExceptT RemoteProtocolError IO ()
verifySignatures Context SHA512
hc = case RemoteSignatures
signatures of
      RSVerify {PublicKeyEd25519
sessPubKey :: RemoteSignatures -> PublicKeyEd25519
sessPubKey :: PublicKeyEd25519
sessPubKey, PublicKeyEd25519
idPubKey :: RemoteSignatures -> PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey} -> do
        Signature 'Ed25519
ssig <- ExceptT RemoteProtocolError IO (Signature 'Ed25519)
getSig
        Signature 'Ed25519
idsig <- ExceptT RemoteProtocolError IO (Signature 'Ed25519)
getSig
        PublicKeyEd25519
-> Signature 'Ed25519
-> Context SHA512
-> ExceptT RemoteProtocolError IO ()
forall {a :: Algorithm} {f :: * -> *} {a}.
(SignatureAlgorithm a, MonadError RemoteProtocolError f,
 HashAlgorithm a) =>
PublicKey a -> Signature a -> Context a -> f ()
verifySig PublicKeyEd25519
sessPubKey Signature 'Ed25519
ssig Context SHA512
hc
        PublicKeyEd25519
-> Signature 'Ed25519
-> Context SHA512
-> ExceptT RemoteProtocolError IO ()
forall {a :: Algorithm} {f :: * -> *} {a}.
(SignatureAlgorithm a, MonadError RemoteProtocolError f,
 HashAlgorithm a) =>
PublicKey a -> Signature a -> Context a -> f ()
verifySig PublicKeyEd25519
idPubKey Signature 'Ed25519
idsig (Context SHA512 -> ExceptT RemoteProtocolError IO ())
-> Context SHA512 -> ExceptT RemoteProtocolError IO ()
forall a b. (a -> b) -> a -> b
$ Context SHA512 -> ByteString -> Context SHA512
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
CH.hashUpdate Context SHA512
hc (ByteString -> Context SHA512) -> ByteString -> Context SHA512
forall a b. (a -> b) -> a -> b
$ Signature 'Ed25519 -> ByteString
forall s. CryptoSignature s => s -> ByteString
C.signatureBytes Signature 'Ed25519
ssig
      RemoteSignatures
_ -> () -> ExceptT RemoteProtocolError IO ()
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        getSig :: ExceptT RemoteProtocolError IO (Signature 'Ed25519)
getSig = do
          Word8
len <- IO Word8 -> ExceptT RemoteProtocolError IO Word8
forall a. IO a -> ExceptT RemoteProtocolError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word8 -> ExceptT RemoteProtocolError IO Word8)
-> IO Word8 -> ExceptT RemoteProtocolError IO Word8
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head (ByteString -> Word8) -> IO ByteString -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getNext Int
1
          (String -> RemoteProtocolError)
-> IO (Either String (Signature 'Ed25519))
-> ExceptT RemoteProtocolError IO (Signature 'Ed25519)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> IO (Either e a) -> ExceptT e' m a
liftError' String -> RemoteProtocolError
RPEInvalidBody (IO (Either String (Signature 'Ed25519))
 -> ExceptT RemoteProtocolError IO (Signature 'Ed25519))
-> IO (Either String (Signature 'Ed25519))
-> ExceptT RemoteProtocolError IO (Signature 'Ed25519)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (Signature 'Ed25519)
forall s. CryptoSignature s => ByteString -> Either String s
C.decodeSignature (ByteString -> Either String (Signature 'Ed25519))
-> IO ByteString -> IO (Either String (Signature 'Ed25519))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getNext (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len)
        verifySig :: PublicKey a -> Signature a -> Context a -> f ()
verifySig PublicKey a
key Signature a
sig Context a
hc' = do
          let signed :: ByteString
signed = Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest a -> ByteString) -> Digest a -> ByteString
forall a b. (a -> b) -> a -> b
$ Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
CH.hashFinalize Context a
hc'
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey a -> Signature a -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' PublicKey a
key Signature a
sig ByteString
signed) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> f ()
forall a. RemoteProtocolError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RemoteProtocolError -> f ()) -> RemoteProtocolError -> f ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> RemoteProtocolError
PRERemoteControl RCErrorType
RCECtrlAuth
    parseBody :: LazyByteString -> ExceptT RemoteProtocolError IO LazyByteString
    parseBody :: LazyByteString -> ExceptT RemoteProtocolError IO LazyByteString
parseBody LazyByteString
s = case LazyByteString -> Maybe (Word8, LazyByteString)
LB.uncons LazyByteString
s of
      Maybe (Word8, LazyByteString)
Nothing -> RemoteProtocolError
-> ExceptT RemoteProtocolError IO LazyByteString
forall a. RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RemoteProtocolError
 -> ExceptT RemoteProtocolError IO LazyByteString)
-> RemoteProtocolError
-> ExceptT RemoteProtocolError IO LazyByteString
forall a b. (a -> b) -> a -> b
$ String -> RemoteProtocolError
RPEInvalidBody String
"empty body"
      Just (Word8
scLen, LazyByteString
rest) -> do
        (ByteString
sessCode', LazyByteString
s') <- Int64
-> LazyByteString
-> ExceptT RemoteProtocolError IO (ByteString, LazyByteString)
forall {m :: * -> *}.
MonadError RemoteProtocolError m =>
Int64 -> LazyByteString -> m (ByteString, LazyByteString)
takeBytes (Word8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
scLen) LazyByteString
rest
        Bool
-> ExceptT RemoteProtocolError IO ()
-> ExceptT RemoteProtocolError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
sessCode' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
sessionCode) (ExceptT RemoteProtocolError IO ()
 -> ExceptT RemoteProtocolError IO ())
-> ExceptT RemoteProtocolError IO ()
-> ExceptT RemoteProtocolError IO ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> ExceptT RemoteProtocolError IO ()
forall a. RemoteProtocolError -> ExceptT RemoteProtocolError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RemoteProtocolError
PRESessionCode
        LazyByteString -> ExceptT RemoteProtocolError IO LazyByteString
forall a. a -> ExceptT RemoteProtocolError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LazyByteString
s'
      where
        takeBytes :: Int64 -> LazyByteString -> m (ByteString, LazyByteString)
takeBytes Int64
n LazyByteString
s' = do
          let (LazyByteString
bs, LazyByteString
rest) = Int64 -> LazyByteString -> (LazyByteString, LazyByteString)
LB.splitAt Int64
n LazyByteString
s'
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LazyByteString -> Int64
LB.length LazyByteString
bs Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
n) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ RemoteProtocolError -> m ()
forall a. RemoteProtocolError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RemoteProtocolError
PRESessionCode
          (ByteString, LazyByteString) -> m (ByteString, LazyByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LazyByteString -> ByteString
LB.toStrict LazyByteString
bs, LazyByteString
rest)
    getNext :: Int -> IO ByteString
getNext Int
sz = TBuffer -> Int -> Maybe Int -> IO ByteString -> IO ByteString
getBuffered TBuffer
bodyBuffer Int
sz Maybe Int
forall a. Maybe a
Nothing (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ a -> IO ByteString
forall a. HTTP2BodyChunk a => a -> IO ByteString
getBodyChunk a
hr