{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module MLS.Util where

import API.Brig
import API.BrigCommon
import API.Galley
import Control.Concurrent.Async hiding (link)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Codensity
import Control.Monad.Cont
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Char8 as C8
import Data.Default
import Data.Foldable
import Data.Function
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text.Encoding as T
import Data.Traversable
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUIDV4
import GHC.Stack
import Notifications
import System.Directory
import System.Exit
import System.FilePath
import System.IO hiding (print, putStrLn)
import System.IO.Error (isAlreadyExistsError)
import System.IO.Temp
import System.Posix.Files
import System.Process
import Testlib.Assertions
import Testlib.HTTP
import Testlib.JSON
import Testlib.Prelude
import Testlib.Printing

mkClientIdentity :: (MakesValue u, MakesValue c) => u -> c -> App ClientIdentity
mkClientIdentity :: forall u c.
(MakesValue u, MakesValue c) =>
u -> c -> App ClientIdentity
mkClientIdentity u
u c
c = do
  (domain, user) <- u -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid u
u
  client <- c %. "id" & asString
  pure $ ClientIdentity {domain = domain, user = user, client = client}

cid2Str :: ClientIdentity -> String
cid2Str :: ClientIdentity -> String
cid2Str ClientIdentity
cid = ClientIdentity
cid.user String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClientIdentity
cid.client String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClientIdentity
cid.domain

data MessagePackage = MessagePackage
  { MessagePackage -> ClientIdentity
sender :: ClientIdentity,
    MessagePackage -> ConvId
convId :: ConvId,
    MessagePackage -> ByteString
message :: ByteString,
    MessagePackage -> Maybe ByteString
welcome :: Maybe ByteString,
    MessagePackage -> Maybe ByteString
groupInfo :: Maybe ByteString
  }

toRandomFile :: ByteString -> App FilePath
toRandomFile :: ByteString -> App String
toRandomFile ByteString
bs = do
  p <- App String
randomFileName
  liftIO $ BS.writeFile p bs
  pure p

randomFileName :: App FilePath
randomFileName :: App String
randomFileName = do
  bd <- App String
getBaseDir
  (bd </>) . UUID.toString <$> liftIO UUIDV4.nextRandom

mlscli :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli :: HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
mConvId Ciphersuite
cs ClientIdentity
cid [String]
args Maybe ByteString
mbstdin = do
  groupOut <- App String
randomFileName
  let substOut = String -> String -> String -> String
argSubst String
"<group-out>" String
groupOut
  let scheme = Ciphersuite -> String
csSignatureScheme Ciphersuite
cs

  gs <- getClientGroupState cid

  substIn <- case flip Map.lookup gs.groups =<< mConvId of
    Maybe ByteString
Nothing -> (String -> String) -> App (String -> String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> String
forall a. a -> a
id
    Just ByteString
groupData -> do
      fn <- ByteString -> App String
toRandomFile ByteString
groupData
      pure (argSubst "<group-in>" fn)
  store <- case Map.lookup scheme gs.keystore of
    Maybe ByteString
Nothing -> do
      bd <- App String
getBaseDir
      liftIO (createDirectory (bd </> cid2Str cid))
        `catch` \IOError
e ->
          if (IOError -> Bool
isAlreadyExistsError IOError
e)
            then () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- creates a file per signature scheme
            else IOError -> App ()
forall e a. (HasCallStack, Exception e) => e -> App a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM IOError
e

      -- initialise new keystore
      path <- randomFileName
      ctype <- make gs.credType & asString
      void $ runCli path ["init", "--ciphersuite", cs.code, "-t", ctype, cid2Str cid] Nothing
      pure path
    Just ByteString
s -> ByteString -> App String
toRandomFile ByteString
s

  let args' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
substIn (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
substOut) [String]
args
  for_ args' $ \String
arg ->
    Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
arg String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"<group-in>", String
"<group-out>"]) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
      String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String
"Unbound arg: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
arg)

  out <- runCli store args' mbstdin
  setGroup <- do
    groupOutWritten <- liftIO $ doesFileExist groupOut
    case (groupOutWritten, mConvId) of
      (Bool
True, Just ConvId
convId) -> do
        groupData <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BS.readFile String
groupOut)
        pure $ \ClientGroupState
x -> ClientGroupState
x {groups = Map.insert convId groupData x.groups}
      (Bool
True, Maybe ConvId
Nothing) -> do
        String -> App ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
red String
"mls-test-cli: Group was written but no convId was provided, this probably indicates something is going to go wrong in this test."
        String -> App ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (String -> App ()) -> App String -> App ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CallStack -> IO String
prettierCallStack CallStack
HasCallStack => CallStack
callStack)
        (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientGroupState -> ClientGroupState
forall a. a -> a
id
      (Bool, Maybe ConvId)
_ -> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientGroupState -> ClientGroupState
forall a. a -> a
id
  setStore <- do
    storeData <- liftIO (BS.readFile store)
    pure $ \ClientGroupState
x -> ClientGroupState
x {keystore = Map.insert scheme storeData x.keystore}

  setClientGroupState cid (setGroup (setStore gs))

  pure out

runCli :: (HasCallStack) => FilePath -> [String] -> Maybe ByteString -> App ByteString
runCli :: HasCallStack =>
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
store [String]
args Maybe ByteString
mStdin =
  HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString
CreateProcess -> Maybe ByteString -> App ByteString
spawn
    ( String -> [String] -> CreateProcess
proc
        String
"mls-test-cli"
        ( [String
"--store", String
store]
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
args
        )
    )
    Maybe ByteString
mStdin

argSubst :: String -> String -> String -> String
argSubst :: String -> String -> String -> String
argSubst String
from String
to_ String
s =
  if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
from then String
to_ else String
s

createWireClient :: (MakesValue u, HasCallStack) => u -> AddClient -> App ClientIdentity
createWireClient :: forall u.
(MakesValue u, HasCallStack) =>
u -> AddClient -> App ClientIdentity
createWireClient u
u AddClient
clientArgs = do
  u -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient u
u AddClient
clientArgs
    App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
    App Value -> (Value -> App ClientIdentity) -> App ClientIdentity
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= u -> Value -> App ClientIdentity
forall u c.
(MakesValue u, MakesValue c) =>
u -> c -> App ClientIdentity
mkClientIdentity u
u

data InitMLSClient = InitMLSClient
  { InitMLSClient -> CredentialType
credType :: CredentialType,
    InitMLSClient -> AddClient
clientArgs :: AddClient,
    InitMLSClient -> [Ciphersuite]
ciphersuites :: [Ciphersuite]
  }

instance Default InitMLSClient where
  def :: InitMLSClient
def = InitMLSClient {credType :: CredentialType
credType = CredentialType
BasicCredentialType, clientArgs :: AddClient
clientArgs = AddClient
forall a. Default a => a
def, ciphersuites :: [Ciphersuite]
ciphersuites = [Ciphersuite
forall a. Default a => a
def]}

initMLSClient :: InitMLSClient -> ClientIdentity -> App Value
initMLSClient :: InitMLSClient -> ClientIdentity -> App Value
initMLSClient InitMLSClient
opts ClientIdentity
cid = do
  HasCallStack => ClientIdentity -> ClientGroupState -> App ()
ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid ClientGroupState
forall a. Default a => a
def {credType = opts.credType}

  -- set public key
  suitePKeys <- [Ciphersuite]
-> (Ciphersuite -> App (Ciphersuite, ByteString))
-> App [(Ciphersuite, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for InitMLSClient
opts.ciphersuites ((Ciphersuite -> App (Ciphersuite, ByteString))
 -> App [(Ciphersuite, ByteString)])
-> (Ciphersuite -> App (Ciphersuite, ByteString))
-> App [(Ciphersuite, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Ciphersuite
ciphersuite -> (Ciphersuite
ciphersuite,) (ByteString -> (Ciphersuite, ByteString))
-> App ByteString -> App (Ciphersuite, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
ciphersuite ClientIdentity
cid [String
"public-key"] Maybe ByteString
forall a. Maybe a
Nothing
  let keys =
        [Pair] -> Value
object
          [ Ciphersuite -> String
csSignatureScheme Ciphersuite
ciphersuite String -> Text -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
Base64.encode ByteString
pkey)
            | (Ciphersuite
ciphersuite, ByteString
pkey) <- [(Ciphersuite, ByteString)]
suitePKeys
          ]
  bindResponse
    ( updateClient
        cid
        def
          { mlsPublicKeys = Just keys
          }
    )
    $ \Response
resp -> Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  pure keys

-- | Create new mls client and register with backend.
createMLSClient :: (MakesValue u, HasCallStack) => InitMLSClient -> u -> App ClientIdentity
createMLSClient :: forall u.
(MakesValue u, HasCallStack) =>
InitMLSClient -> u -> App ClientIdentity
createMLSClient InitMLSClient
opts u
u = do
  cid <- u -> AddClient -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
u -> AddClient -> App ClientIdentity
createWireClient u
u InitMLSClient
opts.clientArgs
  void $ initMLSClient opts cid
  pure cid

-- | create and upload to backend
uploadNewKeyPackage :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App String
uploadNewKeyPackage :: HasCallStack => Ciphersuite -> ClientIdentity -> App String
uploadNewKeyPackage Ciphersuite
suite ClientIdentity
cid = do
  (kp, ref) <- HasCallStack =>
ClientIdentity -> Ciphersuite -> App (ByteString, String)
ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid Ciphersuite
suite

  -- upload key package
  bindResponse (uploadKeyPackages cid [kp]) $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201

  pure ref

generateKeyPackage :: (HasCallStack) => ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage :: HasCallStack =>
ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid Ciphersuite
suite = do
  kp <- HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
suite ClientIdentity
cid [String
"key-package", String
"create", String
"--ciphersuite", Ciphersuite
suite.code] Maybe ByteString
forall a. Maybe a
Nothing
  ref <- B8.unpack . Base64.encode <$> mlscli Nothing suite cid ["key-package", "ref", "-"] (Just kp)
  fp <- keyPackageFile cid ref
  liftIO $ BS.writeFile fp kp
  pure (kp, ref)

-- | Create conversation and corresponding group.
createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup :: HasCallStack => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup Ciphersuite
cs ClientIdentity
cid = HasCallStack =>
Ciphersuite -> ClientIdentity -> CreateConv -> App ConvId
Ciphersuite -> ClientIdentity -> CreateConv -> App ConvId
createNewGroupWith Ciphersuite
cs ClientIdentity
cid CreateConv
defMLS

-- | Create conversation and corresponding group.
createNewGroupWith :: (HasCallStack) => Ciphersuite -> ClientIdentity -> CreateConv -> App ConvId
createNewGroupWith :: HasCallStack =>
Ciphersuite -> ClientIdentity -> CreateConv -> App ConvId
createNewGroupWith Ciphersuite
cs ClientIdentity
cid CreateConv
cc = do
  conv <- ClientIdentity -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation ClientIdentity
cid CreateConv
cc {protocol = "mls"} App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
  convId <- objConvId conv
  createGroup cs cid convId
  pure convId

-- | Retrieve self conversation and create the corresponding group.
createSelfGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App (String, Value)
createSelfGroup :: HasCallStack =>
Ciphersuite -> ClientIdentity -> App (String, Value)
createSelfGroup Ciphersuite
cs ClientIdentity
cid = do
  conv <- ClientIdentity -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
getSelfConversation ClientIdentity
cid App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
  convId <- objConvId conv
  groupId <- conv %. "group_id" & asString
  createGroup cs cid convId
  pure (groupId, conv)

createGroup :: Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup :: Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId = do
  let Just String
groupId = ConvId
convId.groupId
  (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
    let mlsConv :: MLSConv
mlsConv =
          MLSConv
            { members :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
              newMembers :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
              memberUsers :: Set Value
memberUsers = Value -> Set Value
forall a. a -> Set a
Set.singleton ClientIdentity
cid.qualifiedUserId,
              membersToBeRemoved :: Set ClientIdentity
membersToBeRemoved = Set ClientIdentity
forall a. Monoid a => a
mempty,
              String
groupId :: String
groupId :: String
groupId,
              convId :: ConvId
convId = ConvId
convId,
              epoch :: Word64
epoch = Word64
0,
              ciphersuite :: Ciphersuite
ciphersuite = Ciphersuite
cs
            }
     in MLSState
s {convs = Map.insert convId mlsConv s.convs}
  keys <- Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
getMLSPublicKeys ClientIdentity
cid.qualifiedUserId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
  resetClientGroup cs cid groupId convId keys

deleteGroup :: ConvId -> App MLSConv
deleteGroup :: ConvId -> App MLSConv
deleteGroup ConvId
convId = do
  mlsConv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  let allClients = MLSConv
mlsConv.members Set ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Semigroup a => a -> a -> a
<> MLSConv
mlsConv.newMembers Set ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Semigroup a => a -> a -> a
<> MLSConv
mlsConv.membersToBeRemoved
  modifyMLSState $ \MLSState
s ->
    MLSState
s
      { convs = Map.delete convId s.convs,
        clientGroupState = Map.filterWithKey (\ClientIdentity
k ClientGroupState
_ -> ClientIdentity -> Set ClientIdentity -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ClientIdentity
k Set ClientIdentity
allClients) s.clientGroupState
      }
  pure mlsConv

resetGroup :: ClientIdentity -> ConvId -> String -> App ConvId
resetGroup :: ClientIdentity -> ConvId -> String -> App ConvId
resetGroup ClientIdentity
cid ConvId
convId String
groupId = do
  mlsConv <- ConvId -> App MLSConv
deleteGroup ConvId
convId
  let convId' = ConvId
convId {groupId = Just groupId} :: ConvId
  createGroup mlsConv.ciphersuite cid convId'
  pure convId'

createSubConv :: (HasCallStack) => Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv :: HasCallStack =>
Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv Ciphersuite
cs ConvId
convId ClientIdentity
cid String
subId = do
  sub <- ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
subId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
  subConvId <- objConvId sub
  createGroup cs cid subConvId
  void $ createPendingProposalCommit subConvId cid >>= sendAndConsumeCommitBundle

createOne2OneSubConv :: (HasCallStack, MakesValue keys) => Ciphersuite -> ConvId -> ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv :: forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ConvId -> ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv Ciphersuite
cs ConvId
convId ClientIdentity
cid String
subId keys
keys = do
  sub <- ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
subId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
  subConvId <- objConvId sub
  resetOne2OneGroupGeneric cs cid sub keys
  void $ createPendingProposalCommit subConvId cid >>= sendAndConsumeCommitBundle

resetOne2OneGroup :: (HasCallStack, MakesValue one2OneConv) => Ciphersuite -> ClientIdentity -> one2OneConv -> App ()
resetOne2OneGroup :: forall one2OneConv.
(HasCallStack, MakesValue one2OneConv) =>
Ciphersuite -> ClientIdentity -> one2OneConv -> App ()
resetOne2OneGroup Ciphersuite
cs ClientIdentity
cid one2OneConv
one2OneConv =
  Ciphersuite -> ClientIdentity -> App Value -> App Value -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid (one2OneConv
one2OneConv one2OneConv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation") (one2OneConv
one2OneConv one2OneConv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_keys")

-- | Useful when keys are to be taken from main conv and the conv here is the subconv
resetOne2OneGroupGeneric :: (HasCallStack, MakesValue conv, MakesValue keys) => Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric :: forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid conv
conv keys
keys = do
  convId <- conv -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId conv
conv
  groupId <- conv %. "group_id" & asString
  modifyMLSState $ \MLSState
s ->
    let newMLSConv :: MLSConv
newMLSConv =
          MLSConv
            { members :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
              newMembers :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
              memberUsers :: Set Value
memberUsers = Value -> Set Value
forall a. a -> Set a
Set.singleton ClientIdentity
cid.qualifiedUserId,
              membersToBeRemoved :: Set ClientIdentity
membersToBeRemoved = Set ClientIdentity
forall a. Monoid a => a
mempty,
              groupId :: String
groupId = String
groupId,
              convId :: ConvId
convId = ConvId
convId,
              epoch :: Word64
epoch = Word64
0,
              ciphersuite :: Ciphersuite
ciphersuite = Ciphersuite
cs
            }
        resetConv :: MLSConv -> r -> MLSConv
resetConv MLSConv
old r
new =
          MLSConv
old
            { groupId = new.groupId,
              convId = new.convId,
              members = new.members,
              memberUsers = new.memberUsers,
              newMembers = new.newMembers,
              epoch = new.epoch
            }
     in MLSState
s {convs = Map.insertWith resetConv convId newMLSConv s.convs}

  resetClientGroup cs cid groupId convId keys

resetClientGroup :: (HasCallStack, MakesValue keys) => Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup :: forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
gid ConvId
convId keys
keys = do
  removalKey <- App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString (App Value -> App ByteString) -> App Value -> App ByteString
forall a b. (a -> b) -> a -> b
$ keys
keys keys -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. (String
"removal." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ciphersuite -> String
csSignatureScheme Ciphersuite
cs)
  void $
    mlscli
      (Just convId)
      cs
      cid
      [ "group",
        "create",
        "--removal-key",
        "-",
        "--group-out",
        "<group-out>",
        "--ciphersuite",
        cs.code,
        gid
      ]
      (Just removalKey)

keyPackageFile :: (HasCallStack) => ClientIdentity -> String -> App FilePath
keyPackageFile :: HasCallStack => ClientIdentity -> String -> App String
keyPackageFile ClientIdentity
cid String
ref = do
  let ref' :: String
ref' = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
urlSafe String
ref
  bd <- App String
getBaseDir
  pure $ bd </> cid2Str cid </> ref'
  where
    urlSafe :: Char -> Char
urlSafe Char
'+' = Char
'-'
    urlSafe Char
'/' = Char
'_'
    urlSafe Char
c = Char
c

unbundleKeyPackages :: (HasCallStack) => Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages :: HasCallStack => Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages Value
bundle = do
  let entryIdentity :: a -> App ClientIdentity
entryIdentity a
be = do
        d <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
        u <- be %. "user" & asString
        c <- be %. "client" & asString
        pure $ ClientIdentity {domain = d, user = u, client = c}

  bundleEntries <- Value
bundle Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key_packages" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
  for bundleEntries $ \Value
be -> do
    kp64 <- Value
be Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key_package" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    kp <- assertOne . toList . Base64.decode . B8.pack $ kp64
    cid <- entryIdentity be
    pure (cid, kp)

-- | Claim keypackages and create a commit/welcome pair on a given client.
-- Note that this alters the state of the group immediately. If we want to test
-- a scenario where the commit is rejected by the backend, we can restore the
-- group to the previous state by using an older version of the group file.
createAddCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit :: HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
cid ConvId
convId [Value]
users = do
  conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  kps <- fmap concat . for users $ \Value
user -> do
    bundle <- Ciphersuite -> ClientIdentity -> Value -> App Response
forall u v.
(HasCallStack, MakesValue u, MakesValue v) =>
Ciphersuite -> u -> v -> App Response
claimKeyPackages MLSConv
conv.ciphersuite ClientIdentity
cid Value
user App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    unbundleKeyPackages bundle
  createAddCommitWithKeyPackages cid convId kps

withTempKeyPackageFile :: ByteString -> ContT a App FilePath
withTempKeyPackageFile :: forall a. ByteString -> ContT a App String
withTempKeyPackageFile ByteString
bs = do
  bd <- App String -> ContT a App String
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift App String
getBaseDir
  ContT $ \String -> App a
k ->
    App (String, Handle)
-> ((String, Handle) -> App ())
-> ((String, Handle) -> App a)
-> App a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
      (IO (String, Handle) -> App (String, Handle)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO (String, Handle)
openBinaryTempFile String
bd String
"kp"))
      (\(String
fp, Handle
_) -> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
removeFile String
fp))
      (((String, Handle) -> App a) -> App a)
-> ((String, Handle) -> App a) -> App a
forall a b. (a -> b) -> a -> b
$ \(String
fp, Handle
h) -> do
        IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` Handle -> IO ()
hClose Handle
h
        String -> App a
k String
fp

createAddCommitWithKeyPackages ::
  (HasCallStack) =>
  ClientIdentity ->
  ConvId ->
  [(ClientIdentity, ByteString)] ->
  App MessagePackage
createAddCommitWithKeyPackages :: HasCallStack =>
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid ConvId
convId [(ClientIdentity, ByteString)]
clientsAndKeyPackages = do
  bd <- App String
getBaseDir
  welcomeFile <- liftIO $ emptyTempFile bd "welcome"
  giFile <- liftIO $ emptyTempFile bd "gi"
  Just conv <- Map.lookup convId . (.convs) <$> getMLSState

  commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \[String]
kpFiles ->
    HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
      (ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
      MLSConv
conv.ciphersuite
      ClientIdentity
cid
      ( [ String
"member",
          String
"add",
          String
"--group",
          String
"<group-in>",
          String
"--welcome-out",
          String
welcomeFile,
          String
"--group-info-out",
          String
giFile,
          String
"--group-out",
          String
"<group-out>"
        ]
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
kpFiles
      )
      Maybe ByteString
forall a. Maybe a
Nothing

  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            ( \MLSConv
oldConvState ->
                MLSConv
oldConvState {newMembers = Set.fromList (map fst clientsAndKeyPackages)}
            )
            convId
            mls.convs
      }

  welcome <- liftIO $ BS.readFile welcomeFile
  gi <- liftIO $ BS.readFile giFile
  pure $
    MessagePackage
      { sender = cid,
        convId = convId,
        message = commit,
        welcome = Just welcome,
        groupInfo = Just gi
      }

createRemoveCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit :: HasCallStack =>
ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit ClientIdentity
cid ConvId
convId [ClientIdentity]
targets = do
  bd <- App String
getBaseDir
  welcomeFile <- liftIO $ emptyTempFile bd "welcome"
  giFile <- liftIO $ emptyTempFile bd "gi"

  groupStateMap <- do
    gs <- getClientGroupState cid
    groupData <- assertJust "Group state not initialised" (Map.lookup convId gs.groups)
    Map.fromList <$> readGroupState groupData
  let indices = (ClientIdentity -> Word32) -> [ClientIdentity] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe (String -> Word32
forall a. HasCallStack => String -> a
error String
"could not find target") (Maybe Word32 -> Word32)
-> (ClientIdentity -> Maybe Word32) -> ClientIdentity -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity -> Map ClientIdentity Word32 -> Maybe Word32)
-> Map ClientIdentity Word32 -> ClientIdentity -> Maybe Word32
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientIdentity -> Map ClientIdentity Word32 -> Maybe Word32
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map ClientIdentity Word32
groupStateMap) [ClientIdentity]
targets

  conv <- getMLSConv convId

  commit <-
    mlscli
      (Just convId)
      conv.ciphersuite
      cid
      ( [ "member",
          "remove",
          "--group",
          "<group-in>",
          "--group-out",
          "<group-out>",
          "--welcome-out",
          welcomeFile,
          "--group-info-out",
          giFile
        ]
          <> map show indices
      )
      Nothing

  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            ( \MLSConv
oldConvState ->
                MLSConv
oldConvState {membersToBeRemoved = Set.fromList targets}
            )
            convId
            mls.convs
      }

  welcome <- liftIO $ BS.readFile welcomeFile
  gi <- liftIO $ BS.readFile giFile

  pure
    MessagePackage
      { sender = cid,
        convId = convId,
        message = commit,
        welcome = Just welcome,
        groupInfo = Just gi
      }

createAddProposals :: (HasCallStack) => ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals :: HasCallStack =>
ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals ConvId
convId ClientIdentity
cid [Value]
users = do
  Just mls <- ConvId -> Map ConvId MLSConv -> Maybe MLSConv
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConvId
convId (Map ConvId MLSConv -> Maybe MLSConv)
-> (MLSState -> Map ConvId MLSConv) -> MLSState -> Maybe MLSConv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.convs) (MLSState -> Maybe MLSConv) -> App MLSState -> App (Maybe MLSConv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
  bundles <- for users $ (claimKeyPackages mls.ciphersuite cid >=> getJSON 200)
  kps <- concat <$> traverse unbundleKeyPackages bundles
  traverse (createAddProposalWithKeyPackage convId cid) kps

createReInitProposal :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal ConvId
convId ClientIdentity
cid = do
  conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  prop <-
    mlscli
      (Just convId)
      conv.ciphersuite
      cid
      ["proposal", "--group-in", "<group-in>", "--group-out", "<group-out>", "re-init"]
      Nothing
  pure
    MessagePackage
      { sender = cid,
        convId = convId,
        message = prop,
        welcome = Nothing,
        groupInfo = Nothing
      }

createAddProposalWithKeyPackage ::
  ConvId ->
  ClientIdentity ->
  (ClientIdentity, ByteString) ->
  App MessagePackage
createAddProposalWithKeyPackage :: ConvId
-> ClientIdentity
-> (ClientIdentity, ByteString)
-> App MessagePackage
createAddProposalWithKeyPackage ConvId
convId ClientIdentity
cid (ClientIdentity
_, ByteString
kp) = do
  conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  prop <- runContT (withTempKeyPackageFile kp) $ \String
kpFile ->
    HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
      (ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
      MLSConv
conv.ciphersuite
      ClientIdentity
cid
      [String
"proposal", String
"--group-in", String
"<group-in>", String
"--group-out", String
"<group-out>", String
"add", String
kpFile]
      Maybe ByteString
forall a. Maybe a
Nothing
  pure
    MessagePackage
      { sender = cid,
        convId = convId,
        message = prop,
        welcome = Nothing,
        groupInfo = Nothing
      }

createPendingProposalCommit :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
convId ClientIdentity
cid = do
  bd <- App String
getBaseDir
  welcomeFile <- liftIO $ emptyTempFile bd "welcome"
  pgsFile <- liftIO $ emptyTempFile bd "pgs"
  conv <- getMLSConv convId
  commit <-
    mlscli
      (Just convId)
      conv.ciphersuite
      cid
      [ "commit",
        "--group",
        "<group-in>",
        "--group-out",
        "<group-out>",
        "--welcome-out",
        welcomeFile,
        "--group-info-out",
        pgsFile
      ]
      Nothing

  welcome <- liftIO $ readWelcome welcomeFile
  pgs <- liftIO $ BS.readFile pgsFile
  pure
    MessagePackage
      { sender = cid,
        convId = convId,
        message = commit,
        welcome = welcome,
        groupInfo = Just pgs
      }

createExternalCommit ::
  (HasCallStack) =>
  ConvId ->
  ClientIdentity ->
  Maybe ByteString ->
  App MessagePackage
createExternalCommit :: HasCallStack =>
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
createExternalCommit ConvId
convId ClientIdentity
cid Maybe ByteString
mgi = do
  bd <- App String
getBaseDir
  giFile <- liftIO $ emptyTempFile bd "gi"
  gi <- case mgi of
    Maybe ByteString
Nothing -> ClientIdentity -> ConvId -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> App Response
getGroupInfo ClientIdentity
cid ConvId
convId App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
    Just ByteString
v -> ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
v
  conv <- getMLSConv convId
  commit <-
    mlscli
      (Just convId)
      conv.ciphersuite
      cid
      [ "external-commit",
        "--group-info-in",
        "-",
        "--group-info-out",
        giFile,
        "--group-out",
        "<group-out>"
      ]
      (Just gi)

  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs = Map.adjust (\MLSConv
oldConvState -> MLSConv
oldConvState {newMembers = Set.singleton cid}) convId mls.convs
      -- This might be a different client than those that have been in the
      -- group from before.
      }

  newPgs <- liftIO $ BS.readFile giFile
  pure $
    MessagePackage
      { sender = cid,
        convId = convId,
        message = commit,
        welcome = Nothing,
        groupInfo = Just newPgs
      }

data MLSNotificationTag = MLSNotificationMessageTag | MLSNotificationWelcomeTag
  deriving (Int -> MLSNotificationTag -> String -> String
[MLSNotificationTag] -> String -> String
MLSNotificationTag -> String
(Int -> MLSNotificationTag -> String -> String)
-> (MLSNotificationTag -> String)
-> ([MLSNotificationTag] -> String -> String)
-> Show MLSNotificationTag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MLSNotificationTag -> String -> String
showsPrec :: Int -> MLSNotificationTag -> String -> String
$cshow :: MLSNotificationTag -> String
show :: MLSNotificationTag -> String
$cshowList :: [MLSNotificationTag] -> String -> String
showList :: [MLSNotificationTag] -> String -> String
Show, MLSNotificationTag -> MLSNotificationTag -> Bool
(MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> Eq MLSNotificationTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MLSNotificationTag -> MLSNotificationTag -> Bool
== :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c/= :: MLSNotificationTag -> MLSNotificationTag -> Bool
/= :: MLSNotificationTag -> MLSNotificationTag -> Bool
Eq, Eq MLSNotificationTag
Eq MLSNotificationTag =>
(MLSNotificationTag -> MLSNotificationTag -> Ordering)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag)
-> (MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag)
-> Ord MLSNotificationTag
MLSNotificationTag -> MLSNotificationTag -> Bool
MLSNotificationTag -> MLSNotificationTag -> Ordering
MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MLSNotificationTag -> MLSNotificationTag -> Ordering
compare :: MLSNotificationTag -> MLSNotificationTag -> Ordering
$c< :: MLSNotificationTag -> MLSNotificationTag -> Bool
< :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c<= :: MLSNotificationTag -> MLSNotificationTag -> Bool
<= :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c> :: MLSNotificationTag -> MLSNotificationTag -> Bool
> :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c>= :: MLSNotificationTag -> MLSNotificationTag -> Bool
>= :: MLSNotificationTag -> MLSNotificationTag -> Bool
$cmax :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
max :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
$cmin :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
min :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
Ord)

consumingMessages :: (HasCallStack) => MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages :: HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
mlsProtocol MessagePackage
mp = (forall b. (() -> App b) -> App b) -> Codensity App ()
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (() -> App b) -> App b) -> Codensity App ())
-> (forall b. (() -> App b) -> App b) -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ \() -> App b
k -> do
  conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
  -- clients that should receive the message itself
  let oldClients = ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender MLSConv
conv.members
  -- clients that should receive a welcome message
  let newClients = ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender MLSConv
conv.newMembers
  -- all clients that should receive some MLS notification, together with the
  -- expected notification tag
  let clients =
        (ClientIdentity -> (ClientIdentity, MLSNotificationTag))
-> [ClientIdentity] -> [(ClientIdentity, MLSNotificationTag)]
forall a b. (a -> b) -> [a] -> [b]
map (,MLSNotificationTag
MLSNotificationMessageTag) (Set ClientIdentity -> [ClientIdentity]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ClientIdentity
oldClients)
          [(ClientIdentity, MLSNotificationTag)]
-> [(ClientIdentity, MLSNotificationTag)]
-> [(ClientIdentity, MLSNotificationTag)]
forall a. Semigroup a => a -> a -> a
<> (ClientIdentity -> (ClientIdentity, MLSNotificationTag))
-> [ClientIdentity] -> [(ClientIdentity, MLSNotificationTag)]
forall a b. (a -> b) -> [a] -> [b]
map (,MLSNotificationTag
MLSNotificationWelcomeTag) (Set ClientIdentity -> [ClientIdentity]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ClientIdentity
newClients)

  let newUsers =
        Value -> Set Value -> Set Value
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender.qualifiedUserId (Set Value -> Set Value) -> Set Value -> Set Value
forall a b. (a -> b) -> a -> b
$
          Set Value -> Set Value -> Set Value
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
            ((ClientIdentity -> Value) -> Set ClientIdentity -> Set Value
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (.qualifiedUserId) Set ClientIdentity
newClients)
            MLSConv
conv.memberUsers

  withWebSockets (map fst clients) $ \[WebSocket]
wss -> do
    r <- () -> App b
k ()

    -- if the conversation is actually MLS (and not mixed), pick one client for
    -- each new user and wait for its join event. In Mixed protocol, the user is
    -- already in the conversation so they do not get a member-join
    -- notification.
    when (mlsProtocol == MLSProtocolMLS) $
      traverse_
        (awaitMatch isMemberJoinNotif)
        ( flip Map.restrictKeys newUsers
            . Map.mapKeys ((.qualifiedUserId) . fst)
            . Map.fromList
            . toList
            $ zip clients wss
        )

    -- at this point we know that every new user has been added to the
    -- conversation
    for_ (zip clients wss) $ \((ClientIdentity
cid, MLSNotificationTag
t), WebSocket
ws) -> case MLSNotificationTag
t of
      MLSNotificationTag
MLSNotificationMessageTag ->
        Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MLSConv
conv.epoch Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
          App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal MLSConv
conv.ciphersuite ClientIdentity
cid MessagePackage
mp WebSocket
ws
      MLSNotificationTag
MLSNotificationWelcomeTag -> HasCallStack =>
ClientIdentity -> MessagePackage -> WebSocket -> App ()
ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome ClientIdentity
cid MessagePackage
mp WebSocket
ws
    pure r

consumeMessageWithPredicate :: (HasCallStack) => (Value -> App Bool) -> ConvId -> Ciphersuite -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageWithPredicate :: HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
p ConvId
convId Ciphersuite
cs ClientIdentity
cid Maybe MessagePackage
mmp WebSocket
ws = do
  notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
p WebSocket
ws
  event <- notif %. "payload.0"

  event %. "qualified_conversation" `shouldMatch` convIdToQidObject convId
  lookupField event "subconv" `shouldMatch` convId.subconvId

  for_ mmp $ \MessagePackage
mp -> do
    Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"from" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` MessagePackage
mp.sender.user
    Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ByteString -> String
B8.unpack (ByteString -> ByteString
Base64.encode MessagePackage
mp.message))

  msgData <- event %. "data" & asByteString
  _ <- mlsCliConsume convId cs cid msgData
  showMessage cs cid msgData

-- | Get a single MLS message from a websocket and consume it. Return a JSON
-- representation of the message.
consumeMessage :: (HasCallStack) => ConvId -> Ciphersuite -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessage :: HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage = HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif

-- | like 'consumeMessage' but will not consume a message where the sender is the backend
consumeMessageNoExternal :: (HasCallStack) => Ciphersuite -> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal :: HasCallStack =>
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal Ciphersuite
cs ClientIdentity
cid MessagePackage
mp = HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
isNewMLSMessageNotifButNoProposal MessagePackage
mp.convId Ciphersuite
cs ClientIdentity
cid (MessagePackage -> Maybe MessagePackage
forall a. a -> Maybe a
Just MessagePackage
mp)
  where
    -- the backend (correctly) reacts to a commit removing someone from a parent conversation with a
    -- remove proposal, however, we don't want to consume this here
    isNewMLSMessageNotifButNoProposal :: Value -> App Bool
    isNewMLSMessageNotifButNoProposal :: Value -> App Bool
isNewMLSMessageNotifButNoProposal Value
n = do
      isRelevantNotif <- Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif Value
n App Bool -> App Bool -> App Bool
&&~ ConvId -> Value -> App Bool
forall a.
(HasCallStack, MakesValue a, HasCallStack) =>
ConvId -> a -> App Bool
isNotifConvId MessagePackage
mp.convId Value
n
      if isRelevantNotif
        then do
          msg <- n %. "payload.0.data" & asByteString >>= showMessage cs cid
          sender <- msg `lookupField` "message.content.sender" `catch` \(AssertionFailure
_ :: AssertionFailure) -> Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
          let backendSender = [Pair] -> Value
object [String
"External" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Scientific -> Value
Number Scientific
0]
          pure $ sender /= Just backendSender
        else pure False

mlsCliConsume :: (HasCallStack) => ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume :: HasCallStack =>
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
msgData =
  HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
    (ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
    Ciphersuite
cs
    ClientIdentity
cid
    [ String
"consume",
      String
"--group",
      String
"<group-in>",
      String
"--group-out",
      String
"<group-out>",
      String
"-"
    ]
    (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
msgData)

-- | Send an MLS message, wait for clients to receive it, then consume it on
-- the client side. If the message is a commit, the
-- 'sendAndConsumeCommitBundle' function should be used instead.
--
-- returns response body of 'postMLSMessage'
sendAndConsumeMessage :: (HasCallStack) => MessagePackage -> App Value
sendAndConsumeMessage :: HasCallStack => MessagePackage -> App Value
sendAndConsumeMessage MessagePackage
mp = Codensity App Value -> App Value
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity App Value -> App Value)
-> Codensity App Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
  HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
MLSProtocolMLS MessagePackage
mp
  App Value -> Codensity App Value
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App Value -> Codensity App Value)
-> App Value -> Codensity App Value
forall a b. (a -> b) -> a -> b
$ HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSMessage MessagePackage
mp.sender MessagePackage
mp.message App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201

sendAndConsumeCommitBundle :: (HasCallStack) => MessagePackage -> App Value
sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value
sendAndConsumeCommitBundle = HasCallStack => MLSProtocol -> MessagePackage -> App Value
MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol MLSProtocol
MLSProtocolMLS

-- | Send an MLS commit bundle, wait for clients to receive it, consume it, and
-- update the test state accordingly.
sendAndConsumeCommitBundleWithProtocol :: (HasCallStack) => MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol :: HasCallStack => MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol MLSProtocol
protocol MessagePackage
messagePackage = Codensity App Value -> App Value
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity App Value -> App Value)
-> Codensity App Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
  HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
protocol MessagePackage
messagePackage
  App Value -> Codensity App Value
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App Value -> Codensity App Value)
-> App Value -> Codensity App Value
forall a b. (a -> b) -> a -> b
$ HasCallStack => MessagePackage -> App Value
MessagePackage -> App Value
sendCommitBundle MessagePackage
messagePackage

-- | Send an MLS commit bundle, and update the test state accordingly.
sendCommitBundle ::
  (HasCallStack) =>
  MessagePackage ->
  App Value
sendCommitBundle :: HasCallStack => MessagePackage -> App Value
sendCommitBundle MessagePackage
mp = do
  r <- HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle MessagePackage
mp.sender (MessagePackage -> ByteString
mkBundle MessagePackage
mp) App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201

  -- if the sender is a new member (i.e. it's an external commit), then
  -- process the welcome message directly
  do
    conv <- getMLSConv mp.convId
    when (Set.member mp.sender conv.newMembers) $
      traverse_ (fromWelcome mp.convId conv.ciphersuite mp.sender) mp.welcome

  -- increment epoch and add new/remove clients
  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            ( \MLSConv
conv ->
                let newUsers :: Set Value
newUsers = (ClientIdentity -> Value) -> Set ClientIdentity -> Set Value
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (.qualifiedUserId) MLSConv
conv.newMembers
                    removedUsers :: Set Value
removedUsers = (ClientIdentity -> Value) -> Set ClientIdentity -> Set Value
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (.qualifiedUserId) MLSConv
conv.membersToBeRemoved
                    users :: Set Value
users = (MLSConv
conv.memberUsers Set Value -> Set Value -> Set Value
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Value
removedUsers) Set Value -> Set Value -> Set Value
forall a. Semigroup a => a -> a -> a
<> Set Value
newUsers
                 in MLSConv
conv
                      { epoch = conv.epoch + 1,
                        members = (conv.members <> conv.newMembers) Set.\\ conv.membersToBeRemoved,
                        memberUsers = users,
                        membersToBeRemoved = mempty,
                        newMembers = mempty
                      }
            )
            mp.convId
            mls.convs
      }

  pure r

consumeWelcome :: (HasCallStack) => ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome :: HasCallStack =>
ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome ClientIdentity
cid MessagePackage
mp WebSocket
ws = do
  notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isWelcomeNotif WebSocket
ws
  event <- notif %. "payload.0"

  event %. "qualified_conversation" `shouldMatch` convIdToQidObject mp.convId
  lookupField event "subconv" `shouldMatch` mp.convId.subconvId
  event %. "from" `shouldMatch` mp.sender.user
  event %. "data" `shouldMatch` (fmap (B8.unpack . Base64.encode) mp.welcome)

  welcome <- event %. "data" & asByteString
  gs <- getClientGroupState cid
  assertBool
    "Existing clients in a conversation should not consume welcomes"
    (not $ Map.member mp.convId gs.groups)
  conv <- getMLSConv mp.convId
  fromWelcome mp.convId conv.ciphersuite cid welcome

fromWelcome :: ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome :: ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
welcome =
  App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$
    HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
      (ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
      Ciphersuite
cs
      ClientIdentity
cid
      [ String
"group",
        String
"from-welcome",
        String
"--group-out",
        String
"<group-out>",
        String
"-"
      ]
      (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome)

readWelcome :: FilePath -> IO (Maybe ByteString)
readWelcome :: String -> IO (Maybe ByteString)
readWelcome String
fp = MaybeT IO ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO ByteString -> IO (Maybe ByteString))
-> MaybeT IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
  IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist String
fp) MaybeT IO Bool -> (Bool -> MaybeT IO ()) -> MaybeT IO ()
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
  stat <- IO FileStatus -> MaybeT IO FileStatus
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> MaybeT IO FileStatus)
-> IO FileStatus -> MaybeT IO FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus String
fp
  guard $ fileSize stat > 0
  liftIO $ BS.readFile fp

mkBundle :: MessagePackage -> ByteString
mkBundle :: MessagePackage -> ByteString
mkBundle MessagePackage
mp = MessagePackage
mp.message ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> ByteString
mkGroupInfoMessage MessagePackage
mp.groupInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Maybe ByteString -> ByteString
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold MessagePackage
mp.welcome

mkGroupInfoMessage :: ByteString -> ByteString
mkGroupInfoMessage :: ByteString -> ByteString
mkGroupInfoMessage ByteString
gi = [Word8] -> ByteString
BS.pack [Word8
0x00, Word8
0x01, Word8
0x00, Word8
0x04] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
gi

spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> App ByteString
spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString
spawn CreateProcess
cp Maybe ByteString
minput = do
  (mout, ex) <- IO (Maybe ByteString, ExitCode) -> App (Maybe ByteString, ExitCode)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO (Maybe ByteString, ExitCode)
 -> App (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
-> App (Maybe ByteString, ExitCode)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess
      CreateProcess
cp
        { std_out = CreatePipe,
          std_in = if isJust minput then CreatePipe else Inherit
        }
    ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (Maybe ByteString, ExitCode))
 -> IO (Maybe ByteString, ExitCode))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
minh Maybe Handle
mouth Maybe Handle
_ ProcessHandle
ph ->
      let writeInput :: IO ()
