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

module Simplex.RemoteControl.Client
  ( RCHostClient (action),
    RCHostConnection,
    newRCHostPairing,
    connectRCHost,
    cancelHostClient,
    RCCtrlClient (action),
    RCCtrlConnection,
    connectRCCtrl,
    discoverRCCtrl,
    confirmCtrlSession,
    cancelCtrlClient,
    RCStepTMVar,
    rcEncryptBody,
    rcDecryptBody,
    xrcpBlockSize,
    -- for tests only
    sendRCPacket,
    receiveRCPacket,
  ) where

import Control.Applicative ((<|>))
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.Bitraversable (bimapM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Default (def)
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (isNothing)
import qualified Data.Text as T
import Data.Time.Clock.System (getSystemTime)
import Data.Tuple (swap)
import Data.Word (Word16)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..), getFingerprint)
import Network.Socket (PortNumber, SockAddr (..), hostAddressToTuple)
import qualified Network.TLS as TLS
import qualified Network.UDP as UDP
import Simplex.Messaging.Agent.Client ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Crypto.SNTRUP761
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), TransportPeer (..), cGet, cPut)
import Simplex.Messaging.Transport.Buffer (peekBuffered)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Simplex.RemoteControl.Discovery (getLocalAddress, recvAnnounce, startTLSServer, withListener, withSender)
import Simplex.RemoteControl.Invitation
import Simplex.RemoteControl.Types
import UnliftIO
import UnliftIO.Concurrent

xrcpBlockSize :: Int
xrcpBlockSize :: Int
xrcpBlockSize = Int
16384

helloBlockSize :: Int
helloBlockSize :: Int
helloBlockSize = Int
12288

encInvitationSize :: Int
encInvitationSize :: Int
encInvitationSize = Int
900

newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
newRCHostPairing TVar ChaChaDRG
drg = do
  ((APublicVerifyKey
_, APrivateSignKey
caKey), SignedCertificate
caCert) <- TVar ChaChaDRG
-> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
genCredentials TVar ChaChaDRG
drg Maybe Credentials
Maybe ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
forall a. Maybe a
Nothing (Hours
25, Hours
24 Hours -> Hours -> Hours
forall a. Num a => a -> a -> a
* Hours
999999) Text
"ca"
  (PublicKeyEd25519
_, PrivateKeyEd25519
idPrivKey) <- STM (PublicKeyEd25519, PrivateKeyEd25519)
-> IO (PublicKeyEd25519, PrivateKeyEd25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyEd25519, PrivateKeyEd25519)
 -> IO (PublicKeyEd25519, PrivateKeyEd25519))
-> STM (PublicKeyEd25519, PrivateKeyEd25519)
-> IO (PublicKeyEd25519, PrivateKeyEd25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'Ed25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
drg
  RCHostPairing -> IO RCHostPairing
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCHostPairing {APrivateSignKey
caKey :: APrivateSignKey
$sel:caKey:RCHostPairing :: APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
$sel:caCert:RCHostPairing :: SignedCertificate
caCert, PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
$sel:idPrivKey:RCHostPairing :: PrivateKeyEd25519
idPrivKey, $sel:knownHost:RCHostPairing :: Maybe KnownHostPairing
knownHost = Maybe KnownHostPairing
forall a. Maybe a
Nothing}

data RCHostClient = RCHostClient
  { RCHostClient -> Async ()
action :: Async (),
    RCHostClient -> RCHClient_
client_ :: RCHClient_
  }

data RCHClient_ = RCHClient_
  { RCHClient_ -> TMVar (Maybe PortNumber)
startedPort :: TMVar (Maybe PortNumber),
    RCHClient_ -> TMVar (Async (Either RCErrorType ()))
announcer :: TMVar (Async (Either RCErrorType ())),
    RCHClient_ -> TMVar KeyHash
hostCAHash :: TMVar C.KeyHash,
    RCHClient_ -> TMVar ()
endSession :: TMVar ()
  }

type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))

connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection
connectRCHost :: TVar ChaChaDRG
-> RCHostPairing
-> Value
-> Bool
-> Maybe RCCtrlAddress
-> Maybe Word16
-> ExceptT RCErrorType IO RCHostConnection
connectRCHost TVar ChaChaDRG
drg pairing :: RCHostPairing
pairing@RCHostPairing {APrivateSignKey
$sel:caKey:RCHostPairing :: RCHostPairing -> APrivateSignKey
caKey :: APrivateSignKey
caKey, SignedCertificate
$sel:caCert:RCHostPairing :: RCHostPairing -> SignedCertificate
caCert :: SignedCertificate
caCert, PrivateKeyEd25519
$sel:idPrivKey:RCHostPairing :: RCHostPairing -> PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey, Maybe KnownHostPairing
$sel:knownHost:RCHostPairing :: RCHostPairing -> Maybe KnownHostPairing
knownHost :: Maybe KnownHostPairing
knownHost} Value
ctrlAppInfo Bool
multicast Maybe RCCtrlAddress
rcAddrPrefs_ Maybe Word16
port_ = do
  TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r <- ExceptT
  RCErrorType
  IO
  (TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  found :: NonEmpty RCCtrlAddress
found@(RCCtrlAddress {TransportHost
address :: TransportHost
$sel:address:RCCtrlAddress :: RCCtrlAddress -> TransportHost
address} :| [RCCtrlAddress]
_) <- ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
findCtrlAddress
  c :: RCHClient_
c@RCHClient_ {TMVar (Maybe PortNumber)
$sel:startedPort:RCHClient_ :: RCHClient_ -> TMVar (Maybe PortNumber)
startedPort :: TMVar (Maybe PortNumber)
startedPort, TMVar (Async (Either RCErrorType ()))
$sel:announcer:RCHClient_ :: RCHClient_ -> TMVar (Async (Either RCErrorType ()))
announcer :: TMVar (Async (Either RCErrorType ()))
announcer} <- IO RCHClient_ -> ExceptT RCErrorType IO RCHClient_
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RCHClient_
mkClient
  RCHostKeys
hostKeys <- STM RCHostKeys -> ExceptT RCErrorType IO RCHostKeys
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM RCHostKeys
genHostKeys
  Async ()
action <- IO (Async ()) -> ExceptT RCErrorType IO (Async ())
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> ExceptT RCErrorType IO (Async ()))
-> IO (Async ()) -> ExceptT RCErrorType IO (Async ())
forall a b. (a -> b) -> a -> b
$ RCHClient_
-> TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> RCHostKeys
-> IO (Async ())
runClient RCHClient_
c TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r RCHostKeys
hostKeys
  -- wait for the port to make invitation
  Maybe PortNumber
portNum <- STM (Maybe PortNumber) -> ExceptT RCErrorType IO (Maybe PortNumber)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe PortNumber)
 -> ExceptT RCErrorType IO (Maybe PortNumber))
-> STM (Maybe PortNumber)
-> ExceptT RCErrorType IO (Maybe PortNumber)
forall a b. (a -> b) -> a -> b
$ TMVar (Maybe PortNumber) -> STM (Maybe PortNumber)
forall a. TMVar a -> STM a
readTMVar TMVar (Maybe PortNumber)
startedPort
  signedInv :: RCSignedInvitation
signedInv@RCSignedInvitation {RCInvitation
invitation :: RCInvitation
$sel:invitation:RCSignedInvitation :: RCSignedInvitation -> RCInvitation
invitation} <- ExceptT RCErrorType IO RCSignedInvitation
-> (PortNumber -> ExceptT RCErrorType IO RCSignedInvitation)
-> Maybe PortNumber
-> ExceptT RCErrorType IO RCSignedInvitation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RCErrorType -> ExceptT RCErrorType IO RCSignedInvitation
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCETLSStartFailed) (IO RCSignedInvitation -> ExceptT RCErrorType IO RCSignedInvitation
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RCSignedInvitation
 -> ExceptT RCErrorType IO RCSignedInvitation)
-> (PortNumber -> IO RCSignedInvitation)
-> PortNumber
-> ExceptT RCErrorType IO RCSignedInvitation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
mkInvitation RCHostKeys
hostKeys TransportHost
address) Maybe PortNumber
portNum
  Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
multicast (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe KnownHostPairing
knownHost of
    Maybe KnownHostPairing
Nothing -> RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCENewController
    Just KnownHostPairing {PublicKeyX25519
hostDhPubKey :: PublicKeyX25519
$sel:hostDhPubKey:KnownHostPairing :: KnownHostPairing -> PublicKeyX25519
hostDhPubKey} -> do
      Async (Either RCErrorType ())
ann <- IO (Async (Either RCErrorType ()))
-> ExceptT RCErrorType IO (Async (Either RCErrorType ()))
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async (Either RCErrorType ()))
 -> ExceptT RCErrorType IO (Async (Either RCErrorType ())))
-> (ExceptT RCErrorType IO ()
    -> IO (Async (Either RCErrorType ())))
-> ExceptT RCErrorType IO ()
-> ExceptT RCErrorType IO (Async (Either RCErrorType ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either RCErrorType ()) -> IO (Async (Either RCErrorType ()))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO (Either RCErrorType ()) -> IO (Async (Either RCErrorType ())))
-> (ExceptT RCErrorType IO () -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
-> IO (Async (Either RCErrorType ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO ()
 -> ExceptT RCErrorType IO (Async (Either RCErrorType ())))
-> ExceptT RCErrorType IO ()
-> ExceptT RCErrorType IO (Async (Either RCErrorType ()))
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG
-> Int
-> PrivateKeyEd25519
-> PublicKeyX25519
-> RCHostKeys
-> RCInvitation
-> ExceptT RCErrorType IO ()
announceRC TVar ChaChaDRG
drg Int
60 PrivateKeyEd25519
idPrivKey PublicKeyX25519
hostDhPubKey RCHostKeys
hostKeys RCInvitation
invitation
      STM () -> ExceptT RCErrorType IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT RCErrorType IO ())
-> STM () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Async (Either RCErrorType ()))
-> Async (Either RCErrorType ()) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Async (Either RCErrorType ()))
announcer Async (Either RCErrorType ())
ann
  RCHostConnection -> ExceptT RCErrorType IO RCHostConnection
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty RCCtrlAddress
found, RCSignedInvitation
signedInv, RCHostClient {Async ()
$sel:action:RCHostClient :: Async ()
action :: Async ()
action, $sel:client_:RCHostClient :: RCHClient_
client_ = RCHClient_
c}, TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r)
  where
    findCtrlAddress :: ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
    findCtrlAddress :: ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
