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

module MLS.Util where

import API.Brig
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 A
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.Temp
import System.Posix.Files
import System.Process
import Testlib.Assertions
import Testlib.HTTP
import Testlib.JSON
import Testlib.Prelude

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 -> ByteString
message :: ByteString,
    MessagePackage -> Maybe ByteString
welcome :: Maybe ByteString,
    MessagePackage -> Maybe ByteString
groupInfo :: Maybe ByteString
  }

getConv :: App Value
getConv :: App Value
getConv = do
  MLSState
mls <- App MLSState
getMLSState
  case MLSState
mls.convId of
    Maybe Value
Nothing -> String -> App Value
forall a. HasCallStack => String -> App a
assertFailure String
"Uninitialised test conversation"
    Just Value
convId -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
convId

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) => ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli :: HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli 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
  Ciphersuite
cs <- (.ciphersuite) (MLSState -> Ciphersuite) -> App MLSState -> App Ciphersuite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
  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 ClientGroupState
gs.group 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 (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirectory (String
bd String -> String -> String
</> ClientIdentity -> String
cid2Str ClientIdentity
cid)

      -- 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
    if Bool
groupOutWritten
      then 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 {group = Just groupData}
      else (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 -> App ClientIdentity
createWireClient :: forall u. (MakesValue u, HasCallStack) => u -> App ClientIdentity
createWireClient u
u = do
  u -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient u
u AddClient
forall a. Default a => a
def
    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}

instance Default InitMLSClient where
  def :: InitMLSClient
def = InitMLSClient {$sel:credType:InitMLSClient :: CredentialType
credType = CredentialType
BasicCredentialType}

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

  -- set public key
  ByteString
pkey <- HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli ClientIdentity
cid [String
"public-key"] Maybe ByteString
forall a. Maybe a
Nothing
  Ciphersuite
ciphersuite <- (.ciphersuite) (MLSState -> Ciphersuite) -> App MLSState -> App Ciphersuite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
  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)])
          }
    )
    ((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) => ClientIdentity -> App String
uploadNewKeyPackage :: HasCallStack => ClientIdentity -> App String
uploadNewKeyPackage ClientIdentity
cid = do
  (ByteString
kp, String
ref) <- HasCallStack => ClientIdentity -> App (ByteString, String)
ClientIdentity -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid

  -- 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 -> App (ByteString, String)
generateKeyPackage :: HasCallStack => ClientIdentity -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid = do
  Ciphersuite
suite <- (.ciphersuite) (MLSState -> Ciphersuite) -> App MLSState -> App Ciphersuite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
  ByteString
kp <- HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli 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 =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli 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) => ClientIdentity -> App (String, Value)
createNewGroup :: HasCallStack => ClientIdentity -> App (String, Value)
createNewGroup 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
  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
  Value
convId <- Value
conv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
  ClientIdentity -> Value -> App ()
forall conv. MakesValue conv => ClientIdentity -> conv -> App ()
createGroup ClientIdentity
cid Value
conv
  (String, Value) -> App (String, Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
groupId, Value
convId)

-- | Retrieve self conversation and create the corresponding group.
createSelfGroup :: (HasCallStack) => ClientIdentity -> App (String, Value)
createSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value)
createSelfGroup 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
  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
  ClientIdentity -> Value -> App ()
forall conv. MakesValue conv => ClientIdentity -> conv -> App ()
createGroup ClientIdentity
cid Value
conv
  (String, Value) -> App (String, Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
groupId, Value
conv)

createGroup :: (MakesValue conv) => ClientIdentity -> conv -> App ()
createGroup :: forall conv. MakesValue conv => ClientIdentity -> conv -> App ()
createGroup ClientIdentity
cid conv
conv = do
  MLSState
mls <- App MLSState
getMLSState
  case MLSState
mls.groupId of
    Just String
_ -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"only one group can be created"
    Maybe String
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ClientIdentity -> conv -> App ()
forall conv.
(HasCallStack, MakesValue conv) =>
ClientIdentity -> conv -> App ()
resetGroup ClientIdentity
cid conv
conv

createSubConv :: (HasCallStack) => ClientIdentity -> String -> App ()
createSubConv :: HasCallStack => ClientIdentity -> String -> App ()
createSubConv ClientIdentity
cid String
subId = do
  MLSState
mls <- App MLSState
getMLSState
  Value
sub <- ClientIdentity -> Maybe Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
getSubConversation ClientIdentity
cid MLSState
mls.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
  ClientIdentity -> Value -> App ()
forall conv.
(HasCallStack, MakesValue conv) =>
ClientIdentity -> conv -> App ()
resetGroup ClientIdentity
cid Value
sub
  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 => ClientIdentity -> App MessagePackage
ClientIdentity -> App MessagePackage
createPendingProposalCommit 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) => ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv :: forall keys.
(HasCallStack, MakesValue keys) =>
ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv ClientIdentity
cid String
subId keys
keys = do
  MLSState
mls <- App MLSState
getMLSState
  Value
sub <- ClientIdentity -> Maybe Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
getSubConversation ClientIdentity
cid MLSState
mls.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
  ClientIdentity -> Value -> keys -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric 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 => ClientIdentity -> App MessagePackage
ClientIdentity -> App MessagePackage
createPendingProposalCommit 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

resetGroup :: (HasCallStack, MakesValue conv) => ClientIdentity -> conv -> App ()
resetGroup :: forall conv.
(HasCallStack, MakesValue conv) =>
ClientIdentity -> conv -> App ()
resetGroup ClientIdentity
cid conv
conv = do
  Value
convId <- conv -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objSubConvObject 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 ->
    MLSState
s
      { groupId = Just groupId,
        convId = Just convId,
        members = Set.singleton cid,
        epoch = 0,
        newMembers = mempty
      }
  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
  ClientIdentity -> String -> Value -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
ClientIdentity -> String -> keys -> App ()
resetClientGroup ClientIdentity
cid String
groupId Value
keys

resetOne2OneGroup :: (HasCallStack, MakesValue one2OneConv) => ClientIdentity -> one2OneConv -> App ()
resetOne2OneGroup :: forall conv.
(HasCallStack, MakesValue conv) =>
ClientIdentity -> conv -> App ()
resetOne2OneGroup ClientIdentity
cid one2OneConv
one2OneConv =
  ClientIdentity -> App Value -> App Value -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric 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) => ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric :: forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric ClientIdentity
cid conv
conv keys
keys = do
  Value
convId <- conv -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objSubConvObject 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 ->
    MLSState
s
      { groupId = Just groupId,
        convId = Just convId,
        members = Set.singleton cid,
        epoch = 0,
        newMembers = mempty
      }
  ClientIdentity -> String -> keys -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
ClientIdentity -> String -> keys -> App ()
resetClientGroup ClientIdentity
cid String
groupId keys
keys

resetClientGroup :: (HasCallStack, MakesValue keys) => ClientIdentity -> String -> keys -> App ()
resetClientGroup :: forall keys.
(HasCallStack, MakesValue keys) =>
ClientIdentity -> String -> keys -> App ()
resetClientGroup ClientIdentity
cid String
gid keys
keys = do
  MLSState
mls <- App MLSState
getMLSState
  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 MLSState
mls.ciphersuite)
  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 =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      ClientIdentity