writeInput = Maybe (ByteString, Handle)
-> ((ByteString, Handle) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((,) (ByteString -> Handle -> (ByteString, Handle))
-> Maybe ByteString -> Maybe (Handle -> (ByteString, Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
minput Maybe (Handle -> (ByteString, Handle))
-> Maybe Handle -> Maybe (ByteString, Handle)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Handle
minh) (((ByteString, Handle) -> IO ()) -> IO ())
-> ((ByteString, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ByteString
input, Handle
inh) ->
            Handle -> ByteString -> IO ()
BS.hPutStr Handle
inh ByteString
input IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
inh
          readOutput :: IO (Maybe ByteString, ExitCode)
readOutput = (,) (Maybe ByteString -> ExitCode -> (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString)
-> IO (ExitCode -> (Maybe ByteString, ExitCode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO ByteString) -> Maybe Handle -> IO (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Handle -> IO ByteString
BS.hGetContents Maybe Handle
mouth IO (ExitCode -> (Maybe ByteString, ExitCode))
-> IO ExitCode -> IO (Maybe ByteString, ExitCode)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
       in ((), (Maybe ByteString, ExitCode)) -> (Maybe ByteString, ExitCode)
forall a b. (a, b) -> b
snd (((), (Maybe ByteString, ExitCode))
 -> (Maybe ByteString, ExitCode))
-> IO ((), (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ()
-> IO (Maybe ByteString, ExitCode)
-> IO ((), (Maybe ByteString, ExitCode))
forall a b. IO a -> IO b -> IO (a, b)
concurrently IO ()
writeInput IO (Maybe ByteString, ExitCode)
readOutput
  case (mout, ex) of
    (Just ByteString
out, ExitCode
ExitSuccess) -> ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
out
    (Maybe ByteString, ExitCode)
_ -> String -> App ByteString
forall a. HasCallStack => String -> App a
assertFailure String
"Failed spawning process"

getClientGroupState :: (HasCallStack) => ClientIdentity -> App ClientGroupState
getClientGroupState :: HasCallStack => ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid = do
  mls <- App MLSState
getMLSState
  pure $ Map.findWithDefault def cid mls.clientGroupState

setClientGroupState :: (HasCallStack) => ClientIdentity -> ClientGroupState -> App ()
setClientGroupState :: HasCallStack => ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid ClientGroupState
g =
  (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
    MLSState
s {clientGroupState = Map.insert cid g (clientGroupState s)}

showMessage :: (HasCallStack) => Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage :: HasCallStack =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid ByteString
msg = do
  bs <- HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
cs ClientIdentity
cid [String
"show", String
"message", String
"-"] (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
msg)
  assertOne (Aeson.decode (BS.fromStrict bs))

readGroupState :: (HasCallStack) => ByteString -> App [(ClientIdentity, Word32)]
readGroupState :: HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
readGroupState ByteString
gs = do
  v :: Value <- String -> Maybe Value -> App Value
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"Could not decode group state" (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
gs))
  lnodes <- v %. "group" %. "public_group" %. "treesync" %. "tree" %. "leaf_nodes" & asList
  catMaybes <$$> for (zip lnodes [0 ..]) $ \(Value
el, Word32
leafNodeIndex) -> do
    Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
el String
"node" App (Maybe Value)
-> (Maybe Value -> App (Maybe (ClientIdentity, Word32)))
-> App (Maybe (ClientIdentity, Word32))
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Value
lnode -> do
        case Value
lnode of
          Value
Null -> Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClientIdentity, Word32)
forall a. Maybe a
Nothing
          Value
_ -> do
            vecb <- Value
lnode Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"credential" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"credential" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"Basic" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"identity" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"vec"
            vec <- asList vecb
            ws <- BS.pack <$> for vec (\Value
x -> forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral @Word8 Value
x)
            [uc, domain] <- pure (C8.split '@' ws)
            [uid, client] <- pure (C8.split ':' uc)
            let cid = String -> String -> String -> ClientIdentity
ClientIdentity (ByteString -> String
C8.unpack ByteString
domain) (ByteString -> String
C8.unpack ByteString
uid) (ByteString -> String
C8.unpack ByteString
client)
            pure (Just (cid, leafNodeIndex))
      Maybe Value
Nothing ->
        Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClientIdentity, Word32)
forall a. Maybe a
Nothing

createApplicationMessage ::
  (HasCallStack) =>
  ConvId ->
  ClientIdentity ->
  String ->
  App MessagePackage
createApplicationMessage :: HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
convId ClientIdentity
cid String
messageContent = do
  conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  message <-
    mlscli
      (Just convId)
      conv.ciphersuite
      cid
      ["message", "--group-in", "<group-in>", messageContent, "--group-out", "<group-out>"]
      Nothing

  pure
    MessagePackage
      { sender = cid,
        convId = convId,
        message = message,
        welcome = Nothing,
        groupInfo = Nothing
      }

leaveConv ::
  (HasCallStack) =>
  ConvId ->
  ClientIdentity ->
  App ()
leaveConv :: HasCallStack => ConvId -> ClientIdentity -> App ()
leaveConv ConvId
convId ClientIdentity
cid = do
  case ConvId
convId.subconvId of
    -- FUTUREWORK: implement leaving main conversation as well
    Maybe String
Nothing -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"Leaving conversations is not supported"
    Just String
_ -> do
      App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$ ClientIdentity -> ConvId -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> App Response
leaveSubConversation ClientIdentity
cid ConvId
convId App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
      (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
        MLSState
s
          { convs =
              Map.adjust
                ( \MLSConv
conv ->
                    MLSConv
conv
                      { members = Set.delete cid conv.members,
                        memberUsers = Set.delete cid.qualifiedUserId conv.memberUsers
                      }
                )
                convId
                s.convs
          }

getConv :: (HasCallStack) => ConvId -> ClientIdentity -> App Value
getConv :: HasCallStack => ConvId -> ClientIdentity -> App Value
getConv ConvId
convId ClientIdentity
cid = do
  resp <- case ConvId
convId.subconvId of
    Maybe String
Nothing -> ClientIdentity -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation ClientIdentity
cid (ConvId -> Value
convIdToQidObject ConvId
convId)
    Just String
sub -> ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
sub
  getJSON 200 resp

getSubConvId :: (MakesValue user, HasCallStack) => user -> ConvId -> String -> App ConvId
getSubConvId :: forall user.
(MakesValue user, HasCallStack) =>
user -> ConvId -> String -> App ConvId
getSubConvId user
user ConvId
convId String
subConvName =
  user -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation user
user ConvId
convId String
subConvName
    App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    App Value -> (Value -> App ConvId) -> App ConvId
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId

-- | Use this when the user creating the group has not yet joined the channel.
createGroupForChannel :: Ciphersuite -> ClientIdentity -> ConvId -> [Value] -> App ()
createGroupForChannel :: Ciphersuite -> ClientIdentity -> ConvId -> [Value] -> App ()
createGroupForChannel Ciphersuite
cs ClientIdentity
cid ConvId
convId [Value]
members = do
  let Just String
groupId = ConvId
convId.groupId
  memberUsers <- [Value] -> (Value -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
members Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject App [Value] -> ([Value] -> App (Set Value)) -> App (Set Value)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Value] -> App (Set Value)
forall a. (HasCallStack, MakesValue a) => a -> App (Set Value)
asSet
  modifyMLSState $ \MLSState
s ->
    let mlsConv :: MLSConv
mlsConv =
          MLSConv
            { members :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
              newMembers :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
              memberUsers :: Set Value
memberUsers = Value -> Set Value
forall a. a -> Set a
Set.singleton ClientIdentity
cid.qualifiedUserId Set Value -> Set Value -> Set Value
forall a. Semigroup a => a -> a -> a
<> Set Value
memberUsers,
              membersToBeRemoved :: Set ClientIdentity
membersToBeRemoved = Set ClientIdentity
forall a. Monoid a => a
mempty,
              String
groupId :: String
groupId :: String
groupId,
              convId :: ConvId
convId = ConvId
convId,
              epoch :: Word64
epoch = Word64
0,
              ciphersuite :: Ciphersuite
ciphersuite = Ciphersuite
cs
            }
     in MLSState
s {convs = Map.insert convId mlsConv s.convs}
  keys <- getMLSPublicKeys cid.qualifiedUserId >>= getJSON 200
  resetClientGroup cs cid groupId convId keys

-- | Adds members to a channel where the user (must be team admin) it not a member of.
-- The difference to the "normal" case is that the users are added
-- to the conversation before they are added to the MLS group.
addMembersToChannel ::
  (HasCallStack, MakesValue user, MakesValue conv) =>
  user ->
  conv ->
  AddMembers ->
  App Response
addMembersToChannel :: forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> AddMembers -> App Response
addMembersToChannel user
user conv
qcnv AddMembers
opts = do
  response <- user -> conv -> AddMembers -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> AddMembers -> App Response
addMembers user
user conv
qcnv AddMembers
opts
  convId <- objConvId qcnv
  memberUsers <- for opts.users objQidObject >>= asSet
  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            (\MLSConv
conv -> MLSConv
conv {memberUsers = conv.memberUsers <> memberUsers})
            convId
            mls.convs
      }
  pure response

removeMemberFromChannel :: (HasCallStack) => Value -> Value -> Value -> App ()
removeMemberFromChannel :: HasCallStack => Value -> Value -> Value -> App ()
removeMemberFromChannel Value
user Value
channel Value
userToBeRemoved = do
  Value -> Value -> Value -> App Response
forall remover conv removed.
(HasCallStack, MakesValue remover, MakesValue conv,
 MakesValue removed) =>
remover -> conv -> removed -> App Response
removeMember Value
user Value
channel Value
userToBeRemoved App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
204
  userId <- App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ Value
userToBeRemoved Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id"
  domain <- asString $ userToBeRemoved %. "qualified_id.domain"
  convId <- objConvId channel
  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            (\MLSConv
conv -> MLSConv
conv {members = Set.filter (\ClientIdentity
m -> ClientIdentity
m.user String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
userId Bool -> Bool -> Bool
&& ClientIdentity
m.domain String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
domain) conv.members})
            convId
            mls.convs
      }

resetMLSConversation ::
  (HasCallStack, MakesValue conv) =>
  ClientIdentity ->
  conv ->
  App Value
resetMLSConversation :: forall conv.
(HasCallStack, MakesValue conv) =>
ClientIdentity -> conv -> App Value
resetMLSConversation ClientIdentity
cid conv
conv = do
  convId <- conv -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId conv
conv
  mlsConv <- getMLSConv convId
  resetConversation cid mlsConv.groupId mlsConv.epoch >>= assertStatus 200

  conv' <- getConversation cid convId >>= getJSON 200
  groupId <- conv' %. "group_id" & asString
  groupId `shouldNotMatch` (mlsConv.groupId :: String)
  conv' %. "epoch" `shouldMatchInt` 0
  convId' <- objConvId conv'

  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.insert
            convId'
            ( mlsConv
                { groupId,
                  epoch = 0,
                  convId = convId'
                }
            )
            $ Map.delete convId mls.convs
      }

  mlsConv' <- getMLSConv convId'
  keys <- getMLSPublicKeys cid >>= getJSON 200
  resetClientGroup mlsConv'.ciphersuite cid mlsConv'.groupId convId' keys
  pure conv'