{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
module MLS.Util where
import API.Brig
import API.BrigCommon
import API.Galley
import Control.Concurrent.Async hiding (link)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Codensity
import Control.Monad.Cont
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Char8 as C8
import Data.Default
import Data.Foldable
import Data.Function
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text.Encoding as T
import Data.Traversable
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUIDV4
import GHC.Stack
import Notifications
import System.Directory
import System.Exit
import System.FilePath
import System.IO hiding (print, putStrLn)
import System.IO.Error (isAlreadyExistsError)
import System.IO.Temp
import System.Posix.Files
import System.Process
import Testlib.Assertions
import Testlib.HTTP
import Testlib.JSON
import Testlib.Prelude
import Testlib.Printing
mkClientIdentity :: (MakesValue u, MakesValue c) => u -> c -> App ClientIdentity
mkClientIdentity :: forall u c.
(MakesValue u, MakesValue c) =>
u -> c -> App ClientIdentity
mkClientIdentity u
u c
c = do
(String
domain, String
user) <- u -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid u
u
String
client <- c
c c -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> App ClientIdentity)
-> ClientIdentity -> App ClientIdentity
forall a b. (a -> b) -> a -> b
$ ClientIdentity {$sel:domain:ClientIdentity :: String
domain = String
domain, $sel:user:ClientIdentity :: String
user = String
user, $sel:client:ClientIdentity :: String
client = String
client}
cid2Str :: ClientIdentity -> String
cid2Str :: ClientIdentity -> String
cid2Str ClientIdentity
cid = ClientIdentity
cid.user String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClientIdentity
cid.client String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClientIdentity
cid.domain
data MessagePackage = MessagePackage
{ MessagePackage -> ClientIdentity
sender :: ClientIdentity,
MessagePackage -> ConvId
convId :: ConvId,
MessagePackage -> ByteString
message :: ByteString,
MessagePackage -> Maybe ByteString
welcome :: Maybe ByteString,
MessagePackage -> Maybe ByteString
groupInfo :: Maybe ByteString
}
toRandomFile :: ByteString -> App FilePath
toRandomFile :: ByteString -> App String
toRandomFile ByteString
bs = do
String
p <- App String
randomFileName
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
p ByteString
bs
String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p
randomFileName :: App FilePath
randomFileName :: App String
randomFileName = do
String
bd <- App String
getBaseDir
(String
bd </>) (String -> String) -> (UUID -> String) -> UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
UUID.toString (UUID -> String) -> App UUID -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> App UUID
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUIDV4.nextRandom
mlscli :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
mlscli :: HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
mConvId Ciphersuite
cs ClientIdentity
cid [String]
args Maybe ByteString
mbstdin = do
String
groupOut <- App String
randomFileName
let substOut :: String -> String
substOut = String -> String -> String -> String
argSubst String
"<group-out>" String
groupOut
let scheme :: String
scheme = Ciphersuite -> String
csSignatureScheme Ciphersuite
cs
ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid
String -> String
substIn <- case (ConvId -> Map ConvId ByteString -> Maybe ByteString)
-> Map ConvId ByteString -> ConvId -> Maybe ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvId -> Map ConvId ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ClientGroupState
gs.groups (ConvId -> Maybe ByteString) -> Maybe ConvId -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ConvId
mConvId of
Maybe ByteString
Nothing -> (String -> String) -> App (String -> String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> String
forall a. a -> a
id
Just ByteString
groupData -> do
String
fn <- ByteString -> App String
toRandomFile ByteString
groupData
(String -> String) -> App (String -> String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> String -> String
argSubst String
"<group-in>" String
fn)
String
store <- case String -> Map String ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
scheme ClientGroupState
gs.keystore of
Maybe ByteString
Nothing -> do
String
bd <- App String
getBaseDir
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
createDirectory (String
bd String -> String -> String
</> ClientIdentity -> String
cid2Str ClientIdentity
cid))
App () -> (IOError -> App ()) -> App ()
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \IOError
e ->
if (IOError -> Bool
isAlreadyExistsError IOError
e)
then () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else IOError -> App ()
forall e a. (HasCallStack, Exception e) => e -> App a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM IOError
e
String
path <- App String
randomFileName
String
ctype <- CredentialType -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make ClientGroupState
gs.credType App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
String -> [String] -> Maybe ByteString -> App ByteString
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
path [String
"init", String
"--ciphersuite", Ciphersuite
cs.code, String
"-t", String
ctype, ClientIdentity -> String
cid2Str ClientIdentity
cid] Maybe ByteString
forall a. Maybe a
Nothing
String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
path
Just ByteString
s -> ByteString -> App String
toRandomFile ByteString
s
let args' :: [String]
args' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
substIn (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
substOut) [String]
args
[String] -> (String -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
args' ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
arg ->
Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
arg String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"<group-in>", String
"<group-out>"]) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String
"Unbound arg: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
arg)
ByteString
out <- HasCallStack =>
String -> [String] -> Maybe ByteString -> App ByteString
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
store [String]
args' Maybe ByteString
mbstdin
ClientGroupState -> ClientGroupState
setGroup <- do
Bool
groupOutWritten <- IO Bool -> App Bool
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> App Bool) -> IO Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
groupOut
case (Bool
groupOutWritten, Maybe ConvId
mConvId) of
(Bool
True, Just ConvId
convId) -> do
ByteString
groupData <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BS.readFile String
groupOut)
(ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState))
-> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a b. (a -> b) -> a -> b
$ \ClientGroupState
x -> ClientGroupState
x {groups = Map.insert convId groupData x.groups}
(Bool
True, Maybe ConvId
Nothing) -> do
String -> App ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
red String
"mls-test-cli: Group was written but no convId was provided, this probably indicates something is going to go wrong in this test."
String -> App ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (String -> App ()) -> App String -> App ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CallStack -> IO String
prettierCallStack CallStack
HasCallStack => CallStack
callStack)
(ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientGroupState -> ClientGroupState
forall a. a -> a
id
(Bool, Maybe ConvId)
_ -> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientGroupState -> ClientGroupState
forall a. a -> a
id
ClientGroupState -> ClientGroupState
setStore <- do
ByteString
storeData <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BS.readFile String
store)
(ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState))
-> (ClientGroupState -> ClientGroupState)
-> App (ClientGroupState -> ClientGroupState)
forall a b. (a -> b) -> a -> b
$ \ClientGroupState
x -> ClientGroupState
x {keystore = Map.insert scheme storeData x.keystore}
HasCallStack => ClientIdentity -> ClientGroupState -> App ()
ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid (ClientGroupState -> ClientGroupState
setGroup (ClientGroupState -> ClientGroupState
setStore ClientGroupState
gs))
ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
out
runCli :: (HasCallStack) => FilePath -> [String] -> Maybe ByteString -> App ByteString
runCli :: HasCallStack =>
String -> [String] -> Maybe ByteString -> App ByteString
runCli String
store [String]
args Maybe ByteString
mStdin =
HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString
CreateProcess -> Maybe ByteString -> App ByteString
spawn
( String -> [String] -> CreateProcess
proc
String
"mls-test-cli"
( [String
"--store", String
store]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
args
)
)
Maybe ByteString
mStdin
argSubst :: String -> String -> String -> String
argSubst :: String -> String -> String -> String
argSubst String
from String
to_ String
s =
if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
from then String
to_ else String
s
createWireClient :: (MakesValue u, HasCallStack) => u -> AddClient -> App ClientIdentity
createWireClient :: forall u.
(MakesValue u, HasCallStack) =>
u -> AddClient -> App ClientIdentity
createWireClient u
u AddClient
clientArgs = do
u -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient u
u AddClient
clientArgs
App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
App Value -> (Value -> App ClientIdentity) -> App ClientIdentity
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= u -> Value -> App ClientIdentity
forall u c.
(MakesValue u, MakesValue c) =>
u -> c -> App ClientIdentity
mkClientIdentity u
u
data InitMLSClient = InitMLSClient
{ InitMLSClient -> CredentialType
credType :: CredentialType,
InitMLSClient -> AddClient
clientArgs :: AddClient
}
instance Default InitMLSClient where
def :: InitMLSClient
def = InitMLSClient {$sel:credType:InitMLSClient :: CredentialType
credType = CredentialType
BasicCredentialType, $sel:clientArgs:InitMLSClient :: AddClient
clientArgs = AddClient
forall a. Default a => a
def}
createMLSClient :: (MakesValue u, HasCallStack) => Ciphersuite -> InitMLSClient -> u -> App ClientIdentity
createMLSClient :: forall u.
(MakesValue u, HasCallStack) =>
Ciphersuite -> InitMLSClient -> u -> App ClientIdentity
createMLSClient Ciphersuite
ciphersuite = [Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
[Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites [Ciphersuite
ciphersuite]
createMLSClientWithCiphersuites :: (MakesValue u, HasCallStack) => [Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites :: forall u.
(MakesValue u, HasCallStack) =>
[Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
createMLSClientWithCiphersuites [Ciphersuite]
ciphersuites InitMLSClient
opts u
u = do
ClientIdentity
cid <- u -> AddClient -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
u -> AddClient -> App ClientIdentity
createWireClient u
u InitMLSClient
opts.clientArgs
HasCallStack => ClientIdentity -> ClientGroupState -> App ()
ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid ClientGroupState
forall a. Default a => a
def {credType = opts.credType}
[(Ciphersuite, ByteString)]
suitePKeys <- [Ciphersuite]
-> (Ciphersuite -> App (Ciphersuite, ByteString))
-> App [(Ciphersuite, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Ciphersuite]
ciphersuites ((Ciphersuite -> App (Ciphersuite, ByteString))
-> App [(Ciphersuite, ByteString)])
-> (Ciphersuite -> App (Ciphersuite, ByteString))
-> App [(Ciphersuite, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Ciphersuite
ciphersuite -> (Ciphersuite
ciphersuite,) (ByteString -> (Ciphersuite, ByteString))
-> App ByteString -> App (Ciphersuite, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
ciphersuite ClientIdentity
cid [String
"public-key"] Maybe ByteString
forall a. Maybe a
Nothing
App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse
( HasCallStack => ClientIdentity -> UpdateClient -> App Response
ClientIdentity -> UpdateClient -> App Response
updateClient
ClientIdentity
cid
UpdateClient
forall a. Default a => a
def
{ mlsPublicKeys =
Just
( object
[ csSignatureScheme ciphersuite .= T.decodeUtf8 (Base64.encode pkey)
| (ciphersuite, pkey) <- suitePKeys
]
)
}
)
((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientIdentity
cid
uploadNewKeyPackage :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App String
uploadNewKeyPackage :: HasCallStack => Ciphersuite -> ClientIdentity -> App String
uploadNewKeyPackage Ciphersuite
suite ClientIdentity
cid = do
(ByteString
kp, String
ref) <- HasCallStack =>
ClientIdentity -> Ciphersuite -> App (ByteString, String)
ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid Ciphersuite
suite
App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (ClientIdentity -> [ByteString] -> App Response
uploadKeyPackages ClientIdentity
cid [ByteString
kp]) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp ->
Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ref
generateKeyPackage :: (HasCallStack) => ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage :: HasCallStack =>
ClientIdentity -> Ciphersuite -> App (ByteString, String)
generateKeyPackage ClientIdentity
cid Ciphersuite
suite = do
ByteString
kp <- HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
suite ClientIdentity
cid [String
"key-package", String
"create", String
"--ciphersuite", Ciphersuite
suite.code] Maybe ByteString
forall a. Maybe a
Nothing
String
ref <- ByteString -> String
B8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> String) -> App ByteString -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
suite ClientIdentity
cid [String
"key-package", String
"ref", String
"-"] (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
kp)
String
fp <- HasCallStack => ClientIdentity -> String -> App String
ClientIdentity -> String -> App String
keyPackageFile ClientIdentity
cid String
ref
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
fp ByteString
kp
(ByteString, String) -> App (ByteString, String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
kp, String
ref)
createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup :: HasCallStack => Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup Ciphersuite
cs ClientIdentity
cid = do
Value
conv <- ClientIdentity -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation ClientIdentity
cid CreateConv
defMLS App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
ConvId
convId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
conv
Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId
ConvId -> App ConvId
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConvId
convId
createSelfGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App (String, Value)
createSelfGroup :: HasCallStack =>
Ciphersuite -> ClientIdentity -> App (String, Value)
createSelfGroup Ciphersuite
cs ClientIdentity
cid = do
Value
conv <- ClientIdentity -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
getSelfConversation ClientIdentity
cid App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
ConvId
convId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
conv
String
groupId <- Value
conv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId
(String, Value) -> App (String, Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
groupId, Value
conv)
createGroup :: Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup :: Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
convId = do
let Just String
groupId = ConvId
convId.groupId
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
let mlsConv :: MLSConv
mlsConv =
MLSConv
{ $sel:members:MLSConv :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
$sel:newMembers:MLSConv :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
String
groupId :: String
$sel:groupId:MLSConv :: String
groupId,
$sel:convId:MLSConv :: ConvId
convId = ConvId
convId,
$sel:epoch:MLSConv :: Word64
epoch = Word64
0,
$sel:ciphersuite:MLSConv :: Ciphersuite
ciphersuite = Ciphersuite
cs
}
in MLSState
s {convs = Map.insert convId mlsConv s.convs}
Value
keys <- Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> App Response
getMLSPublicKeys ClientIdentity
cid.qualifiedUserId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
Ciphersuite
-> ClientIdentity -> String -> ConvId -> Value -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
groupId ConvId
convId Value
keys
createSubConv :: (HasCallStack) => Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv :: HasCallStack =>
Ciphersuite -> ConvId -> ClientIdentity -> String -> App ()
createSubConv Ciphersuite
cs ConvId
convId ClientIdentity
cid String
subId = do
Value
sub <- ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
subId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
ConvId
subConvId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
sub
Ciphersuite -> ClientIdentity -> ConvId -> App ()
createGroup Ciphersuite
cs ClientIdentity
cid ConvId
subConvId
App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
subConvId ClientIdentity
cid App MessagePackage -> (MessagePackage -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
createOne2OneSubConv :: (HasCallStack, MakesValue keys) => Ciphersuite -> ConvId -> ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv :: forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ConvId -> ClientIdentity -> String -> keys -> App ()
createOne2OneSubConv Ciphersuite
cs ConvId
convId ClientIdentity
cid String
subId keys
keys = do
Value
sub <- ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
subId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
ConvId
subConvId <- Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Value
sub
Ciphersuite -> ClientIdentity -> Value -> keys -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid Value
sub keys
keys
App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
subConvId ClientIdentity
cid App MessagePackage -> (MessagePackage -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
resetOne2OneGroup :: (HasCallStack, MakesValue one2OneConv) => Ciphersuite -> ClientIdentity -> one2OneConv -> App ()
resetOne2OneGroup :: forall one2OneConv.
(HasCallStack, MakesValue one2OneConv) =>
Ciphersuite -> ClientIdentity -> one2OneConv -> App ()
resetOne2OneGroup Ciphersuite
cs ClientIdentity
cid one2OneConv
one2OneConv =
Ciphersuite -> ClientIdentity -> App Value -> App Value -> App ()
forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid (one2OneConv
one2OneConv one2OneConv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation") (one2OneConv
one2OneConv one2OneConv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_keys")
resetOne2OneGroupGeneric :: (HasCallStack, MakesValue conv, MakesValue keys) => Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric :: forall conv keys.
(HasCallStack, MakesValue conv, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> conv -> keys -> App ()
resetOne2OneGroupGeneric Ciphersuite
cs ClientIdentity
cid conv
conv keys
keys = do
ConvId
convId <- conv -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId conv
conv
String
groupId <- conv
conv conv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
let newMLSConv :: MLSConv
newMLSConv =
MLSConv
{ $sel:members:MLSConv :: Set ClientIdentity
members = ClientIdentity -> Set ClientIdentity
forall a. a -> Set a
Set.singleton ClientIdentity
cid,
$sel:newMembers:MLSConv :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
$sel:groupId:MLSConv :: String
groupId = String
groupId,
$sel:convId:MLSConv :: ConvId
convId = ConvId
convId,
$sel:epoch:MLSConv :: Word64
epoch = Word64
0,
$sel:ciphersuite:MLSConv :: Ciphersuite
ciphersuite = Ciphersuite
cs
}
resetConv :: MLSConv -> r -> MLSConv
resetConv MLSConv
old r
new =
MLSConv
old
{ groupId = new.groupId,
convId = new.convId,
members = new.members,
newMembers = new.newMembers,
epoch = new.epoch
}
in MLSState
s {convs = Map.insertWith resetConv convId newMLSConv s.convs}
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
groupId ConvId
convId keys
keys
resetClientGroup :: (HasCallStack, MakesValue keys) => Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup :: forall keys.
(HasCallStack, MakesValue keys) =>
Ciphersuite -> ClientIdentity -> String -> ConvId -> keys -> App ()
resetClientGroup Ciphersuite
cs ClientIdentity
cid String
gid ConvId
convId keys
keys = do
ByteString
removalKey <- App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString (App Value -> App ByteString) -> App Value -> App ByteString
forall a b. (a -> b) -> a -> b
$ keys
keys keys -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. (String
"removal." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ciphersuite -> String
csSignatureScheme Ciphersuite
cs)
App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
Ciphersuite
cs
ClientIdentity
cid
[ String
"group",
String
"create",
String
"--removal-key",
String
"-",
String
"--group-out",
String
"<group-out>",
String
"--ciphersuite",
Ciphersuite
cs.code,
String
gid
]
(ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
removalKey)
keyPackageFile :: (HasCallStack) => ClientIdentity -> String -> App FilePath
keyPackageFile :: HasCallStack => ClientIdentity -> String -> App String
keyPackageFile ClientIdentity
cid String
ref = do
let ref' :: String
ref' = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
urlSafe String
ref
String
bd <- App String
getBaseDir
String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ String
bd String -> String -> String
</> ClientIdentity -> String
cid2Str ClientIdentity
cid String -> String -> String
</> String
ref'
where
urlSafe :: Char -> Char
urlSafe Char
'+' = Char
'-'
urlSafe Char
'/' = Char
'_'
urlSafe Char
c = Char
c
unbundleKeyPackages :: (HasCallStack) => Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages :: HasCallStack => Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages Value
bundle = do
let entryIdentity :: a -> App ClientIdentity
entryIdentity a
be = do
String
d <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
String
u <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"user" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
String
c <- a
be a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"client" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
ClientIdentity -> App ClientIdentity
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> App ClientIdentity)
-> ClientIdentity -> App ClientIdentity
forall a b. (a -> b) -> a -> b
$ ClientIdentity {$sel:domain:ClientIdentity :: String
domain = String
d, $sel:user:ClientIdentity :: String
user = String
u, $sel:client:ClientIdentity :: String
client = String
c}
[Value]
bundleEntries <- Value
bundle Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key_packages" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
[Value]
-> (Value -> App (ClientIdentity, ByteString))
-> App [(ClientIdentity, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
bundleEntries ((Value -> App (ClientIdentity, ByteString))
-> App [(ClientIdentity, ByteString)])
-> (Value -> App (ClientIdentity, ByteString))
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Value
be -> do
String
kp64 <- Value
be Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key_package" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
ByteString
kp <- [ByteString] -> App ByteString
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne ([ByteString] -> App ByteString)
-> (String -> [ByteString]) -> String -> App ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String ByteString -> [ByteString]
forall a. Either String a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Either String ByteString -> [ByteString])
-> (String -> Either String ByteString) -> String -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> (String -> ByteString) -> String -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack (String -> App ByteString) -> String -> App ByteString
forall a b. (a -> b) -> a -> b
$ String
kp64
ClientIdentity
cid <- Value -> App ClientIdentity
forall {a}. MakesValue a => a -> App ClientIdentity
entryIdentity Value
be
(ClientIdentity, ByteString) -> App (ClientIdentity, ByteString)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity
cid, ByteString
kp)
createAddCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit :: HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
cid ConvId
convId [Value]
users = do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
[(ClientIdentity, ByteString)]
kps <- ([[(ClientIdentity, ByteString)]]
-> [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(ClientIdentity, ByteString)]] -> [(ClientIdentity, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (App [[(ClientIdentity, ByteString)]]
-> App [(ClientIdentity, ByteString)])
-> ((Value -> App [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]])
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [(ClientIdentity, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value]
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
users ((Value -> App [(ClientIdentity, ByteString)])
-> App [(ClientIdentity, ByteString)])
-> (Value -> App [(ClientIdentity, ByteString)])
-> App [(ClientIdentity, ByteString)]
forall a b. (a -> b) -> a -> b
$ \Value
user -> do
Value
bundle <- Ciphersuite -> ClientIdentity -> Value -> App Response
forall u v.
(HasCallStack, MakesValue u, MakesValue v) =>
Ciphersuite -> u -> v -> App Response
claimKeyPackages MLSConv
conv.ciphersuite ClientIdentity
cid Value
user App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
HasCallStack => Value -> App [(ClientIdentity, ByteString)]
Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages Value
bundle
HasCallStack =>
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid ConvId
convId [(ClientIdentity, ByteString)]
kps
withTempKeyPackageFile :: ByteString -> ContT a App FilePath
withTempKeyPackageFile :: forall a. ByteString -> ContT a App String
withTempKeyPackageFile ByteString
bs = do
String
bd <- App String -> ContT a App String
forall (m :: * -> *) a. Monad m => m a -> ContT a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift App String
getBaseDir
((String -> App a) -> App a) -> ContT a App String
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((String -> App a) -> App a) -> ContT a App String)
-> ((String -> App a) -> App a) -> ContT a App String
forall a b. (a -> b) -> a -> b
$ \String -> App a
k ->
App (String, Handle)
-> ((String, Handle) -> App ())
-> ((String, Handle) -> App a)
-> App a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(IO (String, Handle) -> App (String, Handle)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO (String, Handle)
openBinaryTempFile String
bd String
"kp"))
(\(String
fp, Handle
_) -> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
removeFile String
fp))
(((String, Handle) -> App a) -> App a)
-> ((String, Handle) -> App a) -> App a
forall a b. (a -> b) -> a -> b
$ \(String
fp, Handle
h) -> do
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` Handle -> IO ()
hClose Handle
h
String -> App a
k String
fp
createAddCommitWithKeyPackages ::
(HasCallStack) =>
ClientIdentity ->
ConvId ->
[(ClientIdentity, ByteString)] ->
App MessagePackage
createAddCommitWithKeyPackages :: HasCallStack =>
ClientIdentity
-> ConvId -> [(ClientIdentity, ByteString)] -> App MessagePackage
createAddCommitWithKeyPackages ClientIdentity
cid ConvId
convId [(ClientIdentity, ByteString)]
clientsAndKeyPackages = do
String
bd <- App String
getBaseDir
String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"
Just MLSConv
conv <- ConvId -> Map ConvId MLSConv -> Maybe MLSConv
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConvId
convId (Map ConvId MLSConv -> Maybe MLSConv)
-> (MLSState -> Map ConvId MLSConv) -> MLSState -> Maybe MLSConv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.convs) (MLSState -> Maybe MLSConv) -> App MLSState -> App (Maybe MLSConv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
ByteString
commit <- ContT ByteString App [String]
-> ([String] -> App ByteString) -> App ByteString
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (((ClientIdentity, ByteString) -> ContT ByteString App String)
-> [(ClientIdentity, ByteString)] -> ContT ByteString App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ByteString -> ContT ByteString App String
forall a. ByteString -> ContT a App String
withTempKeyPackageFile (ByteString -> ContT ByteString App String)
-> ((ClientIdentity, ByteString) -> ByteString)
-> (ClientIdentity, ByteString)
-> ContT ByteString App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) [(ClientIdentity, ByteString)]
clientsAndKeyPackages) (([String] -> App ByteString) -> App ByteString)
-> ([String] -> App ByteString) -> App ByteString
forall a b. (a -> b) -> a -> b
$ \[String]
kpFiles ->
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
( [ String
"member",
String
"add",
String
"--group",
String
"<group-in>",
String
"--welcome-out",
String
welcomeFile,
String
"--group-info-out",
String
giFile,
String
"--group-out",
String
"<group-out>"
]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
kpFiles
)
Maybe ByteString
forall a. Maybe a
Nothing
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls ->
MLSState
mls
{ convs =
Map.adjust
( \MLSConv
oldConvState ->
MLSConv
oldConvState {newMembers = Set.fromList (map fst clientsAndKeyPackages)}
)
convId
mls.convs
}
ByteString
welcome <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
welcomeFile
ByteString
gi <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessagePackage -> App MessagePackage)
-> MessagePackage -> App MessagePackage
forall a b. (a -> b) -> a -> b
$
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
commit,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi
}
createRemoveCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit :: HasCallStack =>
ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit ClientIdentity
cid ConvId
convId [ClientIdentity]
targets = do
String
bd <- App String
getBaseDir
String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"
Map ClientIdentity Word32
groupStateMap <- do
ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid
ByteString
groupData <- String -> Maybe ByteString -> App ByteString
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"Group state not initialised" (ConvId -> Map ConvId ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConvId
convId ClientGroupState
gs.groups)
[(ClientIdentity, Word32)] -> Map ClientIdentity Word32
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ClientIdentity, Word32)] -> Map ClientIdentity Word32)
-> App [(ClientIdentity, Word32)]
-> App (Map ClientIdentity Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
ByteString -> App [(ClientIdentity, Word32)]
readGroupState ByteString
groupData
let indices :: [Word32]
indices = (ClientIdentity -> Word32) -> [ClientIdentity] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe (String -> Word32
forall a. HasCallStack => String -> a
error String
"could not find target") (Maybe Word32 -> Word32)
-> (ClientIdentity -> Maybe Word32) -> ClientIdentity -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity -> Map ClientIdentity Word32 -> Maybe Word32)
-> Map ClientIdentity Word32 -> ClientIdentity -> Maybe Word32
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientIdentity -> Map ClientIdentity Word32 -> Maybe Word32
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map ClientIdentity Word32
groupStateMap) [ClientIdentity]
targets
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
commit <-
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
( [ String
"member",
String
"remove",
String
"--group",
String
"<group-in>",
String
"--group-out",
String
"<group-out>",
String
"--welcome-out",
String
welcomeFile,
String
"--group-info-out",
String
giFile
]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (Word32 -> String) -> [Word32] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> String
forall a. Show a => a -> String
show [Word32]
indices
)
Maybe ByteString
forall a. Maybe a
Nothing
ByteString
welcome <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
welcomeFile
ByteString
gi <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
commit,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi
}
createAddProposals :: (HasCallStack) => ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals :: HasCallStack =>
ConvId -> ClientIdentity -> [Value] -> App [MessagePackage]
createAddProposals ConvId
convId ClientIdentity
cid [Value]
users = do
Just MLSConv
mls <- ConvId -> Map ConvId MLSConv -> Maybe MLSConv
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConvId
convId (Map ConvId MLSConv -> Maybe MLSConv)
-> (MLSState -> Map ConvId MLSConv) -> MLSState -> Maybe MLSConv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.convs) (MLSState -> Maybe MLSConv) -> App MLSState -> App (Maybe MLSConv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App MLSState
getMLSState
[Value]
bundles <- [Value] -> (Value -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
users ((Value -> App Value) -> App [Value])
-> (Value -> App Value) -> App [Value]
forall a b. (a -> b) -> a -> b
$ (Ciphersuite -> ClientIdentity -> Value -> App Response
forall u v.
(HasCallStack, MakesValue u, MakesValue v) =>
Ciphersuite -> u -> v -> App Response
claimKeyPackages MLSConv
mls.ciphersuite ClientIdentity
cid (Value -> App Response)
-> (Response -> App Value) -> Value -> App Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200)
[(ClientIdentity, ByteString)]
kps <- [[(ClientIdentity, ByteString)]] -> [(ClientIdentity, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(ClientIdentity, ByteString)]]
-> [(ClientIdentity, ByteString)])
-> App [[(ClientIdentity, ByteString)]]
-> App [(ClientIdentity, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> App [(ClientIdentity, ByteString)])
-> [Value] -> App [[(ClientIdentity, ByteString)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse HasCallStack => Value -> App [(ClientIdentity, ByteString)]
Value -> App [(ClientIdentity, ByteString)]
unbundleKeyPackages [Value]
bundles
((ClientIdentity, ByteString) -> App MessagePackage)
-> [(ClientIdentity, ByteString)] -> App [MessagePackage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ConvId
-> ClientIdentity
-> (ClientIdentity, ByteString)
-> App MessagePackage
createAddProposalWithKeyPackage ConvId
convId ClientIdentity
cid) [(ClientIdentity, ByteString)]
kps
createReInitProposal :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createReInitProposal ConvId
convId ClientIdentity
cid = do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
prop <-
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
[String
"proposal", String
"--group-in", String
"<group-in>", String
"--group-out", String
"<group-out>", String
"re-init"]
Maybe ByteString
forall a. Maybe a
Nothing
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
prop,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
Nothing
}
createAddProposalWithKeyPackage ::
ConvId ->
ClientIdentity ->
(ClientIdentity, ByteString) ->
App MessagePackage
createAddProposalWithKeyPackage :: ConvId
-> ClientIdentity
-> (ClientIdentity, ByteString)
-> App MessagePackage
createAddProposalWithKeyPackage ConvId
convId ClientIdentity
cid (ClientIdentity
_, ByteString
kp) = do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
prop <- ContT ByteString App String
-> (String -> App ByteString) -> App ByteString
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (ByteString -> ContT ByteString App String
forall a. ByteString -> ContT a App String
withTempKeyPackageFile ByteString
kp) ((String -> App ByteString) -> App ByteString)
-> (String -> App ByteString) -> App ByteString
forall a b. (a -> b) -> a -> b
$ \String
kpFile ->
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
[String
"proposal", String
"--group-in", String
"<group-in>", String
"--group-out", String
"<group-out>", String
"add", String
kpFile]
Maybe ByteString
forall a. Maybe a
Nothing
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
prop,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
Nothing
}
createPendingProposalCommit :: (HasCallStack) => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit :: HasCallStack => ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
convId ClientIdentity
cid = do
String
bd <- App String
getBaseDir
String
welcomeFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"welcome"
String
pgsFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"pgs"
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
commit <-
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
[ String
"commit",
String
"--group",
String
"<group-in>",
String
"--group-out",
String
"<group-out>",
String
"--welcome-out",
String
welcomeFile,
String
"--group-info-out",
String
pgsFile
]
Maybe ByteString
forall a. Maybe a
Nothing
Maybe ByteString
welcome <- IO (Maybe ByteString) -> App (Maybe ByteString)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> App (Maybe ByteString))
-> IO (Maybe ByteString) -> App (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe ByteString)
readWelcome String
welcomeFile
ByteString
pgs <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
pgsFile
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
commit,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
welcome,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
pgs
}
createExternalCommit ::
(HasCallStack) =>
ConvId ->
ClientIdentity ->
Maybe ByteString ->
App MessagePackage
createExternalCommit :: HasCallStack =>
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
createExternalCommit ConvId
convId ClientIdentity
cid Maybe ByteString
mgi = do
String
bd <- App String
getBaseDir
String
giFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
emptyTempFile String
bd String
"gi"
ByteString
gi <- case Maybe ByteString
mgi of
Maybe ByteString
Nothing -> ClientIdentity -> ConvId -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> App Response
getGroupInfo ClientIdentity
cid ConvId
convId App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
Just ByteString
v -> ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
v
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
commit <-
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
[ String
"external-commit",
String
"--group-info-in",
String
"-",
String
"--group-info-out",
String
giFile,
String
"--group-out",
String
"<group-out>"
]
(ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
gi)
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls ->
MLSState
mls
{ convs = Map.adjust (\MLSConv
oldConvState -> MLSConv
oldConvState {newMembers = Set.singleton cid}) convId mls.convs
}
ByteString
newPgs <- IO ByteString -> App ByteString
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> App ByteString)
-> IO ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
giFile
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessagePackage -> App MessagePackage)
-> MessagePackage -> App MessagePackage
forall a b. (a -> b) -> a -> b
$
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
commit,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
newPgs
}
data MLSNotificationTag = MLSNotificationMessageTag | MLSNotificationWelcomeTag
deriving (Int -> MLSNotificationTag -> String -> String
[MLSNotificationTag] -> String -> String
MLSNotificationTag -> String
(Int -> MLSNotificationTag -> String -> String)
-> (MLSNotificationTag -> String)
-> ([MLSNotificationTag] -> String -> String)
-> Show MLSNotificationTag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MLSNotificationTag -> String -> String
showsPrec :: Int -> MLSNotificationTag -> String -> String
$cshow :: MLSNotificationTag -> String
show :: MLSNotificationTag -> String
$cshowList :: [MLSNotificationTag] -> String -> String
showList :: [MLSNotificationTag] -> String -> String
Show, MLSNotificationTag -> MLSNotificationTag -> Bool
(MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> Eq MLSNotificationTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MLSNotificationTag -> MLSNotificationTag -> Bool
== :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c/= :: MLSNotificationTag -> MLSNotificationTag -> Bool
/= :: MLSNotificationTag -> MLSNotificationTag -> Bool
Eq, Eq MLSNotificationTag
Eq MLSNotificationTag =>
(MLSNotificationTag -> MLSNotificationTag -> Ordering)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> Bool)
-> (MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag)
-> (MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag)
-> Ord MLSNotificationTag
MLSNotificationTag -> MLSNotificationTag -> Bool
MLSNotificationTag -> MLSNotificationTag -> Ordering
MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MLSNotificationTag -> MLSNotificationTag -> Ordering
compare :: MLSNotificationTag -> MLSNotificationTag -> Ordering
$c< :: MLSNotificationTag -> MLSNotificationTag -> Bool
< :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c<= :: MLSNotificationTag -> MLSNotificationTag -> Bool
<= :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c> :: MLSNotificationTag -> MLSNotificationTag -> Bool
> :: MLSNotificationTag -> MLSNotificationTag -> Bool
$c>= :: MLSNotificationTag -> MLSNotificationTag -> Bool
>= :: MLSNotificationTag -> MLSNotificationTag -> Bool
$cmax :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
max :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
$cmin :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
min :: MLSNotificationTag -> MLSNotificationTag -> MLSNotificationTag
Ord)
consumingMessages :: (HasCallStack) => MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages :: HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
mlsProtocol MessagePackage
mp = (forall b. (() -> App b) -> App b) -> Codensity App ()
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (() -> App b) -> App b) -> Codensity App ())
-> (forall b. (() -> App b) -> App b) -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ \() -> App b
k -> do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
let oldClients :: Set ClientIdentity
oldClients = ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender MLSConv
conv.members
let newClients :: Set ClientIdentity
newClients = ClientIdentity -> Set ClientIdentity -> Set ClientIdentity
forall a. Ord a => a -> Set a -> Set a
Set.delete MessagePackage
mp.sender MLSConv
conv.newMembers
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 ()
Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MLSProtocol
mlsProtocol MLSProtocol -> MLSProtocol -> Bool
forall a. Eq a => a -> a -> Bool
== MLSProtocol
MLSProtocolMLS) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
(WebSocket -> App Value) -> Map String WebSocket -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
(HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (\Value
n -> Value -> App Bool
forall a. MakesValue a => a -> App Bool
isMemberJoinNotif Value
n))
( (Map String WebSocket -> Set String -> Map String WebSocket)
-> Set String -> Map String WebSocket -> Map String WebSocket
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map String WebSocket -> Set String -> Map String WebSocket
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Set String
newUsers
(Map String WebSocket -> Map String WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ClientIdentity, MLSNotificationTag) -> String)
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
-> Map String WebSocket
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys ((.user) (ClientIdentity -> String)
-> ((ClientIdentity, MLSNotificationTag) -> ClientIdentity)
-> (ClientIdentity, MLSNotificationTag)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientIdentity, MLSNotificationTag) -> ClientIdentity
forall a b. (a, b) -> a
fst)
(Map (ClientIdentity, MLSNotificationTag) WebSocket
-> Map String WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
([((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket)
-> ([((ClientIdentity, MLSNotificationTag), WebSocket)]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)])
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map (ClientIdentity, MLSNotificationTag) WebSocket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
([((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket)
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
-> Map String WebSocket
forall a b. (a -> b) -> a -> b
$ [(ClientIdentity, MLSNotificationTag)]
-> [WebSocket]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ClientIdentity, MLSNotificationTag)]
clients [WebSocket]
wss
)
[((ClientIdentity, MLSNotificationTag), WebSocket)]
-> (((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
-> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([(ClientIdentity, MLSNotificationTag)]
-> [WebSocket]
-> [((ClientIdentity, MLSNotificationTag), WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ClientIdentity, MLSNotificationTag)]
clients [WebSocket]
wss) ((((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
-> App ())
-> (((ClientIdentity, MLSNotificationTag), WebSocket) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \((ClientIdentity
cid, MLSNotificationTag
t), WebSocket
ws) -> case MLSNotificationTag
t of
MLSNotificationTag
MLSNotificationMessageTag -> App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal MLSConv
conv.ciphersuite ClientIdentity
cid MessagePackage
mp WebSocket
ws
MLSNotificationTag
MLSNotificationWelcomeTag -> HasCallStack =>
ClientIdentity -> MessagePackage -> WebSocket -> App ()
ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome ClientIdentity
cid MessagePackage
mp WebSocket
ws
b -> App b
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r
consumeMessageWithPredicate :: (HasCallStack) => (Value -> App Bool) -> ConvId -> Ciphersuite -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessageWithPredicate :: HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
p ConvId
convId Ciphersuite
cs ClientIdentity
cid Maybe MessagePackage
mmp WebSocket
ws = do
Value
notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
p WebSocket
ws
Value
event <- Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId -> Value
convIdToQidObject ConvId
convId
Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
event String
"subconv" App (Maybe Value) -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId
convId.subconvId
Maybe MessagePackage -> (MessagePackage -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MessagePackage
mmp ((MessagePackage -> App ()) -> App ())
-> (MessagePackage -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \MessagePackage
mp -> do
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"from" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` MessagePackage
mp.sender.user
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ByteString -> String
B8.unpack (ByteString -> ByteString
Base64.encode MessagePackage
mp.message))
ByteString
msgData <- Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString
ByteString
_ <- HasCallStack =>
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
msgData
HasCallStack =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid ByteString
msgData
consumeMessage :: (HasCallStack) => ConvId -> Ciphersuite -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
consumeMessage :: HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage = HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
forall a. MakesValue a => a -> App Bool
isNewMLSMessageNotif
consumeMessageNoExternal :: (HasCallStack) => Ciphersuite -> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal :: HasCallStack =>
Ciphersuite
-> ClientIdentity -> MessagePackage -> WebSocket -> App Value
consumeMessageNoExternal Ciphersuite
cs ClientIdentity
cid MessagePackage
mp = HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate Value -> App Bool
isNewMLSMessageNotifButNoProposal MessagePackage
mp.convId Ciphersuite
cs ClientIdentity
cid (MessagePackage -> Maybe MessagePackage
forall a. a -> Maybe a
Just MessagePackage
mp)
where
isNewMLSMessageNotifButNoProposal :: Value -> App Bool
isNewMLSMessageNotifButNoProposal :: Value -> App Bool
isNewMLSMessageNotifButNoProposal Value
n = do
Bool
isRelevantNotif <- Value -> App Bool
forall a. MakesValue a => a -> App Bool
isNewMLSMessageNotif Value
n App Bool -> App Bool -> App Bool
&&~ ConvId -> Value -> App Bool
forall a. (MakesValue a, HasCallStack) => ConvId -> a -> App Bool
isNotifConvId MessagePackage
mp.convId Value
n
if Bool
isRelevantNotif
then do
Value
msg <- Value
n Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString App ByteString -> (ByteString -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid
Maybe Value
sender <- Value
msg Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
`lookupField` String
"message.content.sender" App (Maybe Value)
-> (AssertionFailure -> App (Maybe Value)) -> App (Maybe Value)
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(AssertionFailure
_ :: AssertionFailure) -> Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
let backendSender :: Value
backendSender = [Pair] -> Value
object [String
"External" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Scientific -> Value
Number Scientific
0]
Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ Maybe Value
sender Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value -> Maybe Value
forall a. a -> Maybe a
Just Value
backendSender
else Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
mlsCliConsume :: (HasCallStack) => ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume :: HasCallStack =>
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
msgData =
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
Ciphersuite
cs
ClientIdentity
cid
[ String
"consume",
String
"--group",
String
"<group-in>",
String
"--group-out",
String
"<group-out>",
String
"-"
]
(ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
msgData)
sendAndConsumeMessage :: (HasCallStack) => MessagePackage -> App Value
sendAndConsumeMessage :: HasCallStack => MessagePackage -> App Value
sendAndConsumeMessage MessagePackage
mp = Codensity App Value -> App Value
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity App Value -> App Value)
-> Codensity App Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
MLSProtocolMLS MessagePackage
mp
App Value -> Codensity App Value
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App Value -> Codensity App Value)
-> App Value -> Codensity App Value
forall a b. (a -> b) -> a -> b
$ HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSMessage MessagePackage
mp.sender MessagePackage
mp.message App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
sendAndConsumeCommitBundle :: (HasCallStack) => MessagePackage -> App Value
sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value
sendAndConsumeCommitBundle = HasCallStack => MLSProtocol -> MessagePackage -> App Value
MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol MLSProtocol
MLSProtocolMLS
sendAndConsumeCommitBundleWithProtocol :: (HasCallStack) => MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol :: HasCallStack => MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol MLSProtocol
protocol MessagePackage
mp = do
Codensity App Value -> App Value
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity App Value -> App Value)
-> Codensity App Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
HasCallStack => MLSProtocol -> MessagePackage -> Codensity App ()
MLSProtocol -> MessagePackage -> Codensity App ()
consumingMessages MLSProtocol
protocol MessagePackage
mp
App Value -> Codensity App Value
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App Value -> Codensity App Value)
-> App Value -> Codensity App Value
forall a b. (a -> b) -> a -> b
$ do
Value
r <- HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle MessagePackage
mp.sender (MessagePackage -> ByteString
mkBundle MessagePackage
mp) App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientIdentity -> Set ClientIdentity -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member MessagePackage
mp.sender MLSConv
conv.newMembers) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
(ByteString -> App ()) -> Maybe ByteString -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome MessagePackage
mp.convId MLSConv
conv.ciphersuite MessagePackage
mp.sender) MessagePackage
mp.welcome
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls ->
MLSState
mls
{ convs =
Map.adjust
( \MLSConv
conv ->
MLSConv
conv
{ epoch = conv.epoch + 1,
members = conv.members <> conv.newMembers,
newMembers = mempty
}
)
mp.convId
mls.convs
}
Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
r
consumeWelcome :: (HasCallStack) => ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome :: HasCallStack =>
ClientIdentity -> MessagePackage -> WebSocket -> App ()
consumeWelcome ClientIdentity
cid MessagePackage
mp WebSocket
ws = do
Value
notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. MakesValue a => a -> App Bool
isWelcomeNotif WebSocket
ws
Value
event <- Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ConvId -> Value
convIdToQidObject MessagePackage
mp.convId
Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
event String
"subconv" App (Maybe Value) -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` MessagePackage
mp.convId.subconvId
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"from" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` MessagePackage
mp.sender.user
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> Maybe String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ((ByteString -> String) -> Maybe ByteString -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
B8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode) MessagePackage
mp.welcome)
ByteString
welcome <- Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString
ClientGroupState
gs <- HasCallStack => ClientIdentity -> App ClientGroupState
ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid
HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool
String
"Existing clients in a conversation should not consume welcomes"
(Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConvId -> Map ConvId ByteString -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member MessagePackage
mp.convId ClientGroupState
gs.groups)
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv MessagePackage
mp.convId
ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome MessagePackage
mp.convId MLSConv
conv.ciphersuite ClientIdentity
cid ByteString
welcome
fromWelcome :: ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome :: ConvId -> Ciphersuite -> ClientIdentity -> ByteString -> App ()
fromWelcome ConvId
convId Ciphersuite
cs ClientIdentity
cid ByteString
welcome =
App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
Ciphersuite
cs
ClientIdentity
cid
[ String
"group",
String
"from-welcome",
String
"--group-out",
String
"<group-out>",
String
"-"
]
(ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
welcome)
readWelcome :: FilePath -> IO (Maybe ByteString)
readWelcome :: String -> IO (Maybe ByteString)
readWelcome String
fp = MaybeT IO ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO ByteString -> IO (Maybe ByteString))
-> MaybeT IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist String
fp) MaybeT IO Bool -> (Bool -> MaybeT IO ()) -> MaybeT IO ()
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
FileStatus
stat <- IO FileStatus -> MaybeT IO FileStatus
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> MaybeT IO FileStatus)
-> IO FileStatus -> MaybeT IO FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus String
fp
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
stat FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
> FileOffset
0
IO ByteString -> MaybeT IO ByteString
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> MaybeT IO ByteString)
-> IO ByteString -> MaybeT IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
fp
mkBundle :: MessagePackage -> ByteString
mkBundle :: MessagePackage -> ByteString
mkBundle MessagePackage
mp = MessagePackage
mp.message ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> ByteString
mkGroupInfoMessage MessagePackage
mp.groupInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Maybe ByteString -> ByteString
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold MessagePackage
mp.welcome
mkGroupInfoMessage :: ByteString -> ByteString
mkGroupInfoMessage :: ByteString -> ByteString
mkGroupInfoMessage ByteString
gi = [Word8] -> ByteString
BS.pack [Word8
0x00, Word8
0x01, Word8
0x00, Word8
0x04] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
gi
spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> App ByteString
spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString
spawn CreateProcess
cp Maybe ByteString
minput = do
(Maybe ByteString
mout, ExitCode
ex) <- IO (Maybe ByteString, ExitCode) -> App (Maybe ByteString, ExitCode)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO (Maybe ByteString, ExitCode)
-> App (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
-> App (Maybe ByteString, ExitCode)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess
CreateProcess
cp
{ std_out = CreatePipe,
std_in = if isJust minput then CreatePipe else Inherit
}
((Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode))
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
minh Maybe Handle
mouth Maybe Handle
_ ProcessHandle
ph ->
let writeInput :: IO ()
writeInput = Maybe (ByteString, Handle)
-> ((ByteString, Handle) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((,) (ByteString -> Handle -> (ByteString, Handle))
-> Maybe ByteString -> Maybe (Handle -> (ByteString, Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
minput Maybe (Handle -> (ByteString, Handle))
-> Maybe Handle -> Maybe (ByteString, Handle)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Handle
minh) (((ByteString, Handle) -> IO ()) -> IO ())
-> ((ByteString, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ByteString
input, Handle
inh) ->
Handle -> ByteString -> IO ()
BS.hPutStr Handle
inh ByteString
input IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
inh
readOutput :: IO (Maybe ByteString, ExitCode)
readOutput = (,) (Maybe ByteString -> ExitCode -> (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString)
-> IO (ExitCode -> (Maybe ByteString, ExitCode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO ByteString) -> Maybe Handle -> IO (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Handle -> IO ByteString
BS.hGetContents Maybe Handle
mouth IO (ExitCode -> (Maybe ByteString, ExitCode))
-> IO ExitCode -> IO (Maybe ByteString, ExitCode)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
in ((), (Maybe ByteString, ExitCode)) -> (Maybe ByteString, ExitCode)
forall a b. (a, b) -> b
snd (((), (Maybe ByteString, ExitCode))
-> (Maybe ByteString, ExitCode))
-> IO ((), (Maybe ByteString, ExitCode))
-> IO (Maybe ByteString, ExitCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ()
-> IO (Maybe ByteString, ExitCode)
-> IO ((), (Maybe ByteString, ExitCode))
forall a b. IO a -> IO b -> IO (a, b)
concurrently IO ()
writeInput IO (Maybe ByteString, ExitCode)
readOutput
case (Maybe ByteString
mout, ExitCode
ex) of
(Just ByteString
out, ExitCode
ExitSuccess) -> ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
out
(Maybe ByteString, ExitCode)
_ -> String -> App ByteString
forall a. HasCallStack => String -> App a
assertFailure String
"Failed spawning process"
getClientGroupState :: (HasCallStack) => ClientIdentity -> App ClientGroupState
getClientGroupState :: HasCallStack => ClientIdentity -> App ClientGroupState
getClientGroupState ClientIdentity
cid = do
MLSState
mls <- App MLSState
getMLSState
ClientGroupState -> App ClientGroupState
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientGroupState -> App ClientGroupState)
-> ClientGroupState -> App ClientGroupState
forall a b. (a -> b) -> a -> b
$ ClientGroupState
-> ClientIdentity
-> Map ClientIdentity ClientGroupState
-> ClientGroupState
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ClientGroupState
forall a. Default a => a
def ClientIdentity
cid MLSState
mls.clientGroupState
setClientGroupState :: (HasCallStack) => ClientIdentity -> ClientGroupState -> App ()
setClientGroupState :: HasCallStack => ClientIdentity -> ClientGroupState -> App ()
setClientGroupState ClientIdentity
cid ClientGroupState
g =
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
MLSState
s {clientGroupState = Map.insert cid g (clientGroupState s)}
showMessage :: (HasCallStack) => Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage :: HasCallStack =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
cs ClientIdentity
cid ByteString
msg = do
ByteString
bs <- HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli Maybe ConvId
forall a. Maybe a
Nothing Ciphersuite
cs ClientIdentity
cid [String
"show", String
"message", String
"-"] (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
msg)
Maybe Value -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
bs))
readGroupState :: (HasCallStack) => ByteString -> App [(ClientIdentity, Word32)]
readGroupState :: HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
readGroupState ByteString
gs = do
Value
v :: Value <- String -> Maybe Value -> App Value
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"Could not decode group state" (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
gs))
[Value]
lnodes <- Value
v Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_group" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"treesync" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"tree" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"leaf_nodes" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
[Maybe (ClientIdentity, Word32)] -> [(ClientIdentity, Word32)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ClientIdentity, Word32)] -> [(ClientIdentity, Word32)])
-> (((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [Maybe (ClientIdentity, Word32)])
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [(ClientIdentity, Word32)]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> [(Value, Word32)]
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [Maybe (ClientIdentity, Word32)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Value] -> [Word32] -> [(Value, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Value]
lnodes [Word32
0 ..]) (((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [(ClientIdentity, Word32)])
-> ((Value, Word32) -> App (Maybe (ClientIdentity, Word32)))
-> App [(ClientIdentity, Word32)]
forall a b. (a -> b) -> a -> b
$ \(Value
el, Word32
leafNodeIndex) -> do
Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
el String
"node" App (Maybe Value)
-> (Maybe Value -> App (Maybe (ClientIdentity, Word32)))
-> App (Maybe (ClientIdentity, Word32))
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Value
lnode -> do
case Value
lnode of
Value
Null -> Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClientIdentity, Word32)
forall a. Maybe a
Nothing
Value
_ -> do
Value
vecb <- Value
lnode Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"credential" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"credential" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"Basic" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"identity" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"vec"
[Value]
vec <- Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList Value
vecb
ByteString
ws <- [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> App [Word8] -> App ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> (Value -> App Word8) -> App [Word8]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
vec (\Value
x -> forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral @Word8 Value
x)
[ByteString
uc, ByteString
domain] <- [ByteString] -> App [ByteString]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString -> [ByteString]
C8.split Char
'@' ByteString
ws)
[ByteString
uid, ByteString
client] <- [ByteString] -> App [ByteString]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> ByteString -> [ByteString]
C8.split Char
':' ByteString
uc)
let cid :: ClientIdentity
cid = String -> String -> String -> ClientIdentity
ClientIdentity (ByteString -> String
C8.unpack ByteString
domain) (ByteString -> String
C8.unpack ByteString
uid) (ByteString -> String
C8.unpack ByteString
client)
Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ClientIdentity, Word32) -> Maybe (ClientIdentity, Word32)
forall a. a -> Maybe a
Just (ClientIdentity
cid, Word32
leafNodeIndex))
Maybe Value
Nothing ->
Maybe (ClientIdentity, Word32)
-> App (Maybe (ClientIdentity, Word32))
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ClientIdentity, Word32)
forall a. Maybe a
Nothing
createApplicationMessage ::
(HasCallStack) =>
ConvId ->
ClientIdentity ->
String ->
App MessagePackage
createApplicationMessage :: HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
convId ClientIdentity
cid String
messageContent = do
MLSConv
conv <- HasCallStack => ConvId -> App MLSConv
ConvId -> App MLSConv
getMLSConv ConvId
convId
ByteString
message <-
HasCallStack =>
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
Maybe ConvId
-> Ciphersuite
-> ClientIdentity
-> [String]
-> Maybe ByteString
-> App ByteString
mlscli
(ConvId -> Maybe ConvId
forall a. a -> Maybe a
Just ConvId
convId)
MLSConv
conv.ciphersuite
ClientIdentity
cid
[String
"message", String
"--group-in", String
"<group-in>", String
messageContent, String
"--group-out", String
"<group-out>"]
Maybe ByteString
forall a. Maybe a
Nothing
MessagePackage -> App MessagePackage
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessagePackage
{ $sel:sender:MessagePackage :: ClientIdentity
sender = ClientIdentity
cid,
$sel:convId:MessagePackage :: ConvId
convId = ConvId
convId,
$sel:message:MessagePackage :: ByteString
message = ByteString
message,
$sel:welcome:MessagePackage :: Maybe ByteString
welcome = Maybe ByteString
forall a. Maybe a
Nothing,
$sel:groupInfo:MessagePackage :: Maybe ByteString
groupInfo = Maybe ByteString
forall a. Maybe a
Nothing
}
leaveConv ::
(HasCallStack) =>
ConvId ->
ClientIdentity ->
App ()
leaveConv :: HasCallStack => ConvId -> ClientIdentity -> App ()
leaveConv ConvId
convId ClientIdentity
cid = do
case ConvId
convId.subconvId of
Maybe String
Nothing -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"Leaving conversations is not supported"
Just String
_ -> do
App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$ ClientIdentity -> ConvId -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> App Response
leaveSubConversation ClientIdentity
cid ConvId
convId App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
(MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
s ->
MLSState
s
{ convs = Map.adjust (\MLSConv
conv -> MLSConv
conv {members = Set.delete cid conv.members}) convId s.convs
}
getConv :: (HasCallStack) => ConvId -> ClientIdentity -> App Value
getConv :: HasCallStack => ConvId -> ClientIdentity -> App Value
getConv ConvId
convId ClientIdentity
cid = do
Response
resp <- case ConvId
convId.subconvId of
Maybe String
Nothing -> ClientIdentity -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation ClientIdentity
cid (ConvId -> Value
convIdToQidObject ConvId
convId)
Just String
sub -> ClientIdentity -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation ClientIdentity
cid ConvId
convId String
sub
HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp
getSubConvId :: (MakesValue user, HasCallStack) => user -> ConvId -> String -> App ConvId
getSubConvId :: forall user.
(MakesValue user, HasCallStack) =>
user -> ConvId -> String -> App ConvId
getSubConvId user
user ConvId
convId String
subConvName =
user -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation user
user ConvId
convId String
subConvName
App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
App Value -> (Value -> App ConvId) -> App ConvId
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId