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