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

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
  (String
domain, String
user) <- u -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid u
u
  String
client <- c
c c -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" 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
  ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> App ClientIdentity)
-> ClientIdentity -> App ClientIdentity
forall a b. (a -> b) -> a -> b
$ ClientIdentity {$sel:domain:ClientIdentity :: String
domain = String
domain, $sel:user:ClientIdentity :: String
user = String
user, $sel:client:ClientIdentity :: String
client = String
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
  String
p <- App String
randomFileName
  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
$ String -> ByteString -> IO ()
BS.writeFile String
p ByteString
bs
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p

randomFileName :: App FilePath
randomFileName :: App String
randomFileName = do
  String
bd <- App String
getBaseDir
  (String
bd </>) (String -> String) -> (UUID -> String) -> UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
UUID.toString (UUID -> String) -> App UUID -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> App UUID
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
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
  String
groupOut <- App String
randomFileName
  let substOut :: String -> String
substOut = String -> String -> String -> String
argSubst String
"<group-out>" String
groupOut
  let scheme :: String
scheme = Ciphersuite -> String
csSignatureScheme Ciphersuite
cs

  ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid

  String -> String
substIn <- case (ConvId -> Map ConvId ByteString -> Maybe ByteString)
-> Map ConvId ByteString -> ConvId -> Maybe ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvId -> Map ConvId ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ClientGroupState
gs.groups (ConvId -> Maybe ByteString) -> Maybe ConvId -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ConvId
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
      String
fn <- ByteString -> App String
toRandomFile ByteString
groupData
      (String -> String) -> App (String -> String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> String -> String
argSubst String
"<group-in>" String
fn)
  String
store <- case String -> Map String ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
scheme ClientGroupState
gs.keystore of
    Maybe ByteString
Nothing -> do
      String
bd <- App String
getBaseDir
      IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
createDirectory (String
bd String -> String -> String
</> ClientIdentity -> String
cid2Str ClientIdentity
cid))
        App () -> (IOError -> App ()) -> App ()
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`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
      String
path <- App String
randomFileName
      String
ctype <- CredentialType -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make ClientGroupState
gs.credType 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
      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 =>
String -> [String] -> Maybe ByteString -> App ByteString
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
path [String
"init", String
"--ciphersuite", Ciphersuite
cs.code, String
"-t", String
ctype, ClientIdentity -> String
cid2Str ClientIdentity
cid] Maybe ByteString
forall a. Maybe a
Nothing
      String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
path
    Just ByteString
s -> ByteString -> App String
toRandomFile ByteString
s

  let args' :: [String]
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
  [String] -> (String -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
args' ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \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)

  ByteString
out <- HasCallStack =>
String -> [String] -> Maybe ByteString -> App ByteString
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
store [String]
args' Maybe ByteString
mbstdin
  ClientGroupState -> ClientGroupState
setGroup <- do
    Bool
groupOutWritten <- IO Bool -> App Bool
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> App Bool) -> IO Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
groupOut
    case (Bool
groupOutWritten, Maybe ConvId
mConvId) of
      (Bool
True, Just ConvId
convId) -> do
        ByteString
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)
        (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientGroupState -> ClientGroupState)
 -> App (ClientGroupState -> ClientGroupState))
-> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a b. (a -> b) -> a -> b
$ \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
  ClientGroupState -> ClientGroupState
setStore <- do
    ByteString
storeData <- 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
store)
    (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientGroupState -> ClientGroupState)
 -> App (ClientGroupState -> ClientGroupState))
-> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a b. (a -> b) -> a -> b
$ \ClientGroupState
x -> ClientGroupState
x {keystore = Map.insert scheme storeData x.keystore}

  HasCallStack => ClientIdentity -> ClientGroupState -> App ()
ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid (ClientGroupState -> ClientGroupState
setGroup (ClientGroupState -> ClientGroupState
setStore ClientGroupState
gs))

  ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
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
  }

instance Default InitMLSClient where
  def :: InitMLSClient
def = InitMLSClient {$sel:credType:InitMLSClient :: CredentialType
credType = CredentialType
BasicCredentialType, $sel:clientArgs:InitMLSClient :: AddClient
clientArgs = AddClient
forall a. Default a => a
def}

-- | Create new mls client and register with backend.
createMLSClient :: (MakesValue u, HasCallStack) => Ciphersuite -> InitMLSClient -> u -> App ClientIdentity
createMLSClient :: forall u.
(MakesValue u, HasCallStack) =>
Ciphersuite -> InitMLSClient -> u -> App ClientIdentity
createMLSClient Ciphersuite
ciphersuite = [Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
[Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites [Ciphersuite
ciphersuite]

-- | Create new mls client and register with backend.
createMLSClientWithCiphersuites :: (MakesValue u, HasCallStack) => [Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites :: forall u.
(MakesValue u, HasCallStack) =>
[Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites [Ciphersuite]
ciphersuites InitMLSClient
opts u
u = do
  ClientIdentity
cid <- u -> AddClient -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
u -> AddClient -> App ClientIdentity
createWireClient u
u InitMLSClient
opts.clientArgs
  HasCallStack => ClientIdentity -> ClientGroupState -> App ()
ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid ClientGroupState
forall a. Default a => a
def {credType = opts.credType}

  -- set public key
  [(Ciphersuite, ByteString)]
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 [Ciphersuite]
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
  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse
    ( HasCallStack => ClientIdentity -> UpdateClient -> App Response
ClientIdentity -> UpdateClient -> App Response
updateClient
        ClientIdentity
cid
        UpdateClient
forall a. Default a => a
def
          { mlsPublicKeys =
              Just
                ( object
                    [ csSignatureScheme ciphersuite .= T.decodeUtf8 (Base64.encode pkey)
                      | (ciphersuite, pkey) <- suitePKeys
                    ]
                )
          }
    )
    ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientIdentity
cid

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

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

  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ref

generateKeyPackage :: (HasCallStack) => ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage :: HasCallStack =>
ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid Ciphersuite
suite = do
  ByteString
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
  String
ref <- ByteString -> String
B8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> String) -> App ByteString -> App String
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
suite ClientIdentity
cid [String
"key-package", String
"ref", String
"-"] (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
kp)
  String
fp <- HasCallStack => ClientIdentity -> String -> App String
ClientIdentity -> String -> App String
keyPackageFile ClientIdentity
cid String
ref
  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
$ String -> ByteString -> IO ()
BS.writeFile String
fp ByteString
kp
  (ByteString, String) -> App (ByteString, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
kp, String
ref)

-- | Create conversation and corresponding group.
createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup :: HasCallStack => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup Ciphersuite
cs ClientIdentity
cid = do
  Value
conv <- ClientIdentity -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation ClientIdentity
cid CreateConv
defMLS 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
convId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
conv
  Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId
  ConvId -> App ConvId
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConvId
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
  Value
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
convId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
conv
  String
groupId <- Value
conv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" 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
  Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId
  (String, Value) -> App (String, Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
groupId, Value
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
            { $sel:members:MLSConv :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
              $sel:newMembers:MLSConv :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
              String
groupId :: String
$sel:groupId:MLSConv :: String
groupId,
              $sel:convId:MLSConv :: ConvId
convId = ConvId
convId,
              $sel:epoch:MLSConv :: Word64
epoch = Word64
0,
              $sel:ciphersuite:MLSConv :: Ciphersuite
ciphersuite = Ciphersuite
cs
            }
     in MLSState
s {convs = Map.insert convId mlsConv s.convs}
  Value
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
  Ciphersuite
-> ClientIdentity -> String -> ConvId -> Value -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
groupId ConvId
convId Value
keys

createSubConv :: (HasCallStack) => Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv :: HasCallStack =>
Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv Ciphersuite
cs ConvId
convId ClientIdentity
cid String
subId = do
  Value
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
  ConvId
subConvId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
sub
  Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
subConvId
  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 => ConvId -> ClientIdentity -> App MessagePackage
ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
subConvId ClientIdentity
cid App MessagePackage -> (MessagePackage -> 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 => MessagePackage -> App Value
MessagePackage -> App Value
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
  Value
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
  ConvId
subConvId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
sub
  Ciphersuite -> ClientIdentity -> Value -> keys -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid Value
sub keys
keys
  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 => ConvId -> ClientIdentity -> App MessagePackage
ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
subConvId ClientIdentity
cid App MessagePackage -> (MessagePackage -> 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 => MessagePackage -> App Value
MessagePackage -> App Value
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
convId <- conv -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId conv
conv
  String
groupId <- conv
conv conv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" 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
  (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
    let newMLSConv :: MLSConv
newMLSConv =
          MLSConv
            { $sel:members:MLSConv :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
              $sel:newMembers:MLSConv :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
              $sel:groupId:MLSConv :: String
groupId = String
groupId,
              $sel:convId:MLSConv :: ConvId
convId = ConvId
convId,
              $sel:epoch:MLSConv :: Word64
epoch = Word64
0,
              $sel:ciphersuite:MLSConv :: Ciphersuite
ciphersuite = Ciphersuite
cs
            }
        resetConv :: MLSConv -> r -> MLSConv
resetConv MLSConv
old r
new =
          MLSConv
old
            { groupId = new.groupId,
              convId = new.convId,
              members = new.members,
              newMembers = new.newMembers,
              epoch = new.epoch
            }
     in MLSState
s {convs = Map.insertWith resetConv convId newMLSConv s.convs}

  Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
groupId ConvId
convId keys
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
  ByteString
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)
  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
"create",
        String
"--removal-key",
        String
"-",
        String
"--group-out",
        String
"<group-out>",
        String
"--ciphersuite",
        Ciphersuite
cs.code,
        String
gid
      ]
      (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
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
  String
bd <- App String
getBaseDir
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ String
bd String -> String -> String
</> ClientIdentity -> String
cid2Str ClientIdentity
cid String -> String -> String
</> String
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
        String
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
        String
u <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"user" 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
        String
c <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"client" 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
        ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> App ClientIdentity)
-> ClientIdentity -> App ClientIdentity
forall a b. (a -> b) -> a -> b
$ ClientIdentity {$sel:domain:ClientIdentity :: String
domain = String
d, $sel:user:ClientIdentity :: String
user = String
u, $sel:client:ClientIdentity :: String
client = String
c}

  [Value]
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
  [Value]
-> (Value -> App (ClientIdentity, ByteString))
-> App [(ClientIdentity, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
bundleEntries ((Value -> App (ClientIdentity, ByteString))
 -> App [(ClientIdentity, ByteString)])
-> (Value -> App (ClientIdentity, ByteString))
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Value
be -> do
    String
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
    ByteString
kp <- [ByteString] -> App ByteString
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne ([ByteString] -> App ByteString)
-> (String -> [ByteString]) -> String -> App ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String ByteString -> [ByteString]
forall a. Either String a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Either String ByteString -> [ByteString])
-> (String -> Either String ByteString) -> String -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> (String -> ByteString) -> String -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack (String -> App ByteString) -> String -> App ByteString
forall a b. (a -> b) -> a -> b
$ String
kp64
    ClientIdentity
cid <- Value -> App ClientIdentity
forall {a}. MakesValue a => a -> App ClientIdentity
entryIdentity Value
be
    (ClientIdentity, ByteString) -> App (ClientIdentity, ByteString)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity
cid, ByteString
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
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  [(ClientIdentity, ByteString)]
kps <- ([[(ClientIdentity, ByteString)]]
 -> [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(ClientIdentity, ByteString)]] -> [(ClientIdentity, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (App [[(ClientIdentity, ByteString)]]
 -> App [(ClientIdentity, ByteString)])
-> ((Value -> App [(ClientIdentity, ByteString)])
    -> App [[(ClientIdentity, ByteString)]])
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [(ClientIdentity, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value]
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
users ((Value -> App [(ClientIdentity, ByteString)])
 -> App [(ClientIdentity, ByteString)])
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Value
user -> do
    Value
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
    HasCallStack => Value -> App [(ClientIdentity, ByteString)]
Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages Value
bundle
  HasCallStack =>
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid ConvId
convId [(ClientIdentity, ByteString)]
kps

withTempKeyPackageFile :: ByteString -> ContT a App FilePath
withTempKeyPackageFile :: forall a. ByteString -> ContT a App String
withTempKeyPackageFile ByteString
bs = do
  String
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
  ((String -> App a) -> App a) -> ContT a App String
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((String -> App a) -> App a) -> ContT a App String)
-> ((String -> App a) -> App a) -> ContT a App String
forall a b. (a -> b) -> a -> b
$ \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
  String
bd <- App String
getBaseDir
  String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
  String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"
  Just MLSConv
conv <- 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

  ByteString
commit <- ContT ByteString App [String]
-> ([String] -> App ByteString) -> App ByteString
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (((ClientIdentity, ByteString) -> ContT ByteString App String)
-> [(ClientIdentity, ByteString)] -> ContT ByteString App [String]
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) -> [a] -> f [b]
traverse (ByteString -> ContT ByteString App String
forall a. ByteString -> ContT a App String
withTempKeyPackageFile (ByteString -> ContT ByteString App String)
-> ((ClientIdentity, ByteString) -> ByteString)
-> (ClientIdentity, ByteString)
-> ContT ByteString App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) [(ClientIdentity, ByteString)]
clientsAndKeyPackages) (([String] -> App ByteString) -> App ByteString)
-> ([String] -> App ByteString) -> App ByteString
forall a b. (a -> b) -> a -> b
$ \[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

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

  ByteString
welcome <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
welcomeFile
  ByteString
gi <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile
  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessagePackage -> App MessagePackage)
-> MessagePackage -> App MessagePackage
forall a b. (a -> b) -> a -> b
$
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
commit,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi
      }

createRemoveCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit :: HasCallStack =>
ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit ClientIdentity
cid ConvId
convId [ClientIdentity]
targets = do
  String
bd <- App String
getBaseDir
  String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
  String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"

  Map ClientIdentity Word32
groupStateMap <- do
    ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid
    ByteString
groupData <- String -> Maybe ByteString -> App ByteString
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"Group state not initialised" (ConvId -> Map ConvId ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConvId
convId ClientGroupState
gs.groups)
    [(ClientIdentity, Word32)] -> Map ClientIdentity Word32
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ClientIdentity, Word32)] -> Map ClientIdentity Word32)
-> App [(ClientIdentity, Word32)]
-> App (Map ClientIdentity Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
ByteString -> App [(ClientIdentity, Word32)]
readGroupState ByteString
groupData
  let indices :: [Word32]
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

  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId

  ByteString
commit <-
    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
"remove",
          String
"--group",
          String
"<group-in>",
          String
"--group-out",
          String
"<group-out>",
          String
"--welcome-out",
          String
welcomeFile,
          String
"--group-info-out",
          String
giFile
        ]
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (Word32 -> String) -> [Word32] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> String
forall a. Show a => a -> String
show [Word32]
indices
      )
      Maybe ByteString
forall a. Maybe a
Nothing

  ByteString
welcome <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
welcomeFile
  ByteString
gi <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile

  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
commit,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi
      }

createAddProposals :: (HasCallStack) => ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals :: HasCallStack =>
ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals ConvId
convId ClientIdentity
cid [Value]
users = do
  Just MLSConv
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
  [Value]
bundles <- [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]
users ((Value -> App Value) -> App [Value])
-> (Value -> App Value) -> App [Value]
forall a b. (a -> b) -> a -> b
$ (Ciphersuite -> ClientIdentity -> Value -> App Response
forall u v.
(HasCallStack, MakesValue u, MakesValue v) =>
Ciphersuite -> u -> v -> App Response
claimKeyPackages MLSConv
mls.ciphersuite ClientIdentity
cid (Value -> App Response)
-> (Response -> App Value) -> Value -> App Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200)
  [(ClientIdentity, ByteString)]
kps <- [[(ClientIdentity, ByteString)]] -> [(ClientIdentity, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(ClientIdentity, ByteString)]]
 -> [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
-> App [(ClientIdentity, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> App [(ClientIdentity, ByteString)])
-> [Value] -> App [[(ClientIdentity, 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) -> [a] -> f [b]
traverse HasCallStack => Value -> App [(ClientIdentity, ByteString)]
Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages [Value]
bundles
  ((ClientIdentity, ByteString) -> App MessagePackage)
-> [(ClientIdentity, ByteString)] -> App [MessagePackage]
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) -> [a] -> f [b]
traverse (ConvId
-> ClientIdentity
-> (ClientIdentity, ByteString)
-> App MessagePackage
createAddProposalWithKeyPackage ConvId
convId ClientIdentity
cid) [(ClientIdentity, ByteString)]
kps

createReInitProposal :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal ConvId
convId ClientIdentity
cid = do
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  ByteString
prop <-
    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
"re-init"]
      Maybe ByteString
forall a. Maybe a
Nothing
  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
prop,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
Nothing
      }

createAddProposalWithKeyPackage ::
  ConvId ->
  ClientIdentity ->
  (ClientIdentity, ByteString) ->
  App MessagePackage
createAddProposalWithKeyPackage :: ConvId
-> ClientIdentity
-> (ClientIdentity, ByteString)
-> App MessagePackage
createAddProposalWithKeyPackage ConvId
convId ClientIdentity
cid (ClientIdentity
_, ByteString
kp) = do
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  ByteString
prop <- ContT ByteString App String
-> (String -> App ByteString) -> App ByteString
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (ByteString -> ContT ByteString App String
forall a. ByteString -> ContT a App String
withTempKeyPackageFile ByteString
kp) ((String -> App ByteString) -> App ByteString)
-> (String -> App ByteString) -> App ByteString
forall a b. (a -> b) -> a -> b
$ \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
  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
prop,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
Nothing
      }

createPendingProposalCommit :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
convId ClientIdentity
cid = do
  String
bd <- App String
getBaseDir
  String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
  String
pgsFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"pgs"
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  ByteString
commit <-
    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
"commit",
        String
"--group",
        String
"<group-in>",
        String
"--group-out",
        String
"<group-out>",
        String
"--welcome-out",
        String
welcomeFile,
        String
"--group-info-out",
        String
pgsFile
      ]
      Maybe ByteString
forall a. Maybe a
Nothing

  Maybe ByteString
welcome <- IO (Maybe ByteString) -> App (Maybe ByteString)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> App (Maybe ByteString))
-> IO (Maybe ByteString) -> App (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe ByteString)
readWelcome String
welcomeFile
  ByteString
pgs <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
pgsFile
  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
commit,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
welcome,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
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
  String
bd <- App String
getBaseDir
  String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"
  ByteString
gi <- case Maybe ByteString
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
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  ByteString
commit <-
    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
"external-commit",
        String
"--group-info-in",
        String
"-",
        String
"--group-info-out",
        String
giFile,
        String
"--group-out",
        String
"<group-out>"
      ]
      (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi)

  (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \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.
      }

  ByteString
newPgs <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile
  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessagePackage -> App MessagePackage)
-> MessagePackage -> App MessagePackage
forall a b. (a -> b) -> a -> b
$
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
commit,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
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
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
  -- clients that should receive the message itself
  let oldClients :: Set ClientIdentity
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 :: Set ClientIdentity
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, MLSNotificationTag)]
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 :: Set String
newUsers =
        String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender.user (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$
          Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
            ((ClientIdentity -> String) -> Set ClientIdentity -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (.user) Set ClientIdentity
newClients)
            ((ClientIdentity -> String) -> Set ClientIdentity -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (.user) Set ClientIdentity
oldClients)
  [ClientIdentity] -> ([WebSocket] -> App b) -> App b
forall a w.
(HasCallStack, ToWSConnect w) =>
[w] -> ([WebSocket] -> App a) -> App a
withWebSockets (((ClientIdentity, MLSNotificationTag) -> ClientIdentity)
-> [(ClientIdentity, MLSNotificationTag)] -> [ClientIdentity]
forall a b. (a -> b) -> [a] -> [b]
map (ClientIdentity, MLSNotificationTag) -> ClientIdentity
forall a b. (a, b) -> a
fst [(ClientIdentity, MLSNotificationTag)]
clients) (([WebSocket] -> App b) -> App b)
-> ([WebSocket] -> App b) -> App b
forall a b. (a -> b) -> a -> b
$ \[WebSocket]
wss -> do
    b
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.
    Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MLSProtocol
mlsProtocol MLSProtocol -> MLSProtocol -> Bool
forall a. Eq a => a -> a -> Bool
== MLSProtocol
MLSProtocolMLS) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
      (WebSocket -> App Value) -> Map String WebSocket -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        (HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (\Value
n -> Value -> App Bool
forall a. MakesValue a => a -> App Bool
isMemberJoinNotif Value
n))
        ( (Map String WebSocket -> Set String -> Map String WebSocket)
-> Set String -> Map String WebSocket -> Map String WebSocket
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map String WebSocket -> Set String -> Map String WebSocket
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Set String
newUsers
            (Map String WebSocket -> Map String WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
    -> Map String WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ClientIdentity, MLSNotificationTag) -> String)
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
-> Map String WebSocket
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys ((.user) (ClientIdentity -> String)
-> ((ClientIdentity, MLSNotificationTag) -> ClientIdentity)
-> (ClientIdentity, MLSNotificationTag)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity, MLSNotificationTag) -> ClientIdentity
forall a b. (a, b) -> a
fst)
            (Map (ClientIdentity, MLSNotificationTag) WebSocket
 -> Map String WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
    -> Map (ClientIdentity, MLSNotificationTag) WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            ([((ClientIdentity, MLSNotificationTag), WebSocket)]
 -> Map (ClientIdentity, MLSNotificationTag) WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
    -> [((ClientIdentity, MLSNotificationTag), WebSocket)])
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
            ([((ClientIdentity, MLSNotificationTag), WebSocket)]
 -> Map String WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall a b. (a -> b) -> a -> b
$ [(ClientIdentity, MLSNotificationTag)]
-> [WebSocket]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ClientIdentity, MLSNotificationTag)]
clients [WebSocket]
wss
        )

    -- at this point we know that every new user has been added to the
    -- conversation
    [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> (((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
-> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([(ClientIdentity, MLSNotificationTag)]
-> [WebSocket]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ClientIdentity, MLSNotificationTag)]
clients [WebSocket]
wss) ((((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
 -> App ())
-> (((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \((ClientIdentity
cid, MLSNotificationTag
t), WebSocket
ws) -> case MLSNotificationTag
t of
      MLSNotificationTag
MLSNotificationMessageTag -> 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
    b -> App b
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
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
  Value
notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
p WebSocket
ws
  Value
event <- Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0"

  Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId -> Value
convIdToQidObject ConvId
convId
  Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
event String
"subconv" App (Maybe Value) -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId
convId.subconvId

  Maybe MessagePackage -> (MessagePackage -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MessagePackage
mmp ((MessagePackage -> App ()) -> App ())
-> (MessagePackage -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \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))

  ByteString
msgData <- Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString
  ByteString
_ <- HasCallStack =>
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
msgData
  HasCallStack =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid ByteString
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. 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
      Bool
isRelevantNotif <- Value -> App Bool
forall a. MakesValue a => a -> App Bool
isNewMLSMessageNotif Value
n App Bool -> App Bool -> App Bool
&&~ ConvId -> Value -> App Bool
forall a. (MakesValue a, HasCallStack) => ConvId -> a -> App Bool
isNotifConvId MessagePackage
mp.convId Value
n
      if Bool
isRelevantNotif
        then do
          Value
msg <- Value
n Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString App ByteString -> (ByteString -> 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 =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid
          Maybe Value
sender <- Value
msg Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
`lookupField` String
"message.content.sender" App (Maybe Value)
-> (AssertionFailure -> App (Maybe Value)) -> App (Maybe Value)
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`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 :: Value
backendSender = [Pair] -> Value
object [String
"External" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Scientific -> Value
Number Scientific
0]
          Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ Maybe Value