findCtrlAddress = do
      [RCCtrlAddress]
found' <- IO [RCCtrlAddress] -> ExceptT RCErrorType IO [RCCtrlAddress]
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [RCCtrlAddress] -> ExceptT RCErrorType IO [RCCtrlAddress])
-> IO [RCCtrlAddress] -> ExceptT RCErrorType IO [RCCtrlAddress]
forall a b. (a -> b) -> a -> b
$ Maybe RCCtrlAddress -> IO [RCCtrlAddress]
getLocalAddress Maybe RCCtrlAddress
rcAddrPrefs_
      ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
-> (NonEmpty RCCtrlAddress
    -> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress))
-> Maybe (NonEmpty RCCtrlAddress)
-> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RCErrorType -> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCENoLocalAddress) NonEmpty RCCtrlAddress
-> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty RCCtrlAddress)
 -> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress))
-> Maybe (NonEmpty RCCtrlAddress)
-> ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
forall a b. (a -> b) -> a -> b
$ [RCCtrlAddress] -> Maybe (NonEmpty RCCtrlAddress)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [RCCtrlAddress]
found'
    mkClient :: IO RCHClient_
    mkClient :: IO RCHClient_
mkClient = do
      TMVar (Maybe PortNumber)
startedPort <- IO (TMVar (Maybe PortNumber))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      TMVar (Async (Either RCErrorType ()))
announcer <- IO (TMVar (Async (Either RCErrorType ())))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      TMVar ()
endSession <- IO (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      TMVar KeyHash
hostCAHash <- IO (TMVar KeyHash)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      RCHClient_ -> IO RCHClient_
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCHClient_ {TMVar (Maybe PortNumber)
$sel:startedPort:RCHClient_ :: TMVar (Maybe PortNumber)
startedPort :: TMVar (Maybe PortNumber)
startedPort, TMVar (Async (Either RCErrorType ()))
$sel:announcer:RCHClient_ :: TMVar (Async (Either RCErrorType ()))
announcer :: TMVar (Async (Either RCErrorType ()))
announcer, TMVar KeyHash
$sel:hostCAHash:RCHClient_ :: TMVar KeyHash
hostCAHash :: TMVar KeyHash
hostCAHash, TMVar ()
$sel:endSession:RCHClient_ :: TMVar ()
endSession :: TMVar ()
endSession}
    runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
    runClient :: RCHClient_
-> TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TServer,
         RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> RCHostKeys
-> IO (Async ())
runClient RCHClient_ {TMVar (Maybe PortNumber)
$sel:startedPort:RCHClient_ :: RCHClient_ -> TMVar (Maybe PortNumber)
startedPort :: TMVar (Maybe PortNumber)
startedPort, TMVar (Async (Either RCErrorType ()))
$sel:announcer:RCHClient_ :: RCHClient_ -> TMVar (Async (Either RCErrorType ()))
announcer :: TMVar (Async (Either RCErrorType ()))
announcer, TMVar KeyHash
$sel:hostCAHash:RCHClient_ :: RCHClient_ -> TMVar KeyHash
hostCAHash :: TMVar KeyHash
hostCAHash, TMVar ()
$sel:endSession:RCHClient_ :: RCHClient_ -> TMVar ()
endSession :: TMVar ()
endSession} TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r RCHostKeys
hostKeys = do
      Credential
tlsCreds <- TVar ChaChaDRG
-> APrivateSignKey -> SignedCertificate -> IO Credential
genTLSCredentials TVar ChaChaDRG
drg APrivateSignKey
caKey SignedCertificate
caCert
      Maybe Word16
-> TMVar (Maybe PortNumber)
-> Credential
-> ServerHooks
-> (TLS 'TServer -> IO ())
-> IO (Async ())
startTLSServer Maybe Word16
port_ TMVar (Maybe PortNumber)
startedPort Credential
tlsCreds (TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> Maybe KnownHostPairing -> TMVar KeyHash -> ServerHooks
forall a.
TMVar a -> Maybe KnownHostPairing -> TMVar KeyHash -> ServerHooks
tlsHooks TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r Maybe KnownHostPairing
knownHost TMVar KeyHash
hostCAHash) ((TLS 'TServer -> IO ()) -> IO (Async ()))
-> (TLS 'TServer -> IO ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ \TLS 'TServer
tls ->
        IO (Either RCErrorType ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either RCErrorType ()) -> IO ())
-> (ExceptT RCErrorType IO () -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO () -> IO ())
-> ExceptT RCErrorType IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r' <- ExceptT
  RCErrorType
  IO
  (RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
          ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool -> ExceptT RCErrorType IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
-> Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
r (Either
   RCErrorType
   (ByteString, TLS 'TServer,
    RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
 -> STM Bool)
-> Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> STM Bool
forall a b. (a -> b) -> a -> b
$ (ByteString, TLS 'TServer,
 RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
-> Either
     RCErrorType
     (ByteString, TLS 'TServer,
      RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))
forall a b. b -> Either a b
Right (TLS 'TServer -> ByteString
forall (p :: TransportPeer). TLS p -> ByteString
tlsUniq TLS 'TServer
tls, TLS 'TServer
tls, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r')) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$
            TLS 'TServer
-> RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT RCErrorType IO ()
runSession TLS 'TServer
tls RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r' ExceptT RCErrorType IO ()
-> RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT RCErrorType IO ()
forall a b.
ExceptT RCErrorType IO a
-> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
`putRCError` RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r'
      where
        runSession :: TLS 'TServer
-> RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
-> ExceptT RCErrorType IO ()
runSession TLS 'TServer
tls RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r' = do
          Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Incoming TLS connection"
          RCHostEncHello
hostEncHello <- TLS 'TServer -> ExceptT RCErrorType IO RCHostEncHello
forall a (p :: TransportPeer).
Encoding a =>
TLS p -> ExceptT RCErrorType IO a
receiveRCPacket TLS 'TServer
tls
          Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Received host HELLO"
          KeyHash
hostCA <- STM KeyHash -> ExceptT RCErrorType IO KeyHash
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM KeyHash -> ExceptT RCErrorType IO KeyHash)
-> STM KeyHash -> ExceptT RCErrorType IO KeyHash
forall a b. (a -> b) -> a -> b
$ TMVar KeyHash -> STM KeyHash
forall a. TMVar a -> STM a
takeTMVar TMVar KeyHash
hostCAHash
          (RCCtrlEncHello
ctrlEncHello, HostSessKeys
sessionKeys, RCHostHello
helloBody, RCHostPairing
pairing') <- TVar ChaChaDRG
-> KeyHash
-> RCHostPairing
-> RCHostKeys
-> RCHostEncHello
-> ExceptT
     RCErrorType
     IO
     (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
prepareHostSession TVar ChaChaDRG
drg KeyHash
hostCA RCHostPairing
pairing RCHostKeys
hostKeys RCHostEncHello
hostEncHello
          TLS 'TServer -> RCCtrlEncHello -> ExceptT RCErrorType IO ()
forall a (p :: TransportPeer).
Encoding a =>
TLS p -> a -> ExceptT RCErrorType IO ()
sendRCPacket TLS 'TServer
tls RCCtrlEncHello
ctrlEncHello
          Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Sent ctrl HELLO"
          ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool -> ExceptT RCErrorType IO Bool
forall a b. (a -> b) -> a -> b
$ RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
-> Either RCErrorType (RCHostSession, RCHostHello, RCHostPairing)
-> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)
r' (Either RCErrorType (RCHostSession, RCHostHello, RCHostPairing)
 -> STM Bool)
-> Either RCErrorType (RCHostSession, RCHostHello, RCHostPairing)
-> STM Bool
forall a b. (a -> b) -> a -> b
$ (RCHostSession, RCHostHello, RCHostPairing)
-> Either RCErrorType (RCHostSession, RCHostHello, RCHostPairing)
forall a b. b -> Either a b
Right (RCHostSession {TLS 'TServer
tls :: TLS 'TServer
$sel:tls:RCHostSession :: TLS 'TServer
tls, HostSessKeys
sessionKeys :: HostSessKeys
$sel:sessionKeys:RCHostSession :: HostSessKeys
sessionKeys}, RCHostHello
helloBody, RCHostPairing
pairing')) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ do
            STM (Maybe (Async (Either RCErrorType ())))
-> ExceptT RCErrorType IO (Maybe (Async (Either RCErrorType ())))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Async (Either RCErrorType ()))
-> STM (Maybe (Async (Either RCErrorType ())))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Async (Either RCErrorType ()))
announcer) ExceptT RCErrorType IO (Maybe (Async (Either RCErrorType ())))
-> (Maybe (Async (Either RCErrorType ()))
    -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO ()
forall a b.
ExceptT RCErrorType IO a
-> (a -> ExceptT RCErrorType IO b) -> ExceptT RCErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Async (Either RCErrorType ()) -> ExceptT RCErrorType IO ())
-> Maybe (Async (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async (Either RCErrorType ()) -> ExceptT RCErrorType IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel
            -- can use `RCHostSession` until `endSession` is signalled
            Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Holding session"
            STM () -> ExceptT RCErrorType IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT RCErrorType IO ())
-> STM () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
endSession
    tlsHooks :: TMVar a -> Maybe KnownHostPairing -> TMVar C.KeyHash -> TLS.ServerHooks
    tlsHooks :: forall a.
TMVar a -> Maybe KnownHostPairing -> TMVar KeyHash -> ServerHooks
tlsHooks TMVar a
r Maybe KnownHostPairing
knownHost_ TMVar KeyHash
hostCAHash =
      ServerHooks
forall a. Default a => a
def
        { TLS.onNewHandshake = \Measurement
_ -> STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool) -> STM (Maybe a) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar a
r,
          TLS.onClientCertificate = \(X.CertificateChain [SignedCertificate]
chain) ->
            case [SignedCertificate]
chain of
              [SignedCertificate
_leaf, SignedCertificate
ca] -> do
                let kh :: KeyHash
kh = SignedCertificate -> KeyHash
certFingerprint SignedCertificate
ca
                    accept :: Bool
accept = Bool
-> (KnownHostPairing -> Bool) -> Maybe KnownHostPairing -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\KnownHostPairing
h -> KnownHostPairing -> KeyHash
hostFingerprint KnownHostPairing
h KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
kh) Maybe KnownHostPairing
knownHost_
                if Bool
accept
                  then STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar KeyHash -> KeyHash -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar KeyHash
hostCAHash KeyHash
kh) IO () -> CertificateUsage -> IO CertificateUsage
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CertificateUsage
TLS.CertificateUsageAccept
                  else CertificateUsage -> IO CertificateUsage
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertificateUsage -> IO CertificateUsage)
-> CertificateUsage -> IO CertificateUsage
forall a b. (a -> b) -> a -> b
$ CertificateRejectReason -> CertificateUsage
TLS.CertificateUsageReject CertificateRejectReason
TLS.CertificateRejectUnknownCA
              [SignedCertificate]
_ ->
                CertificateUsage -> IO CertificateUsage
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CertificateUsage -> IO CertificateUsage)
-> CertificateUsage -> IO CertificateUsage
forall a b. (a -> b) -> a -> b
$ CertificateRejectReason -> CertificateUsage
TLS.CertificateUsageReject CertificateRejectReason
TLS.CertificateRejectUnknownCA
        }
    genHostKeys :: STM RCHostKeys
    genHostKeys :: STM RCHostKeys
genHostKeys = do
      (PublicKeyEd25519, PrivateKeyEd25519)
sessKeys <- TVar ChaChaDRG -> STM (KeyPair 'Ed25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
drg
      (PublicKeyX25519, PrivateKey 'X25519)
dhKeys <- TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
drg
      RCHostKeys -> STM RCHostKeys
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCHostKeys {KeyPair 'Ed25519
(PublicKeyEd25519, PrivateKeyEd25519)
sessKeys :: (PublicKeyEd25519, PrivateKeyEd25519)
$sel:sessKeys:RCHostKeys :: KeyPair 'Ed25519
sessKeys, KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
dhKeys :: (PublicKeyX25519, PrivateKey 'X25519)
$sel:dhKeys:RCHostKeys :: KeyPair 'X25519
dhKeys}
    mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
    mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
mkInvitation RCHostKeys {KeyPair 'Ed25519
$sel:sessKeys:RCHostKeys :: RCHostKeys -> KeyPair 'Ed25519
sessKeys :: KeyPair 'Ed25519
sessKeys, KeyPair 'X25519
$sel:dhKeys:RCHostKeys :: RCHostKeys -> KeyPair 'X25519
dhKeys :: KeyPair 'X25519
dhKeys} TransportHost
host PortNumber
portNum = do
      SystemTime
ts <- IO SystemTime
getSystemTime
      let inv :: RCInvitation
inv =
            RCInvitation
              { $sel:ca:RCInvitation :: KeyHash
ca = SignedCertificate -> KeyHash
certFingerprint SignedCertificate
caCert,
                TransportHost
host :: TransportHost
$sel:host:RCInvitation :: TransportHost
host,
                $sel:port:RCInvitation :: Word16
port = PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
portNum,
                $sel:v:RCInvitation :: VersionRangeRCP
v = VersionRangeRCP
supportedRCPVRange,
                $sel:app:RCInvitation :: Value
app = Value
ctrlAppInfo,
                SystemTime
ts :: SystemTime
$sel:ts:RCInvitation :: SystemTime
ts,
                $sel:skey:RCInvitation :: PublicKeyEd25519
skey = (PublicKeyEd25519, PrivateKeyEd25519) -> PublicKeyEd25519
forall a b. (a, b) -> a
fst KeyPair 'Ed25519
(PublicKeyEd25519, PrivateKeyEd25519)
sessKeys,
                $sel:idkey:RCInvitation :: PublicKeyEd25519
idkey = PrivateKeyEd25519 -> PublicKeyEd25519
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKeyEd25519
idPrivKey,
                $sel:dh:RCInvitation :: PublicKeyX25519
dh = (PublicKeyX25519, PrivateKey 'X25519) -> PublicKeyX25519
forall a b. (a, b) -> a
fst KeyPair 'X25519
(PublicKeyX25519, PrivateKey 'X25519)
dhKeys
              }
      RCSignedInvitation -> IO RCSignedInvitation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RCSignedInvitation -> IO RCSignedInvitation)
-> RCSignedInvitation -> IO RCSignedInvitation
forall a b. (a -> b) -> a -> b
$ PrivateKeyEd25519
-> PrivateKeyEd25519 -> RCInvitation -> RCSignedInvitation
signInvitation ((PublicKeyEd25519, PrivateKeyEd25519) -> PrivateKeyEd25519
forall a b. (a, b) -> b
snd KeyPair 'Ed25519
(PublicKeyEd25519, PrivateKeyEd25519)
sessKeys) PrivateKeyEd25519
idPrivKey RCInvitation
inv

genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> X.SignedCertificate -> IO TLS.Credential
genTLSCredentials :: TVar ChaChaDRG
-> APrivateSignKey -> SignedCertificate -> IO Credential
genTLSCredentials TVar ChaChaDRG
drg APrivateSignKey
caKey SignedCertificate
caCert = do
  let caCreds :: ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
caCreds = (APrivateSignKey -> ASignatureKeyPair
C.signatureKeyPair APrivateSignKey
caKey, SignedCertificate
caCert)
  ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
leaf <- TVar ChaChaDRG
-> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
genCredentials TVar ChaChaDRG
drg (((APublicVerifyKey, APrivateSignKey), SignedCertificate)
-> Maybe ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
forall a. a -> Maybe a
Just ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
caCreds) (Hours
1, Hours
24 Hours -> Hours -> Hours
forall a. Num a => a -> a -> a
* Hours
999999) Text
"localhost" -- session-signing cert
  Credential -> IO Credential
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credential -> IO Credential)
-> ((KeyHash, Credential) -> Credential)
-> (KeyHash, Credential)
-> IO Credential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyHash, Credential) -> Credential
forall a b. (a, b) -> b
snd ((KeyHash, Credential) -> IO Credential)
-> (KeyHash, Credential) -> IO Credential
forall a b. (a -> b) -> a -> b
$ NonEmpty Credentials -> (KeyHash, Credential)
tlsCredentials (((APublicVerifyKey, APrivateSignKey), SignedCertificate)
leaf ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
-> [((APublicVerifyKey, APrivateSignKey), SignedCertificate)]
-> NonEmpty
     ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
forall a. a -> [a] -> NonEmpty a
:| [((APublicVerifyKey, APrivateSignKey), SignedCertificate)
caCreds])

certFingerprint :: X.SignedCertificate -> C.KeyHash
certFingerprint :: SignedCertificate -> KeyHash
certFingerprint SignedCertificate
caCert = ByteString -> KeyHash
C.KeyHash ByteString
fp
  where
    Fingerprint ByteString
fp = SignedCertificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedCertificate
caCert HashALG
X.HashSHA256

cancelHostClient :: RCHostClient -> IO ()
cancelHostClient :: RCHostClient -> IO ()
cancelHostClient RCHostClient {Async ()
$sel:action:RCHostClient :: RCHostClient -> Async ()
action :: Async ()
action, $sel:client_:RCHostClient :: RCHostClient -> RCHClient_
client_ = RCHClient_ {TMVar (Async (Either RCErrorType ()))
$sel:announcer:RCHClient_ :: RCHClient_ -> TMVar (Async (Either RCErrorType ()))
announcer :: TMVar (Async (Either RCErrorType ()))
announcer, TMVar ()
$sel:endSession:RCHClient_ :: RCHClient_ -> TMVar ()
endSession :: TMVar ()
endSession}} = do
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
endSession ()
  STM (Maybe (Async (Either RCErrorType ())))
-> IO (Maybe (Async (Either RCErrorType ())))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Async (Either RCErrorType ()))
-> STM (Maybe (Async (Either RCErrorType ())))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Async (Either RCErrorType ()))
announcer) IO (Maybe (Async (Either RCErrorType ())))
-> (Maybe (Async (Either RCErrorType ())) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Async (Either RCErrorType ()) -> IO ())
-> Maybe (Async (Either RCErrorType ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async (Either RCErrorType ()) -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel
  Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
action

prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
prepareHostSession :: TVar ChaChaDRG
-> KeyHash
-> RCHostPairing
-> RCHostKeys
-> RCHostEncHello
-> ExceptT
     RCErrorType
     IO
     (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
prepareHostSession
  TVar ChaChaDRG
drg
  KeyHash
tlsHostFingerprint
  pairing :: RCHostPairing
pairing@RCHostPairing {PrivateKeyEd25519
$sel:idPrivKey:RCHostPairing :: RCHostPairing -> PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey, $sel:knownHost:RCHostPairing :: RCHostPairing -> Maybe KnownHostPairing
knownHost = Maybe KnownHostPairing
knownHost_}
  RCHostKeys {$sel:sessKeys:RCHostKeys :: RCHostKeys -> KeyPair 'Ed25519
sessKeys = (PublicKeyType PrivateKeyEd25519
_, PrivateKeyEd25519
sessPrivKey), $sel:dhKeys:RCHostKeys :: RCHostKeys -> KeyPair 'X25519
dhKeys = (PublicKeyType (PrivateKey 'X25519)
_, PrivateKey 'X25519
dhPrivKey)}
  RCHostEncHello {PublicKeyX25519
dhPubKey :: PublicKeyX25519
$sel:dhPubKey:RCHostEncHello :: RCHostEncHello -> PublicKeyX25519
dhPubKey, CbNonce
nonce :: CbNonce
$sel:nonce:RCHostEncHello :: RCHostEncHello -> CbNonce
nonce, ByteString
encBody :: ByteString
$sel:encBody:RCHostEncHello :: RCHostEncHello -> ByteString
encBody} = do
    let sharedKey :: DhSecret 'X25519
sharedKey = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
dhPubKey PrivateKey 'X25519
dhPrivKey
    ByteString
helloBody <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEDecrypt) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt DhSecret 'X25519
sharedKey CbNonce
nonce ByteString
encBody
    hostHello :: RCHostHello
hostHello@RCHostHello {VersionRCP
v :: VersionRCP
$sel:v:RCHostHello :: RCHostHello -> VersionRCP
v, KeyHash
ca :: KeyHash
$sel:ca:RCHostHello :: RCHostHello -> KeyHash
ca, $sel:kem:RCHostHello :: RCHostHello -> KEMPublicKey
kem = KEMPublicKey
kemPubKey} <- (String -> RCErrorType)
-> Either String RCHostHello -> ExceptT RCErrorType IO RCHostHello
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith String -> RCErrorType
RCESyntax (Either String RCHostHello -> ExceptT RCErrorType IO RCHostHello)
-> Either String RCHostHello -> ExceptT RCErrorType IO RCHostHello
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String RCHostHello
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecodeStrict ByteString
helloBody
    Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyHash
ca KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
tlsHostFingerprint) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEIdentity
    (KEMCiphertext
kemCiphertext, KEMSharedKey
kemSharedKey) <- IO (KEMCiphertext, KEMSharedKey)
-> ExceptT RCErrorType IO (KEMCiphertext, KEMSharedKey)
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (KEMCiphertext, KEMSharedKey)
 -> ExceptT RCErrorType IO (KEMCiphertext, KEMSharedKey))
-> IO (KEMCiphertext, KEMSharedKey)
-> ExceptT RCErrorType IO (KEMCiphertext, KEMSharedKey)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey)
sntrup761Enc TVar ChaChaDRG
drg KEMPublicKey
kemPubKey
    let KEMHybridSecret ScrubbedBytes