cid
      [ String
"group",
        String
"create",
        String
"--removal-key",
        String
"-",
        String
"--group-out",
        String
"<group-out>",
        String
"--ciphersuite",
        MLSState
mls.ciphersuite.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 -> [Value] -> App MessagePackage
createAddCommit :: HasCallStack => ClientIdentity -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
cid [Value]
users = do
  MLSState
mls <- App MLSState
getMLSState
  [(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 MLSState
mls.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
-> [(ClientIdentity, ByteString)] -> App MessagePackage
ClientIdentity
-> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid [(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 ->
  [(ClientIdentity, ByteString)] ->
  App MessagePackage
createAddCommitWithKeyPackages :: HasCallStack =>
ClientIdentity
-> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid [(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"

  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 =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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
      { newMembers = Set.fromList (map fst clientsAndKeyPackages)
      }

  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: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 -> [ClientIdentity] -> App MessagePackage
createRemoveCommit :: HasCallStack =>
ClientIdentity -> [ClientIdentity] -> App MessagePackage
createRemoveCommit ClientIdentity
cid [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" ClientGroupState
gs.group
    [(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

  ByteString
commit <-
    HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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: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) => ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals :: HasCallStack => ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals ClientIdentity
cid [Value]
users = do
  MLSState
mls <- 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 MLSState
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 (ClientIdentity
-> (ClientIdentity, ByteString) -> App MessagePackage
createAddProposalWithKeyPackage ClientIdentity
cid) [(ClientIdentity, ByteString)]
kps

createReInitProposal :: (HasCallStack) => ClientIdentity -> App MessagePackage
createReInitProposal :: HasCallStack => ClientIdentity -> App MessagePackage
createReInitProposal ClientIdentity
cid = do
  ByteString
prop <-
    HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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: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 ::
  ClientIdentity ->
  (ClientIdentity, ByteString) ->
  App MessagePackage
createAddProposalWithKeyPackage :: ClientIdentity
-> (ClientIdentity, ByteString) -> App MessagePackage
createAddProposalWithKeyPackage ClientIdentity
cid (ClientIdentity
_, ByteString
kp) = do
  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 =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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: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) => ClientIdentity -> App MessagePackage
createPendingProposalCommit :: HasCallStack => ClientIdentity -> App MessagePackage
createPendingProposalCommit 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"
  ByteString
commit <-
    HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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: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) =>
  ClientIdentity ->
  Maybe ByteString ->
  App MessagePackage
createExternalCommit :: HasCallStack =>
ClientIdentity -> Maybe ByteString -> App MessagePackage
createExternalCommit 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"
  Value
conv <- App Value
getConv
  ByteString
gi <- case Maybe ByteString
mgi of
    Maybe ByteString
Nothing -> ClientIdentity -> Value -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> App Response
getGroupInfo ClientIdentity
cid Value
conv 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
  ByteString
commit <-
    HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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
      { newMembers = Set.singleton cid
      -- 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: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)

-- | Extract a conversation ID (including an optional subconversation) from an
-- event object.
eventSubConv :: (HasCallStack) => (MakesValue event) => event -> App Value
eventSubConv :: forall a. (HasCallStack, MakesValue a) => a -> App Value
eventSubConv event
event = do
  Maybe Value
sub <- event -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField event
event String
"subconv"
  Value
conv <- event
event event -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation"
  Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objSubConvObject (Value -> App Value) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ String
"parent_qualified_id" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
conv,
        String
"subconv_id" String -> Maybe Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Maybe Value
sub
      ]

consumingMessages :: (HasCallStack) => MessagePackage -> Codensity App ()
consumingMessages :: HasCallStack => MessagePackage -> Codensity App ()
consumingMessages 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
  MLSState
mls <- App MLSState
getMLSState
  -- 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 MLSState
mls.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 MLSState
mls.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
    Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MLSState
mls.protocol 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 -> App Bool
forall a. MakesValue a => a -> App Bool
isMemberJoinNotif)
        ( (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 =>
ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal ClientIdentity
cid (MessagePackage -> Maybe MessagePackage
forall a. a -> Maybe a
Just 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) -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageWithPredicate :: HasCallStack =>
(Value -> App Bool)
-> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageWithPredicate Value -> App Bool
p ClientIdentity
cid Maybe MessagePackage
mmp WebSocket
ws = do
  MLSState
mls <- App MLSState
getMLSState
  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"

  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
    App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
eventSubConv Value
event) (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
A.Null MLSState
mls.convId)
    App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"from") MessagePackage
mp.sender.user
    App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data") (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 => ClientIdentity -> ByteString -> App ByteString
ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ClientIdentity
cid ByteString
msgData
  HasCallStack => ClientIdentity -> ByteString -> App Value
ClientIdentity -> ByteString -> App Value
showMessage ClientIdentity
cid ByteString
msgData

-- | Get a single MLS message from a websocket and consume it. Return a JSON
-- representation of the message.
consumeMessage :: (HasCallStack) => ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessage :: HasCallStack =>
ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessage = HasCallStack =>
(Value -> App Bool)
-> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
(Value -> App Bool)
-> 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) => ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal :: HasCallStack =>
ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal ClientIdentity
cid = HasCallStack =>
(Value -> App Bool)
-> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
(Value -> App Bool)
-> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageWithPredicate Value -> App Bool
isNewMLSMessageNotifButNoProposal ClientIdentity
cid
  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
isNotif <- Value -> App Bool
forall a. MakesValue a => a -> App Bool
isNewMLSMessageNotif Value
n
      if Bool
isNotif
        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 => ClientIdentity -> ByteString -> App Value
ClientIdentity -> ByteString -> App Value
showMessage 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) => ClientIdentity -> ByteString -> App ByteString
mlsCliConsume :: HasCallStack => ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ClientIdentity
cid ByteString
msgData =
  HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
    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.
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 => MessagePackage -> Codensity App ()
MessagePackage -> Codensity App ()
consumingMessages 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

-- | Send an MLS commit bundle, wait for clients to receive it, consume it, and
-- update the test state accordingly.
sendAndConsumeCommitBundle :: (HasCallStack) => MessagePackage -> App Value
sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value
sendAndConsumeCommitBundle 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 => MessagePackage -> Codensity App ()
MessagePackage -> Codensity App ()
consumingMessages 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
        MLSState
mls <- App MLSState
getMLSState
        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 MLSState
mls.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_ (ClientIdentity -> ByteString -> App ()
fromWelcome 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
          { epoch = epoch mls + 1,
            members = members mls <> newMembers mls,
            newMembers = mempty
          }

      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
  MLSState
mls <- App MLSState
getMLSState
  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"

  App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
eventSubConv Value
event) (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
A.Null MLSState
mls.convId)
  App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"from") MessagePackage
mp.sender.user
  App Value -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch (Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data") ((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"
    (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing ClientGroupState
gs.group)
  ClientIdentity -> ByteString -> App ()
fromWelcome ClientIdentity
cid ByteString
welcome

fromWelcome :: ClientIdentity -> ByteString -> App ()
fromWelcome :: ClientIdentity -> ByteString -> App ()
fromWelcome 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 =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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) => ClientIdentity -> ByteString -> App Value
showMessage :: HasCallStack => ClientIdentity -> ByteString -> App Value
showMessage ClientIdentity
cid ByteString
msg = do
  ByteString
bs <- HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli 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) =>
  ClientIdentity ->
  String ->
  App MessagePackage
createApplicationMessage :: HasCallStack => ClientIdentity -> String -> App MessagePackage
createApplicationMessage ClientIdentity
cid String
messageContent = do
  ByteString
message <-
    HasCallStack =>
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli
      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: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
      }