sender Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value -> Maybe Value
forall a. a -> Maybe a
Just Value
backendSender
        else Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
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
mp = do
  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
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
$ do
      Value
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
        MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
        Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientIdentity -> Set ClientIdentity -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MessagePackage
mp.sender MLSConv
conv.newMembers) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
          (ByteString -> App ()) -> Maybe ByteString -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome MessagePackage
mp.convId MLSConv
conv.ciphersuite MessagePackage
mp.sender) MessagePackage
mp.welcome

      -- increment epoch and add new clients
      (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls ->
        MLSState
mls
          { convs =
              Map.adjust
                ( \MLSConv
conv ->
                    MLSConv
conv
                      { epoch = conv.epoch + 1,
                        members = conv.members <> conv.newMembers,
                        newMembers = mempty
                      }
                )
                mp.convId
                mls.convs
          }

      Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
r

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

  Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId -> Value
convIdToQidObject MessagePackage
mp.convId
  Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
event String
"subconv" App (Maybe Value) -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` MessagePackage
mp.convId.subconvId
  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 -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ((ByteString -> String) -> Maybe ByteString -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
B8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode) MessagePackage
mp.welcome)

  ByteString
welcome <- Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString
  ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid
  HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool
    String
"Existing clients in a conversation should not consume welcomes"
    (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConvId -> Map ConvId ByteString -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member MessagePackage
mp.convId ClientGroupState
gs.groups)
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
  ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome MessagePackage
mp.convId MLSConv
conv.ciphersuite ClientIdentity
cid ByteString
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
  FileStatus
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
  Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
stat FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
> FileOffset
0
  IO ByteString -> MaybeT IO ByteString
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> MaybeT IO ByteString)
-> IO ByteString -> MaybeT IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
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
  (Maybe ByteString
mout, ExitCode
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 (Maybe ByteString
mout, ExitCode
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
  MLSState
mls <- App MLSState
getMLSState
  ClientGroupState -> App ClientGroupState
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientGroupState -> App ClientGroupState)
-> ClientGroupState -> App ClientGroupState
forall a b. (a -> b) -> a -> b
$ ClientGroupState
-> ClientIdentity
-> Map ClientIdentity ClientGroupState
-> ClientGroupState
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ClientGroupState
forall a. Default a => a
def ClientIdentity
cid MLSState
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
  ByteString
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)
  Maybe Value -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
bs))

readGroupState :: (HasCallStack) => ByteString -> App [(ClientIdentity, Word32)]
readGroupState :: HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
readGroupState ByteString
gs = do
  Value
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))
  [Value]
lnodes <- Value
v Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_group" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"treesync" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"tree" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"leaf_nodes" 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
  [Maybe (ClientIdentity, Word32)] -> [(ClientIdentity, Word32)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ClientIdentity, Word32)] -> [(ClientIdentity, Word32)])
-> (((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
    -> App [Maybe (ClientIdentity, Word32)])
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [(ClientIdentity, Word32)]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> [(Value, Word32)]
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [Maybe (ClientIdentity, Word32)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Value] -> [Word32] -> [(Value, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Value]
lnodes [Word32
0 ..]) (((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
 -> App [(ClientIdentity, Word32)])
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [(ClientIdentity, Word32)]
forall a b. (a -> b) -> a -> b
$ \(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
            Value
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"
            [Value]
vec <- Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList Value
vecb
            ByteString
ws <- [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> App [Word8] -> App ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> (Value -> App Word8) -> App [Word8]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
vec (\Value
x -> forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral @Word8 Value
x)
            [ByteString
uc, ByteString
domain] <- [ByteString] -> App [ByteString]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString -> [ByteString]
C8.split Char
'@' ByteString
ws)
            [ByteString
uid, ByteString
client] <- [ByteString] -> App [ByteString]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString -> [ByteString]
C8.split Char
':' ByteString
uc)
            let cid :: ClientIdentity
cid = String -> String -> String -> ClientIdentity
ClientIdentity (ByteString -> String
C8.unpack ByteString
domain) (ByteString -> String
C8.unpack ByteString
uid) (ByteString -> String
C8.unpack ByteString
client)
            Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientIdentity, Word32) -> Maybe (ClientIdentity, Word32)
forall a. a -> Maybe a
Just (ClientIdentity
cid, Word32
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
  MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
  ByteString
message <-
    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
"message", String
"--group-in", String
"<group-in>", String
messageContent, String
"--group-out", String
"<group-out>"]
      Maybe ByteString
forall a. Maybe a
Nothing

  MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    MessagePackage
      { $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
        $sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
        $sel:message:MessagePackage :: ByteString
message = ByteString
message,
        $sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
        $sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
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}) convId s.convs
          }

getConv :: (HasCallStack) => ConvId -> ClientIdentity -> App Value
getConv :: HasCallStack => ConvId -> ClientIdentity -> App Value
getConv ConvId
convId ClientIdentity
cid = do
  Response
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
  HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
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