hybridKey = PublicKeyX25519
-> PrivateKey 'X25519 -> KEMSharedKey -> KEMHybridSecret
kemHybridSecret PublicKeyX25519
dhPubKey PrivateKey 'X25519
dhPrivKey KEMSharedKey
kemSharedKey
    Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VersionRCP -> VersionRangeRCP -> Bool
forall v a. VersionI v a => a -> VersionRange v -> Bool
isCompatible VersionRCP
v VersionRangeRCP
supportedRCPVRange) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEVersion
    (TVar SbChainKey
sndKey, TVar SbChainKey
rcvKey) <- (SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey))
-> (SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey))
-> (SbChainKey, SbChainKey)
-> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ((SbChainKey, SbChainKey)
 -> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey))
-> (SbChainKey, SbChainKey)
-> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey)
forall a b. (a -> b) -> a -> b
$ ByteString -> ScrubbedBytes -> (SbChainKey, SbChainKey)
forall secret.
ByteArrayAccess secret =>
ByteString -> secret -> (SbChainKey, SbChainKey)
C.sbcInit ByteString
"" ScrubbedBytes
hybridKey
    let keys :: HostSessKeys
keys = HostSessKeys {$sel:chainKeys:HostSessKeys :: TSbChainKeys
chainKeys = TSbChainKeys {TVar SbChainKey
sndKey :: TVar SbChainKey
$sel:sndKey:TSbChainKeys :: TVar SbChainKey
sndKey, TVar SbChainKey
rcvKey :: TVar SbChainKey
$sel:rcvKey:TSbChainKeys :: TVar SbChainKey
rcvKey}, PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
$sel:idPrivKey:HostSessKeys :: PrivateKeyEd25519
idPrivKey, PrivateKeyEd25519
sessPrivKey :: PrivateKeyEd25519
$sel:sessPrivKey:HostSessKeys :: PrivateKeyEd25519
sessPrivKey}
    KnownHostPairing
knownHost' <- KeyHash
-> PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
updateKnownHost KeyHash
ca PublicKeyX25519
dhPubKey
    let ctrlHello :: RCCtrlHello
ctrlHello = RCCtrlHello {}
    -- TODO send error response if something fails
    (SbKey
sk, CbNonce
nonce') <- STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce))
-> STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce)
forall a b. (a -> b) -> a -> b
$ TVar SbChainKey
-> (SbChainKey -> ((SbKey, CbNonce), SbChainKey))
-> STM (SbKey, CbNonce)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SbChainKey
sndKey SbChainKey -> ((SbKey, CbNonce), SbChainKey)
C.sbcHkdf
    ByteString
encBody' <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEBlockSize) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ SbKey
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.sbEncrypt SbKey
sk CbNonce
nonce' (ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ RCCtrlHello -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode RCCtrlHello
ctrlHello) Int
helloBlockSize
    let ctrlEncHello :: RCCtrlEncHello
ctrlEncHello = RCCtrlEncHello {$sel:kem:RCCtrlEncHello :: KEMCiphertext
kem = KEMCiphertext
kemCiphertext, $sel:encBody:RCCtrlEncHello :: ByteString
encBody = ByteString
encBody'}
    (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
-> ExceptT
     RCErrorType
     IO
     (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RCCtrlEncHello
ctrlEncHello, HostSessKeys
keys, RCHostHello
hostHello, RCHostPairing
pairing {knownHost = Just knownHost'})
    where
      updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
      updateKnownHost :: KeyHash
-> PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
updateKnownHost KeyHash
ca PublicKeyX25519
hostDhPubKey = case Maybe KnownHostPairing
knownHost_ of
        Just KnownHostPairing
h -> do
          Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KnownHostPairing -> KeyHash
hostFingerprint KnownHostPairing
h KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
tlsHostFingerprint) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> (RCErrorType -> ExceptT RCErrorType IO ())
-> RCErrorType
-> ExceptT RCErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (RCErrorType -> ExceptT RCErrorType IO ())
-> RCErrorType -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$
            String -> RCErrorType
RCEInternal String
"TLS host CA is different from host pairing, should be caught in TLS handshake"
          KnownHostPairing -> ExceptT RCErrorType IO KnownHostPairing
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KnownHostPairing
h :: KnownHostPairing) {hostDhPubKey}
        Maybe KnownHostPairing
Nothing -> KnownHostPairing -> ExceptT RCErrorType IO KnownHostPairing
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KnownHostPairing {$sel:hostFingerprint:KnownHostPairing :: KeyHash
hostFingerprint = KeyHash
ca, PublicKeyX25519
$sel:hostDhPubKey:KnownHostPairing :: PublicKeyX25519
hostDhPubKey :: PublicKeyX25519
hostDhPubKey}

data RCCtrlClient = RCCtrlClient
  { RCCtrlClient -> Async ()
action :: Async (),
    RCCtrlClient -> RCCClient_
client_ :: RCCClient_
  }

data RCCClient_ = RCCClient_
  { RCCClient_ -> TMVar Bool
confirmSession :: TMVar Bool,
    RCCClient_ -> TMVar ()
endSession :: TMVar ()
  }

type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))

-- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl :: TVar ChaChaDRG
-> RCVerifiedInvitation
-> Maybe RCCtrlPairing
-> Value
-> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl TVar ChaChaDRG
drg (RCVerifiedInvitation inv :: RCInvitation
inv@RCInvitation {KeyHash
$sel:ca:RCInvitation :: RCInvitation -> KeyHash
ca :: KeyHash
ca, PublicKeyEd25519
$sel:idkey:RCInvitation :: RCInvitation -> PublicKeyEd25519
idkey :: PublicKeyEd25519
idkey}) Maybe RCCtrlPairing
pairing_ Value
hostAppInfo = do
  RCCtrlPairing
pairing' <- ExceptT RCErrorType IO RCCtrlPairing
-> (RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing)
-> Maybe RCCtrlPairing
-> ExceptT RCErrorType IO RCCtrlPairing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RCCtrlPairing
newCtrlPairing) RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
updateCtrlPairing Maybe RCCtrlPairing
pairing_
  TVar ChaChaDRG
-> RCCtrlPairing
-> RCInvitation
-> Value
-> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl_ TVar ChaChaDRG
drg RCCtrlPairing
pairing' RCInvitation
inv Value
hostAppInfo
  where
    newCtrlPairing :: IO RCCtrlPairing
    newCtrlPairing :: IO RCCtrlPairing
newCtrlPairing = do
      ((APublicVerifyKey
_, APrivateSignKey
caKey), SignedCertificate
caCert) <- TVar ChaChaDRG
-> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
genCredentials TVar ChaChaDRG
drg Maybe Credentials
Maybe ((APublicVerifyKey, APrivateSignKey), SignedCertificate)
forall a. Maybe a
Nothing (Hours
1, Hours
24 Hours -> Hours -> Hours
forall a. Num a => a -> a -> a
* Hours
999999) Text
"ca"
      (PublicKeyX25519
_, PrivateKey 'X25519
dhPrivKey) <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> IO (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> IO (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> IO (PublicKeyX25519, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
drg
      RCCtrlPairing -> IO RCCtrlPairing
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCCtrlPairing {APrivateSignKey
caKey :: APrivateSignKey
$sel:caKey:RCCtrlPairing :: APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
$sel:caCert:RCCtrlPairing :: SignedCertificate
caCert, $sel:ctrlFingerprint:RCCtrlPairing :: KeyHash
ctrlFingerprint = KeyHash
ca, $sel:idPubKey:RCCtrlPairing :: PublicKeyEd25519
idPubKey = PublicKeyEd25519
idkey, PrivateKey 'X25519
dhPrivKey :: PrivateKey 'X25519
$sel:dhPrivKey:RCCtrlPairing :: PrivateKey 'X25519
dhPrivKey, $sel:prevDhPrivKey:RCCtrlPairing :: Maybe (PrivateKey 'X25519)
prevDhPrivKey = Maybe (PrivateKey 'X25519)
forall a. Maybe a
Nothing}
    updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
    updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
updateCtrlPairing pairing :: RCCtrlPairing
pairing@RCCtrlPairing {KeyHash
$sel:ctrlFingerprint:RCCtrlPairing :: RCCtrlPairing -> KeyHash
ctrlFingerprint :: KeyHash
ctrlFingerprint, PublicKeyEd25519
$sel:idPubKey:RCCtrlPairing :: RCCtrlPairing -> PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey, $sel:dhPrivKey:RCCtrlPairing :: RCCtrlPairing -> PrivateKey 'X25519
dhPrivKey = PrivateKey 'X25519
currDhPrivKey} = do
      Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyHash
ca KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
ctrlFingerprint Bool -> Bool -> Bool
&& PublicKeyEd25519
idPubKey PublicKeyEd25519 -> PublicKeyEd25519 -> Bool
forall a. Eq a => a -> a -> Bool
== PublicKeyEd25519
idkey) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEIdentity
      (PublicKeyX25519
_, PrivateKey 'X25519
dhPrivKey) <- STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT RCErrorType IO (PublicKeyX25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKeyX25519, PrivateKey 'X25519)
 -> ExceptT RCErrorType IO (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> ExceptT RCErrorType IO (PublicKeyX25519, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
drg
      RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCCtrlPairing
pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey}

connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl_ :: TVar ChaChaDRG
-> RCCtrlPairing
-> RCInvitation
-> Value
-> ExceptT RCErrorType IO RCCtrlConnection
connectRCCtrl_ TVar ChaChaDRG
drg pairing' :: RCCtrlPairing
pairing'@RCCtrlPairing {APrivateSignKey
$sel:caKey:RCCtrlPairing :: RCCtrlPairing -> APrivateSignKey
caKey :: APrivateSignKey
caKey, SignedCertificate
$sel:caCert:RCCtrlPairing :: RCCtrlPairing -> SignedCertificate
caCert :: SignedCertificate
caCert} inv :: RCInvitation
inv@RCInvitation {KeyHash
$sel:ca:RCInvitation :: RCInvitation -> KeyHash
ca :: KeyHash
ca, TransportHost
$sel:host:RCInvitation :: RCInvitation -> TransportHost
host :: TransportHost
host, Word16
$sel:port:RCInvitation :: RCInvitation -> Word16
port :: Word16
port} Value
hostAppInfo = do
  TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r <- ExceptT
  RCErrorType
  IO
  (TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing))))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  RCCClient_
c <- IO RCCClient_ -> ExceptT RCErrorType IO RCCClient_
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RCCClient_
mkClient
  Async ()
action <- IO (Async ()) -> ExceptT RCErrorType IO (Async ())
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> ExceptT RCErrorType IO (Async ()))
-> (ExceptT RCErrorType IO () -> IO (Async ()))
-> ExceptT RCErrorType IO ()
-> ExceptT RCErrorType 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 () -> IO (Async ()))
-> (ExceptT RCErrorType IO () -> IO ())
-> ExceptT RCErrorType IO ()
-> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either RCErrorType ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either RCErrorType ()) -> IO ())
-> (ExceptT RCErrorType IO () -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO (Async ()))
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO (Async ())
forall a b. (a -> b) -> a -> b
$ RCCClient_
-> TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT RCErrorType IO ()
runClient RCCClient_
c TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r ExceptT RCErrorType IO ()
-> TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT RCErrorType IO ()
forall a b.
ExceptT RCErrorType IO a
-> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
`putRCError` TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r
  RCCtrlConnection -> ExceptT RCErrorType IO RCCtrlConnection
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RCCtrlClient {Async ()
$sel:action:RCCtrlClient :: Async ()
action :: Async ()
action, $sel:client_:RCCtrlClient :: RCCClient_
client_ = RCCClient_
c}, TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r)
  where
    mkClient :: IO RCCClient_
    mkClient :: IO RCCClient_
mkClient = do
      TMVar Bool
confirmSession <- IO (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      TMVar ()
endSession <- IO (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      RCCClient_ -> IO RCCClient_
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RCCClient_ {TMVar Bool
$sel:confirmSession:RCCClient_ :: TMVar Bool
confirmSession :: TMVar Bool
confirmSession, TMVar ()
$sel:endSession:RCCClient_ :: TMVar ()
endSession :: TMVar ()
endSession}
    runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
    runClient :: RCCClient_
-> TMVar
     (Either
        RCErrorType
        (ByteString, TLS 'TClient,
         RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> ExceptT RCErrorType IO ()
runClient RCCClient_ {TMVar Bool
$sel:confirmSession:RCCClient_ :: RCCClient_ -> TMVar Bool
confirmSession :: TMVar Bool
confirmSession, TMVar ()
$sel:endSession:RCCClient_ :: RCCClient_ -> TMVar ()
endSession :: TMVar ()
endSession} TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r = do
      Maybe Credential
clientCredentials <- IO (Maybe Credential) -> ExceptT RCErrorType IO (Maybe Credential)
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Credential)
 -> ExceptT RCErrorType IO (Maybe Credential))
-> IO (Maybe Credential)
-> ExceptT RCErrorType IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ Credential -> Maybe Credential
forall a. a -> Maybe a
Just (Credential -> Maybe Credential)
-> IO Credential -> IO (Maybe Credential)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ChaChaDRG
-> APrivateSignKey -> SignedCertificate -> IO Credential
genTLSCredentials TVar ChaChaDRG
drg APrivateSignKey
caKey SignedCertificate
caCert
      let clientConfig :: TransportClientConfig
clientConfig = TransportClientConfig
defaultTransportClientConfig {clientCredentials}
      IO (Either RCErrorType ()) -> ExceptT RCErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either RCErrorType ()) -> ExceptT RCErrorType IO ())
-> ((TLS 'TClient -> IO (Either RCErrorType ()))
    -> IO (Either RCErrorType ()))
-> (TLS 'TClient -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> String
-> Maybe KeyHash
-> (TLS 'TClient -> IO (Either RCErrorType ()))
-> IO (Either RCErrorType ())
forall (c :: TransportPeer -> *) a.
Transport c =>
TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> String
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTransportClient TransportClientConfig
clientConfig Maybe SocksCredentials
forall a. Maybe a
Nothing TransportHost
host (Word16 -> String
forall a. Show a => a -> String
show Word16
port) (KeyHash -> Maybe KeyHash
forall a. a -> Maybe a
Just KeyHash
ca) ((TLS 'TClient -> IO (Either RCErrorType ()))
 -> ExceptT RCErrorType IO ())
-> (TLS 'TClient -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ \tls :: TLS 'TClient
tls@TLS {TBuffer
tlsBuffer :: TBuffer
$sel:tlsBuffer:TLS :: forall (p :: TransportPeer). TLS p -> TBuffer
tlsBuffer, Context
tlsContext :: Context
$sel:tlsContext:TLS :: forall (p :: TransportPeer). TLS p -> Context
tlsContext} -> ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO () -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall a b. (a -> b) -> a -> b
$ do
        -- pump socket to detect connection problems
        IO () -> ExceptT RCErrorType IO ()
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT RCErrorType IO ())
-> IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TBuffer
-> Int -> IO ByteString -> IO (ByteString, Maybe ByteString)
peekBuffered TBuffer
tlsBuffer Int
100000 (Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
tlsContext) IO (ByteString, Maybe ByteString)
-> ((ByteString, Maybe ByteString) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> IO ())
-> ((ByteString, Maybe ByteString) -> Text)
-> (ByteString, Maybe ByteString)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe ByteString) -> Text
forall a. Show a => a -> Text
tshow -- should normally be ("", Nothing) here
        Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Got TLS connection"
        RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r' <- ExceptT RCErrorType IO (RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
        ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool -> ExceptT RCErrorType IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-> Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar
  (Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
r (Either
   RCErrorType
   (ByteString, TLS 'TClient,
    RCStepTMVar (RCCtrlSession, RCCtrlPairing))
 -> STM Bool)
-> Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> STM Bool
forall a b. (a -> b) -> a -> b
$ (ByteString, TLS 'TClient,
 RCStepTMVar (RCCtrlSession, RCCtrlPairing))
-> Either
     RCErrorType
     (ByteString, TLS 'TClient,
      RCStepTMVar (RCCtrlSession, RCCtrlPairing))
forall a b. b -> Either a b
Right (TLS 'TClient -> ByteString
forall (p :: TransportPeer). TLS p -> ByteString
tlsUniq TLS 'TClient
tls, TLS 'TClient
tls, RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r')) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Waiting for session confirmation"
          ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool -> ExceptT RCErrorType IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
readTMVar TMVar Bool
confirmSession) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TLS 'TClient
-> RCStepTMVar (RCCtrlSession, RCCtrlPairing)
-> ExceptT RCErrorType IO ()
runSession TLS 'TClient
tls RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r' ExceptT RCErrorType IO ()
-> RCStepTMVar (RCCtrlSession, RCCtrlPairing)
-> ExceptT RCErrorType IO ()
forall a b.
ExceptT RCErrorType IO a
-> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
`putRCError` RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r'
      where
        runSession :: TLS 'TClient
-> RCStepTMVar (RCCtrlSession, RCCtrlPairing)
-> ExceptT RCErrorType IO ()
runSession TLS 'TClient
tls RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r' = do
          (DhSecret 'X25519
sharedKey, KEMSecretKey
kemPrivKey, RCHostEncHello
hostEncHello) <- TVar ChaChaDRG
-> RCCtrlPairing
-> RCInvitation
-> Value
-> ExceptT
     RCErrorType IO (DhSecret 'X25519, KEMSecretKey, RCHostEncHello)
prepareHostHello TVar ChaChaDRG
drg RCCtrlPairing
pairing' RCInvitation
inv Value
hostAppInfo
          TLS 'TClient -> RCHostEncHello -> ExceptT RCErrorType IO ()
forall a (p :: TransportPeer).
Encoding a =>
TLS p -> a -> ExceptT RCErrorType IO ()
sendRCPacket TLS 'TClient
tls RCHostEncHello
hostEncHello
          RCCtrlEncHello
ctrlEncHello <- TLS 'TClient -> ExceptT RCErrorType IO RCCtrlEncHello
forall a (p :: TransportPeer).
Encoding a =>
TLS p -> ExceptT RCErrorType IO a
receiveRCPacket TLS 'TClient
tls
          Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Received ctrl HELLO"
          CtrlSessKeys
ctrlSessKeys <- RCCtrlPairing
-> RCInvitation
-> DhSecret 'X25519
-> KEMSecretKey
-> RCCtrlEncHello
-> ExceptT RCErrorType IO CtrlSessKeys
prepareCtrlSession RCCtrlPairing
pairing' RCInvitation
inv DhSecret 'X25519
sharedKey KEMSecretKey
kemPrivKey RCCtrlEncHello
ctrlEncHello
          ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool -> ExceptT RCErrorType IO Bool
forall a b. (a -> b) -> a -> b
$ RCStepTMVar (RCCtrlSession, RCCtrlPairing)
-> Either RCErrorType (RCCtrlSession, RCCtrlPairing) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar RCStepTMVar (RCCtrlSession, RCCtrlPairing)
r' (Either RCErrorType (RCCtrlSession, RCCtrlPairing) -> STM Bool)
-> Either RCErrorType (RCCtrlSession, RCCtrlPairing) -> STM Bool
forall a b. (a -> b) -> a -> b
$ (RCCtrlSession, RCCtrlPairing)
-> Either RCErrorType (RCCtrlSession, RCCtrlPairing)
forall a b. b -> Either a b
Right (RCCtrlSession {TLS 'TClient
tls :: TLS 'TClient
$sel:tls:RCCtrlSession :: TLS 'TClient
tls, $sel:sessionKeys:RCCtrlSession :: CtrlSessKeys
sessionKeys = CtrlSessKeys
ctrlSessKeys}, RCCtrlPairing
pairing')) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Session started"
            -- release second putTMVar in confirmCtrlSession
            ExceptT RCErrorType IO Bool -> ExceptT RCErrorType IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT RCErrorType IO Bool -> ExceptT RCErrorType IO ())
-> (STM Bool -> ExceptT RCErrorType IO Bool)
-> STM Bool
-> ExceptT RCErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ExceptT RCErrorType IO ())
-> STM Bool -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
takeTMVar TMVar Bool
confirmSession
            STM () -> ExceptT RCErrorType IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT RCErrorType IO ())
-> STM () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
endSession
            Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Session ended"

putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
ExceptT RCErrorType IO a
a putRCError :: forall a b.
ExceptT RCErrorType IO a
-> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
`putRCError` TMVar (Either RCErrorType b)
r = ExceptT RCErrorType IO a
a ExceptT RCErrorType IO a
-> (RCErrorType -> ExceptT RCErrorType IO a)
-> ExceptT RCErrorType IO a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \RCErrorType
e -> STM Bool -> ExceptT RCErrorType IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either RCErrorType b) -> Either RCErrorType b -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either RCErrorType b)
r (Either RCErrorType b -> STM Bool)
-> Either RCErrorType b -> STM Bool
forall a b. (a -> b) -> a -> b
$ RCErrorType -> Either RCErrorType b
forall a b. a -> Either a b
Left RCErrorType
e) ExceptT RCErrorType IO Bool
-> ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
forall a b.
ExceptT RCErrorType IO a
-> ExceptT RCErrorType IO b -> ExceptT RCErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RCErrorType -> ExceptT RCErrorType IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
e

sendRCPacket :: Encoding a => TLS p -> a -> ExceptT RCErrorType IO ()
sendRCPacket :: forall a (p :: TransportPeer).
Encoding a =>
TLS p -> a -> ExceptT RCErrorType IO ()
sendRCPacket TLS p
tls a
pkt = do
  ByteString
b <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEBlockSize) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Either CryptoError ByteString
C.pad (a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode a
pkt) Int
xrcpBlockSize
  IO () -> ExceptT RCErrorType IO ()
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT RCErrorType IO ())
-> IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ TLS p -> ByteString -> IO ()
forall (p :: TransportPeer). TLS p -> ByteString -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> ByteString -> IO ()
cPut TLS p
tls ByteString
b

receiveRCPacket :: Encoding a => TLS p -> ExceptT RCErrorType IO a
receiveRCPacket :: forall a (p :: TransportPeer).
Encoding a =>
TLS p -> ExceptT RCErrorType IO a
receiveRCPacket TLS p
tls = do
  ByteString
b <- IO ByteString -> ExceptT RCErrorType IO ByteString
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT RCErrorType IO ByteString)
-> IO ByteString -> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ TLS p -> Int -> IO ByteString
forall (p :: TransportPeer). TLS p -> Int -> IO ByteString
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> Int -> IO ByteString
cGet TLS p
tls Int
xrcpBlockSize
  Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
xrcpBlockSize) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEBlockSize
  ByteString
b' <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEBlockSize) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either CryptoError ByteString
C.unPad ByteString
b
  (String -> RCErrorType)
-> Either String a -> ExceptT RCErrorType IO a
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith String -> RCErrorType
RCESyntax (Either String a -> ExceptT RCErrorType IO a)
-> Either String a -> ExceptT RCErrorType IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
b'

prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (C.DhSecretX25519, KEMSecretKey, RCHostEncHello)
prepareHostHello :: TVar ChaChaDRG
-> RCCtrlPairing
-> RCInvitation
-> Value
-> ExceptT
     RCErrorType IO (DhSecret 'X25519, KEMSecretKey, RCHostEncHello)
prepareHostHello
  TVar ChaChaDRG
drg
  RCCtrlPairing {SignedCertificate
$sel:caCert:RCCtrlPairing :: RCCtrlPairing -> SignedCertificate
caCert :: SignedCertificate
caCert, PrivateKey 'X25519
$sel:dhPrivKey:RCCtrlPairing :: RCCtrlPairing -> PrivateKey 'X25519
dhPrivKey :: PrivateKey 'X25519
dhPrivKey}
  RCInvitation {VersionRangeRCP
$sel:v:RCInvitation :: RCInvitation -> VersionRangeRCP
v :: VersionRangeRCP
v, $sel:dh:RCInvitation :: RCInvitation -> PublicKeyX25519
dh = PublicKeyX25519
dhPubKey}
  Value
hostAppInfo = do
    Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Preparing session"
    case VersionRangeRCP
-> VersionRangeRCP
-> Maybe (Compatible (VersionT RCPVersion VersionRangeRCP))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
compatibleVersion VersionRangeRCP
v VersionRangeRCP
supportedRCPVRange of
      Maybe (Compatible (VersionT RCPVersion VersionRangeRCP))
Nothing -> RCErrorType
-> ExceptT
     RCErrorType IO (DhSecret 'X25519, KEMSecretKey, RCHostEncHello)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEVersion
      Just (Compatible VersionRCP
v') -> do
        CbNonce
nonce <- IO CbNonce -> ExceptT RCErrorType IO CbNonce
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CbNonce -> ExceptT RCErrorType IO CbNonce)
-> (STM CbNonce -> IO CbNonce)
-> STM CbNonce
-> ExceptT RCErrorType IO CbNonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM CbNonce -> IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ExceptT RCErrorType IO CbNonce)
-> STM CbNonce -> ExceptT RCErrorType IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
drg
        (KEMPublicKey
kemPubKey, KEMSecretKey
kemPrivKey) <- IO (KEMPublicKey, KEMSecretKey)
-> ExceptT RCErrorType IO (KEMPublicKey, KEMSecretKey)
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (KEMPublicKey, KEMSecretKey)
 -> ExceptT RCErrorType IO (KEMPublicKey, KEMSecretKey))
-> IO (KEMPublicKey, KEMSecretKey)
-> ExceptT RCErrorType IO (KEMPublicKey, KEMSecretKey)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey)
sntrup761Keypair TVar ChaChaDRG
drg
        let helloBody :: RCHostHello
helloBody = RCHostHello {$sel:v:RCHostHello :: VersionRCP
v = VersionRCP
v', $sel:ca:RCHostHello :: KeyHash
ca = SignedCertificate -> KeyHash
certFingerprint SignedCertificate
caCert, $sel:app:RCHostHello :: Value
app = Value
hostAppInfo, $sel:kem:RCHostHello :: KEMPublicKey
kem = KEMPublicKey
kemPubKey}
            sharedKey :: DhSecret 'X25519
sharedKey = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
dhPubKey PrivateKey 'X25519
dhPrivKey
        ByteString
encBody <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEBlockSize) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt DhSecret 'X25519
sharedKey CbNonce
nonce (ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ RCHostHello -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode RCHostHello
helloBody) Int
helloBlockSize
        -- let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
        let hostEncHello :: RCHostEncHello
hostEncHello = RCHostEncHello {$sel:dhPubKey:RCHostEncHello :: PublicKeyX25519
dhPubKey = PrivateKey 'X25519 -> PublicKeyX25519
forall (a :: Algorithm). PrivateKey a -> PublicKey a
C.publicKey PrivateKey 'X25519
dhPrivKey, CbNonce
$sel:nonce:RCHostEncHello :: CbNonce
nonce :: CbNonce
nonce, ByteString
$sel:encBody:RCHostEncHello :: ByteString
encBody :: ByteString
encBody}
        (DhSecret 'X25519, KEMSecretKey, RCHostEncHello)
-> ExceptT
     RCErrorType IO (DhSecret 'X25519, KEMSecretKey, RCHostEncHello)
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DhSecret 'X25519
sharedKey, KEMSecretKey
kemPrivKey, RCHostEncHello
hostEncHello)

prepareCtrlSession :: RCCtrlPairing -> RCInvitation -> C.DhSecretX25519 -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO CtrlSessKeys
prepareCtrlSession :: RCCtrlPairing
-> RCInvitation
-> DhSecret 'X25519
-> KEMSecretKey
-> RCCtrlEncHello
-> ExceptT RCErrorType IO CtrlSessKeys
prepareCtrlSession
  RCCtrlPairing {PublicKeyEd25519
$sel:idPubKey:RCCtrlPairing :: RCCtrlPairing -> PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey, PrivateKey 'X25519
$sel:dhPrivKey:RCCtrlPairing :: RCCtrlPairing -> PrivateKey 'X25519
dhPrivKey :: PrivateKey 'X25519
dhPrivKey}
  RCInvitation {PublicKeyEd25519
$sel:skey:RCInvitation :: RCInvitation -> PublicKeyEd25519
skey :: PublicKeyEd25519
skey, $sel:dh:RCInvitation :: RCInvitation -> PublicKeyX25519
dh = PublicKeyX25519
dhPubKey}
  DhSecret 'X25519
sharedKey
  KEMSecretKey
kemPrivKey = \case
    RCCtrlEncHello {$sel:kem:RCCtrlEncHello :: RCCtrlEncHello -> KEMCiphertext
kem = KEMCiphertext
kemCiphertext, ByteString
$sel:encBody:RCCtrlEncHello :: RCCtrlEncHello -> ByteString
encBody :: ByteString
encBody} -> do
      KEMSharedKey
kemSharedKey <- IO KEMSharedKey -> ExceptT RCErrorType IO KEMSharedKey
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KEMSharedKey -> ExceptT RCErrorType IO KEMSharedKey)
-> IO KEMSharedKey -> ExceptT RCErrorType IO KEMSharedKey
forall a b. (a -> b) -> a -> b
$ KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey
sntrup761Dec KEMCiphertext
kemCiphertext KEMSecretKey
kemPrivKey
      let KEMHybridSecret ScrubbedBytes
hybridKey = PublicKeyX25519
-> PrivateKey 'X25519 -> KEMSharedKey -> KEMHybridSecret
kemHybridSecret PublicKeyX25519
dhPubKey PrivateKey 'X25519
dhPrivKey KEMSharedKey
kemSharedKey
      -- keys are swapped in controller
      (TVar SbChainKey
sndKey, TVar SbChainKey
rcvKey) <- (TVar SbChainKey, TVar SbChainKey)
-> (TVar SbChainKey, TVar SbChainKey)
forall a b. (a, b) -> (b, a)
swap ((TVar SbChainKey, TVar SbChainKey)
 -> (TVar SbChainKey, TVar SbChainKey))
-> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey)
-> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey))
-> (SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey))
-> (SbChainKey, SbChainKey)
-> ExceptT RCErrorType IO (TVar SbChainKey, TVar SbChainKey)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO SbChainKey -> ExceptT RCErrorType IO (TVar SbChainKey)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (ByteString -> ScrubbedBytes -> (SbChainKey, SbChainKey)
forall secret.
ByteArrayAccess secret =>
ByteString -> secret -> (SbChainKey, SbChainKey)
C.sbcInit ByteString
"" ScrubbedBytes
hybridKey)
      (SbKey
sk, CbNonce
nonce) <- STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce))
-> STM (SbKey, CbNonce) -> ExceptT RCErrorType IO (SbKey, CbNonce)
forall a b. (a -> b) -> a -> b
$ TVar SbChainKey
-> (SbChainKey -> ((SbKey, CbNonce), SbChainKey))
-> STM (SbKey, CbNonce)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar SbChainKey
rcvKey SbChainKey -> ((SbKey, CbNonce), SbChainKey)
C.sbcHkdf
      ByteString
helloBody <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEDecrypt) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
C.sbDecrypt SbKey
sk CbNonce
nonce ByteString
encBody
      Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Decrypted ctrl HELLO"
      RCCtrlHello {} <- (String -> RCErrorType)
-> Either String RCCtrlHello -> ExceptT RCErrorType IO RCCtrlHello
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith String -> RCErrorType
RCESyntax (Either String RCCtrlHello -> ExceptT RCErrorType IO RCCtrlHello)
-> Either String RCCtrlHello -> ExceptT RCErrorType IO RCCtrlHello
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String RCCtrlHello
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecodeStrict ByteString
helloBody
      CtrlSessKeys -> ExceptT RCErrorType IO CtrlSessKeys
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CtrlSessKeys {$sel:chainKeys:CtrlSessKeys :: TSbChainKeys
chainKeys = TSbChainKeys {TVar SbChainKey
$sel:sndKey:TSbChainKeys :: TVar SbChainKey
sndKey :: TVar SbChainKey
sndKey, TVar SbChainKey
$sel:rcvKey:TSbChainKeys :: TVar SbChainKey
rcvKey :: TVar SbChainKey
rcvKey}, PublicKeyEd25519
idPubKey :: PublicKeyEd25519
$sel:idPubKey:CtrlSessKeys :: PublicKeyEd25519
idPubKey, $sel:sessPubKey:CtrlSessKeys :: PublicKeyEd25519
sessPubKey = PublicKeyEd25519
skey}
    RCCtrlEncError {CbNonce
nonce :: CbNonce
$sel:nonce:RCCtrlEncHello :: RCCtrlEncHello -> CbNonce
nonce, ByteString
encMessage :: ByteString
$sel:encMessage:RCCtrlEncHello :: RCCtrlEncHello -> ByteString
encMessage} -> do
      ByteString
message <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEDecrypt) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt DhSecret 'X25519
sharedKey CbNonce
nonce ByteString
encMessage
      RCErrorType -> ExceptT RCErrorType IO CtrlSessKeys
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (RCErrorType -> ExceptT RCErrorType IO CtrlSessKeys)
-> RCErrorType -> ExceptT RCErrorType IO CtrlSessKeys
forall a b. (a -> b) -> a -> b
$ String -> RCErrorType
RCECtrlError (String -> RCErrorType) -> String -> RCErrorType
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
safeDecodeUtf8 ByteString
message

-- * Multicast discovery

announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO ()
announceRC :: TVar ChaChaDRG
-> Int
-> PrivateKeyEd25519
-> PublicKeyX25519
-> RCHostKeys
-> RCInvitation
-> ExceptT RCErrorType IO ()
announceRC TVar ChaChaDRG
drg Int
maxCount PrivateKeyEd25519
idPrivKey PublicKeyX25519
knownDhPub RCHostKeys {KeyPair 'Ed25519
$sel:sessKeys:RCHostKeys :: RCHostKeys -> KeyPair 'Ed25519
sessKeys :: KeyPair 'Ed25519
sessKeys, KeyPair 'X25519
$sel:dhKeys:RCHostKeys :: RCHostKeys -> KeyPair 'X25519
dhKeys :: KeyPair 'X25519
dhKeys} RCInvitation
inv = IO (Either RCErrorType ()) -> ExceptT RCErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either RCErrorType ()) -> ExceptT RCErrorType IO ())
-> IO (Either RCErrorType ()) -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ (UDPSocket -> IO (Either RCErrorType ()))
-> IO (Either RCErrorType ())
forall a. (UDPSocket -> IO a) -> IO a
withSender ((UDPSocket -> IO (Either RCErrorType ()))
 -> IO (Either RCErrorType ()))
-> (UDPSocket -> IO (Either RCErrorType ()))
-> IO (Either RCErrorType ())
forall a b. (a -> b) -> a -> b
$ \UDPSocket
sender -> ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO () -> IO (Either RCErrorType ()))
-> ExceptT RCErrorType IO () -> IO (Either RCErrorType ())
forall a b. (a -> b) -> a -> b
$ do
  Int -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
maxCount (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug Text
"Announcing..."
    CbNonce
nonce <- STM CbNonce -> ExceptT RCErrorType IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ExceptT RCErrorType IO CbNonce)
-> STM CbNonce -> ExceptT RCErrorType IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
drg
    ByteString
encInvitation <- (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEEncrypt) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt DhSecret 'X25519
sharedKey CbNonce
nonce ByteString
sigInvitation Int
encInvitationSize
    IO () -> ExceptT RCErrorType IO ()
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT RCErrorType IO ())
-> (ByteString -> IO ()) -> ByteString -> ExceptT RCErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UDPSocket -> ByteString -> IO ()
UDP.send UDPSocket
sender (ByteString -> ExceptT RCErrorType IO ())
-> ByteString -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCEncInvitation -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode RCEncInvitation {PublicKeyType (PrivateKey 'X25519)
PublicKeyX25519
dhPubKey :: PublicKeyType (PrivateKey 'X25519)
$sel:dhPubKey:RCEncInvitation :: PublicKeyX25519
dhPubKey, CbNonce
nonce :: CbNonce
$sel:nonce:RCEncInvitation :: CbNonce
nonce, ByteString
encInvitation :: ByteString
$sel:encInvitation:RCEncInvitation :: ByteString
encInvitation}
    Int -> ExceptT RCErrorType IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
1000000
  where
    sigInvitation :: ByteString
sigInvitation = RCSignedInvitation -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (RCSignedInvitation -> ByteString)
-> RCSignedInvitation -> ByteString
forall a b. (a -> b) -> a -> b
$ PrivateKeyEd25519
-> PrivateKeyEd25519 -> RCInvitation -> RCSignedInvitation
signInvitation PrivateKeyEd25519
sPrivKey PrivateKeyEd25519
idPrivKey RCInvitation
inv
    (PublicKeyType PrivateKeyEd25519
_sPub, PrivateKeyEd25519
sPrivKey) = KeyPair 'Ed25519
sessKeys
    sharedKey :: DhSecret 'X25519
sharedKey = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
knownDhPub PrivateKey 'X25519
dhPrivKey
    (PublicKeyType (PrivateKey 'X25519)
dhPubKey, PrivateKey 'X25519
dhPrivKey) = KeyPair 'X25519
dhKeys

discoverRCCtrl :: TMVar Int -> NonEmpty RCCtrlPairing -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
discoverRCCtrl :: TMVar Int
-> NonEmpty RCCtrlPairing
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
discoverRCCtrl TMVar Int
subscribers NonEmpty RCCtrlPairing
pairings =
  RCErrorType
-> Int
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> Int -> ExceptT e m a -> ExceptT e m a
timeoutThrow RCErrorType
RCENotDiscovered Int
30000000 (ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall a b. (a -> b) -> a -> b
$ IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
 -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall a b. (a -> b) -> a -> b
$ TMVar Int
-> (ListenSocket
    -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
forall a. TMVar Int -> (ListenSocket -> IO a) -> IO a
withListener TMVar Int
subscribers ((ListenSocket
  -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
 -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
-> (ListenSocket
    -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
forall a b. (a -> b) -> a -> b
$ \ListenSocket
listener ->
    ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
-> (ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
    -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation))
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall a. ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
loop (ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
 -> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation)))
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
-> IO (Either RCErrorType (RCCtrlPairing, RCVerifiedInvitation))
forall a b. (a -> b) -> a -> b
$ do
      (SockAddr
source, ByteString
bytes) <- IO (SockAddr, ByteString)
-> ExceptT RCErrorType IO (SockAddr, ByteString)
forall a. IO a -> ExceptT RCErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SockAddr, ByteString)
 -> ExceptT RCErrorType IO (SockAddr, ByteString))
-> IO (SockAddr, ByteString)
-> ExceptT RCErrorType IO (SockAddr, ByteString)
forall a b. (a -> b) -> a -> b
$ ListenSocket -> IO (SockAddr, ByteString)
recvAnnounce ListenSocket
listener
      RCEncInvitation
encInvitation <- (String -> RCErrorType)
-> Either String RCEncInvitation
-> ExceptT RCErrorType IO RCEncInvitation
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> String -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEInvitation) (Either String RCEncInvitation
 -> ExceptT RCErrorType IO RCEncInvitation)
-> Either String RCEncInvitation
-> ExceptT RCErrorType IO RCEncInvitation
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String RCEncInvitation
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
bytes
      r :: (RCCtrlPairing, RCVerifiedInvitation)
r@(RCCtrlPairing
_, RCVerifiedInvitation RCInvitation {TransportHost
$sel:host:RCInvitation :: RCInvitation -> TransportHost
host :: TransportHost
host}) <- NonEmpty RCCtrlPairing
-> RCEncInvitation
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
findRCCtrlPairing NonEmpty RCCtrlPairing
pairings RCEncInvitation
encInvitation
      case SockAddr
source of
        SockAddrInet PortNumber
_ HostAddress
ha | (Word8, Word8, Word8, Word8) -> TransportHost
THIPv4 (HostAddress -> (Word8, Word8, Word8, Word8)
hostAddressToTuple HostAddress
ha) TransportHost -> TransportHost -> Bool
forall a. Eq a => a -> a -> Bool
== TransportHost
host -> () -> ExceptT RCErrorType IO ()
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        SockAddr
_ -> RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEInvitation
      (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RCCtrlPairing, RCVerifiedInvitation)
r
  where
    loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
    loop :: forall a. ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
loop ExceptT RCErrorType IO a
action = ExceptT RCErrorType IO a
action ExceptT RCErrorType IO a
-> (RCErrorType -> ExceptT RCErrorType IO a)
-> ExceptT RCErrorType IO a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \RCErrorType
e -> Text -> ExceptT RCErrorType IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (RCErrorType -> Text
forall a. Show a => a -> Text
tshow RCErrorType
e) ExceptT RCErrorType IO ()
-> ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
forall a b.
ExceptT RCErrorType IO a
-> ExceptT RCErrorType IO b -> ExceptT RCErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
forall a. ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
loop ExceptT RCErrorType IO a
action

findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
findRCCtrlPairing :: NonEmpty RCCtrlPairing
-> RCEncInvitation
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
findRCCtrlPairing NonEmpty RCCtrlPairing
pairings RCEncInvitation {PublicKeyX25519
$sel:dhPubKey:RCEncInvitation :: RCEncInvitation -> PublicKeyX25519
dhPubKey :: PublicKeyX25519
dhPubKey, CbNonce
$sel:nonce:RCEncInvitation :: RCEncInvitation -> CbNonce
nonce :: CbNonce
nonce, ByteString
$sel:encInvitation:RCEncInvitation :: RCEncInvitation -> ByteString
encInvitation :: ByteString
encInvitation} = do
  (RCCtrlPairing
pairing, ByteString
signedInvStr) <- Either RCErrorType (RCCtrlPairing, ByteString)
-> ExceptT RCErrorType IO (RCCtrlPairing, ByteString)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either RCErrorType (RCCtrlPairing, ByteString)
 -> ExceptT RCErrorType IO (RCCtrlPairing, ByteString))
-> Either RCErrorType (RCCtrlPairing, ByteString)
-> ExceptT RCErrorType IO (RCCtrlPairing, ByteString)
forall a b. (a -> b) -> a -> b
$ [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
decrypt (NonEmpty RCCtrlPairing -> [RCCtrlPairing]
forall a. NonEmpty a -> [a]
L.toList NonEmpty RCCtrlPairing
pairings)
  RCSignedInvitation
signedInv <- (String -> RCErrorType)
-> Either String RCSignedInvitation
-> ExceptT RCErrorType IO RCSignedInvitation
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith String -> RCErrorType
RCESyntax (Either String RCSignedInvitation
 -> ExceptT RCErrorType IO RCSignedInvitation)
-> Either String RCSignedInvitation
-> ExceptT RCErrorType IO RCSignedInvitation
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String RCSignedInvitation
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
signedInvStr
  inv :: RCVerifiedInvitation
inv@(RCVerifiedInvitation RCInvitation {$sel:dh:RCInvitation :: RCInvitation -> PublicKeyX25519
dh = PublicKeyX25519
invDh}) <- ExceptT RCErrorType IO RCVerifiedInvitation
-> (RCVerifiedInvitation
    -> ExceptT RCErrorType IO RCVerifiedInvitation)
-> Maybe RCVerifiedInvitation
-> ExceptT RCErrorType IO RCVerifiedInvitation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RCErrorType -> ExceptT RCErrorType IO RCVerifiedInvitation
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEInvitation) RCVerifiedInvitation -> ExceptT RCErrorType IO RCVerifiedInvitation
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RCVerifiedInvitation
 -> ExceptT RCErrorType IO RCVerifiedInvitation)
-> Maybe RCVerifiedInvitation
-> ExceptT RCErrorType IO RCVerifiedInvitation
forall a b. (a -> b) -> a -> b
$ RCSignedInvitation -> Maybe RCVerifiedInvitation
verifySignedInvitation RCSignedInvitation
signedInv
  Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKeyX25519
invDh PublicKeyX25519 -> PublicKeyX25519 -> Bool
forall a. Eq a => a -> a -> Bool
== PublicKeyX25519
dhPubKey) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEInvitation
  (RCCtrlPairing, RCVerifiedInvitation)
-> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation)
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RCCtrlPairing
pairing, RCVerifiedInvitation
inv)
  where
    decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
    decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
decrypt [] = RCErrorType -> Either RCErrorType (RCCtrlPairing, ByteString)
forall a b. a -> Either a b
Left RCErrorType
RCECtrlNotFound
    decrypt (pairing :: RCCtrlPairing
pairing@RCCtrlPairing {PrivateKey 'X25519
$sel:dhPrivKey:RCCtrlPairing :: RCCtrlPairing -> PrivateKey 'X25519
dhPrivKey :: PrivateKey 'X25519
dhPrivKey, Maybe (PrivateKey 'X25519)
$sel:prevDhPrivKey:RCCtrlPairing :: RCCtrlPairing -> Maybe (PrivateKey 'X25519)
prevDhPrivKey :: Maybe (PrivateKey 'X25519)
prevDhPrivKey} : [RCCtrlPairing]
rest) =
      let r :: Maybe ByteString
r = PrivateKey 'X25519 -> Maybe ByteString
decrypt_ PrivateKey 'X25519
dhPrivKey Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PrivateKey 'X25519 -> Maybe ByteString
decrypt_ (PrivateKey 'X25519 -> Maybe ByteString)
-> Maybe (PrivateKey 'X25519) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (PrivateKey 'X25519)
prevDhPrivKey)
       in Either RCErrorType (RCCtrlPairing, ByteString)
-> (ByteString -> Either RCErrorType (RCCtrlPairing, ByteString))
-> Maybe ByteString
-> Either RCErrorType (RCCtrlPairing, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
decrypt [RCCtrlPairing]
rest) ((RCCtrlPairing, ByteString)
-> Either RCErrorType (RCCtrlPairing, ByteString)
forall a b. b -> Either a b
Right ((RCCtrlPairing, ByteString)
 -> Either RCErrorType (RCCtrlPairing, ByteString))
-> (ByteString -> (RCCtrlPairing, ByteString))
-> ByteString
-> Either RCErrorType (RCCtrlPairing, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RCCtrlPairing
pairing,)) Maybe ByteString
r
    decrypt_ :: C.PrivateKeyX25519 -> Maybe ByteString
    decrypt_ :: PrivateKey 'X25519 -> Maybe ByteString
decrypt_ PrivateKey 'X25519
dhPrivKey =
      let key :: DhSecret 'X25519
key = PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKeyX25519
dhPubKey PrivateKey 'X25519
dhPrivKey
       in Either CryptoError ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either CryptoError ByteString -> Maybe ByteString)
-> Either CryptoError ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt DhSecret 'X25519
key CbNonce
nonce ByteString
encInvitation

-- * Controller handle operations

-- application should call this function when TMVar resolves
confirmCtrlSession :: RCCtrlClient -> Bool -> IO ()
confirmCtrlSession :: RCCtrlClient -> Bool -> IO ()
confirmCtrlSession RCCtrlClient {$sel:client_:RCCtrlClient :: RCCtrlClient -> RCCClient_
client_ = RCCClient_ {TMVar Bool
$sel:confirmSession:RCCClient_ :: RCCClient_ -> TMVar Bool
confirmSession :: TMVar Bool
confirmSession}} Bool
res = do
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
confirmSession Bool
res
  -- controler does takeTMVar, freeing the slot
  -- TODO add timeout
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Bool
confirmSession Bool
res -- wait for Ctrl to take the var

cancelCtrlClient :: RCCtrlClient -> IO ()
cancelCtrlClient :: RCCtrlClient -> IO ()
cancelCtrlClient RCCtrlClient {Async ()
$sel:action:RCCtrlClient :: RCCtrlClient -> Async ()
action :: Async ()
action, $sel:client_:RCCtrlClient :: RCCtrlClient -> RCCClient_
client_ = RCCClient_ {TMVar ()
$sel:endSession:RCCClient_ :: RCCClient_ -> TMVar ()
endSession :: TMVar ()
endSession}} = do
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
endSession ()
  Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel Async ()
action

-- * Session encryption

rcEncryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcEncryptBody :: (SbKey, CbNonce) -> ByteString -> ExceptT RCErrorType IO ByteString
rcEncryptBody (SbKey, CbNonce)
keyNonce ByteString
s = do
  (CryptoError -> RCErrorType)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEEncrypt) (Either CryptoError ByteString
 -> ExceptT RCErrorType IO ByteString)
-> Either CryptoError ByteString
-> ExceptT RCErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ (SbKey, CbNonce) -> ByteString -> Either CryptoError ByteString
LC.sbEncryptTailTagNoPad (SbKey, CbNonce)
keyNonce ByteString
s

rcDecryptBody :: C.SbKeyNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcDecryptBody :: (SbKey, CbNonce) -> ByteString -> ExceptT RCErrorType IO ByteString
rcDecryptBody (SbKey, CbNonce)
keyNonce ByteString
ct = do
  let len :: Int64
len = ByteString -> Int64
LB.length ByteString
ct Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
16
  Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0) (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEDecrypt
  (Bool
ok, ByteString
s) <- (CryptoError -> RCErrorType)
-> Either CryptoError (Bool, ByteString)
-> ExceptT RCErrorType IO (Bool, ByteString)
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (RCErrorType -> CryptoError -> RCErrorType
forall a b. a -> b -> a
const RCErrorType
RCEDecrypt) (Either CryptoError (Bool, ByteString)
 -> ExceptT RCErrorType IO (Bool, ByteString))
-> Either CryptoError (Bool, ByteString)
-> ExceptT RCErrorType IO (Bool, ByteString)
forall a b. (a -> b) -> a -> b
$ (SbKey, CbNonce)
-> Int64 -> ByteString -> Either CryptoError (Bool, ByteString)
LC.sbDecryptTailTagNoPad (SbKey, CbNonce)
keyNonce Int64
len ByteString
ct
  Bool -> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ())
-> ExceptT RCErrorType IO () -> ExceptT RCErrorType IO ()
forall a b. (a -> b) -> a -> b
$ RCErrorType -> ExceptT RCErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE RCErrorType
RCEDecrypt
  ByteString -> ExceptT RCErrorType IO ByteString
forall a. a -> ExceptT RCErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s