setMLSCiphersuite :: Ciphersuite -> App ()
setMLSCiphersuite :: Ciphersuite -> App ()
setMLSCiphersuite Ciphersuite
suite = (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls -> MLSState
mls {ciphersuite = suite}

leaveCurrentConv ::
  (HasCallStack) =>
  ClientIdentity ->
  App ()
leaveCurrentConv :: HasCallStack => ClientIdentity -> App ()
leaveCurrentConv ClientIdentity
cid = do
  MLSState
mls <- App MLSState
getMLSState
  (Value
_, Maybe String
mSubId) <- Maybe Value -> App (Value, Maybe String)
forall a.
(HasCallStack, MakesValue a) =>
a -> App (Value, Maybe String)
objSubConv MLSState
mls.convId
  case Maybe String
mSubId 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 -> Maybe Value -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> App Response
leaveSubConversation ClientIdentity
cid MLSState
mls.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
          { members = Set.difference mls.members (Set.singleton cid)
          }

getCurrentConv :: (HasCallStack) => ClientIdentity -> App Value
getCurrentConv :: HasCallStack => ClientIdentity -> App Value
getCurrentConv ClientIdentity
cid = do
  MLSState
mls <- App MLSState
getMLSState
  (Value
conv, Maybe String
mSubId) <- Maybe Value -> App (Value, Maybe String)
forall a.
(HasCallStack, MakesValue a) =>
a -> App (Value, Maybe String)
objSubConv MLSState
mls.convId
  Response
resp <- case Maybe String
mSubId of
    Maybe String
Nothing -> ClientIdentity -> Value -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> App Response
getConversation ClientIdentity
cid Value
conv
    Just String
sub -> ClientIdentity -> Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
getSubConversation ClientIdentity
cid Value
conv String
sub
  HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp