module Galley.API.MLS.Proposal
(
derefOrCheckProposal,
checkProposal,
processProposal,
proposalProcessingStage,
addProposedClient,
applyProposals,
paAddClient,
paRemoveClient,
ProposalAction (..),
HasProposalEffects,
)
where
import Data.Id
import Data.Map qualified as Map
import Data.Qualified
import Data.Set qualified as Set
import Data.Time
import Galley.API.Error
import Galley.API.MLS.IncomingMessage
import Galley.API.MLS.Types
import Galley.API.Util
import Galley.Effects
import Galley.Effects.BrigAccess
import Galley.Effects.ProposalStore
import Galley.Env
import Galley.Options
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.State
import Polysemy.TinyLog
import Wire.API.Conversation hiding (Member)
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.AuthenticatedContent
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Credential
import Wire.API.MLS.KeyPackage
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Message
import Wire.API.MLS.Proposal
import Wire.API.MLS.Serialisation
import Wire.API.MLS.Validation
import Wire.API.Message
import Wire.NotificationSubsystem
data ProposalAction = ProposalAction
{ ProposalAction -> ClientMap
paAdd :: ClientMap,
ProposalAction -> ClientMap
paRemove :: ClientMap
}
deriving (Int -> ProposalAction -> ShowS
[ProposalAction] -> ShowS
ProposalAction -> String
(Int -> ProposalAction -> ShowS)
-> (ProposalAction -> String)
-> ([ProposalAction] -> ShowS)
-> Show ProposalAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProposalAction -> ShowS
showsPrec :: Int -> ProposalAction -> ShowS
$cshow :: ProposalAction -> String
show :: ProposalAction -> String
$cshowList :: [ProposalAction] -> ShowS
showList :: [ProposalAction] -> ShowS
Show)
instance Semigroup ProposalAction where
ProposalAction ClientMap
add1 ClientMap
rem1 <> :: ProposalAction -> ProposalAction -> ProposalAction
<> ProposalAction ClientMap
add2 ClientMap
rem2 =
ClientMap -> ClientMap -> ProposalAction
ProposalAction
((Map ClientId LeafIndex
-> Map ClientId LeafIndex -> Map ClientId LeafIndex)
-> ClientMap -> ClientMap -> ClientMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map ClientId LeafIndex
-> Map ClientId LeafIndex -> Map ClientId LeafIndex
forall a. Monoid a => a -> a -> a
mappend ClientMap
add1 ClientMap
add2)
((Map ClientId LeafIndex
-> Map ClientId LeafIndex -> Map ClientId LeafIndex)
-> ClientMap -> ClientMap -> ClientMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map ClientId LeafIndex
-> Map ClientId LeafIndex -> Map ClientId LeafIndex
forall a. Monoid a => a -> a -> a
mappend ClientMap
rem1 ClientMap
rem2)
instance Monoid ProposalAction where
mempty :: ProposalAction
mempty = ClientMap -> ClientMap -> ProposalAction
ProposalAction ClientMap
forall a. Monoid a => a
mempty ClientMap
forall a. Monoid a => a
mempty
paAddClient :: ClientIdentity -> LeafIndex -> ProposalAction
paAddClient :: ClientIdentity -> LeafIndex -> ProposalAction
paAddClient ClientIdentity
cid LeafIndex
idx = ProposalAction
forall a. Monoid a => a
mempty {paAdd = cmSingleton cid idx}
paRemoveClient :: ClientIdentity -> LeafIndex -> ProposalAction
paRemoveClient :: ClientIdentity -> LeafIndex -> ProposalAction
paRemoveClient ClientIdentity
cid LeafIndex
idx = ProposalAction
forall a. Monoid a => a
mempty {paRemove = cmSingleton cid idx}
data ProposalProcessingStage
= ProposalProcessingStageExtensions
| ProposalProcessingStageUpdate
| ProposalProcessingStageRemove
| ProposalProcessingStageAdd
| ProposalProcessingStagePreSharedKey
| ProposalProcessingStageExternalInit
| ProposalProcessingStageReInit
deriving (ProposalProcessingStage -> ProposalProcessingStage -> Bool
(ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> (ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> Eq ProposalProcessingStage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
== :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
$c/= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
/= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
Eq, Eq ProposalProcessingStage
Eq ProposalProcessingStage =>
(ProposalProcessingStage -> ProposalProcessingStage -> Ordering)
-> (ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> (ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> (ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> (ProposalProcessingStage -> ProposalProcessingStage -> Bool)
-> (ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage)
-> (ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage)
-> Ord ProposalProcessingStage
ProposalProcessingStage -> ProposalProcessingStage -> Bool
ProposalProcessingStage -> ProposalProcessingStage -> Ordering
ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage
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 :: ProposalProcessingStage -> ProposalProcessingStage -> Ordering
compare :: ProposalProcessingStage -> ProposalProcessingStage -> Ordering
$c< :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
< :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
$c<= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
<= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
$c> :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
> :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
$c>= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
>= :: ProposalProcessingStage -> ProposalProcessingStage -> Bool
$cmax :: ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage
max :: ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage
$cmin :: ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage
min :: ProposalProcessingStage
-> ProposalProcessingStage -> ProposalProcessingStage
Ord)
proposalProcessingStage :: Proposal -> ProposalProcessingStage
proposalProcessingStage :: Proposal -> ProposalProcessingStage
proposalProcessingStage (AddProposal RawMLS KeyPackage
_) = ProposalProcessingStage
ProposalProcessingStageAdd
proposalProcessingStage (RemoveProposal LeafIndex
_) = ProposalProcessingStage
ProposalProcessingStageRemove
proposalProcessingStage (UpdateProposal RawMLS LeafNode
_) = ProposalProcessingStage
ProposalProcessingStageUpdate
proposalProcessingStage (PreSharedKeyProposal RawMLS PreSharedKeyID
_) = ProposalProcessingStage
ProposalProcessingStagePreSharedKey
proposalProcessingStage (ReInitProposal RawMLS ReInit
_) = ProposalProcessingStage
ProposalProcessingStageReInit
proposalProcessingStage (ExternalInitProposal ByteString
_) = ProposalProcessingStage
ProposalProcessingStageExternalInit
proposalProcessingStage (GroupContextExtensionsProposal [Extension]
_) = ProposalProcessingStage
ProposalProcessingStageExtensions
type HasProposalEffects r =
( Member BackendNotificationQueueAccess r,
Member BrigAccess r,
Member ConversationStore r,
Member NotificationSubsystem r,
Member (Error InternalError) r,
Member (Error FederationError) r,
Member (Error MLSProposalFailure) r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSClientMismatch) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (Error NonFederatingBackends) r,
Member (Error UnreachableBackends) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member (Input Env) r,
Member (Input (Local ())) r,
Member (Input Opts) r,
Member (Input UTCTime) r,
Member LegalHoldStore r,
Member MemberStore r,
Member ProposalStore r,
Member TeamStore r,
Member TeamStore r,
Member TinyLog r
)
derefOrCheckProposal ::
( Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r,
Member ProposalStore r,
Member (State IndexMap) r,
Member (ErrorS 'MLSProposalNotFound) r
) =>
Epoch ->
CipherSuiteTag ->
GroupId ->
ProposalOrRef ->
Sem r Proposal
derefOrCheckProposal :: forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r, Member ProposalStore r,
Member (State IndexMap) r,
Member (ErrorS 'MLSProposalNotFound) r) =>
Epoch
-> CipherSuiteTag -> GroupId -> ProposalOrRef -> Sem r Proposal
derefOrCheckProposal Epoch
epoch CipherSuiteTag
_ciphersuite GroupId
groupId (Ref ProposalRef
ref) = do
RawMLS Proposal
p <- GroupId -> Epoch -> ProposalRef -> Sem r (Maybe (RawMLS Proposal))
forall (r :: EffectRow).
Member ProposalStore r =>
GroupId -> Epoch -> ProposalRef -> Sem r (Maybe (RawMLS Proposal))
getProposal GroupId
groupId Epoch
epoch ProposalRef
ref Sem r (Maybe (RawMLS Proposal))
-> (Maybe (RawMLS Proposal) -> Sem r (RawMLS Proposal))
-> Sem r (RawMLS Proposal)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'MLSProposalNotFound
Proposal -> Sem r Proposal
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMLS Proposal
p.value
derefOrCheckProposal Epoch
_epoch CipherSuiteTag
ciphersuite GroupId
_ (Inline Proposal
p) = do
IndexMap
im <- Sem r IndexMap
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
CipherSuiteTag -> IndexMap -> Proposal -> Sem r ()
forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> IndexMap -> Proposal -> Sem r ()
checkProposal CipherSuiteTag
ciphersuite IndexMap
im Proposal
p
Proposal -> Sem r Proposal
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposal
p
checkProposal ::
( Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r
) =>
CipherSuiteTag ->
IndexMap ->
Proposal ->
Sem r ()
checkProposal :: forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> IndexMap -> Proposal -> Sem r ()
checkProposal CipherSuiteTag
ciphersuite IndexMap
im Proposal
p = case Proposal
p of
AddProposal RawMLS KeyPackage
kp -> do
(CipherSuiteTag
cs, Lifetime
_lifetime) <-
(Text -> Sem r (CipherSuiteTag, Lifetime))
-> ((CipherSuiteTag, Lifetime) -> Sem r (CipherSuiteTag, Lifetime))
-> Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\Text
msg -> MLSProtocolError -> Sem r (CipherSuiteTag, Lifetime)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError (Text
"Invalid key package in Add proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg)))
(CipherSuiteTag, Lifetime) -> Sem r (CipherSuiteTag, Lifetime)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime))
-> Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime)
forall a b. (a -> b) -> a -> b
$ Maybe ClientIdentity
-> KeyPackage -> Either Text (CipherSuiteTag, Lifetime)
validateKeyPackage Maybe ClientIdentity
forall a. Maybe a
Nothing RawMLS KeyPackage
kp.value
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CipherSuiteTag
ciphersuite CipherSuiteTag -> CipherSuiteTag -> Bool
forall a. Eq a => a -> a -> Bool
== CipherSuiteTag
cs) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"Key package ciphersuite does not match conversation")
RemoveProposal LeafIndex
idx -> do
Sem r ClientIdentity -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r ClientIdentity -> Sem r ())
-> Sem r ClientIdentity -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'MLSInvalidLeafNodeIndex (Maybe ClientIdentity -> Sem r ClientIdentity)
-> Maybe ClientIdentity -> Sem r ClientIdentity
forall a b. (a -> b) -> a -> b
$ IndexMap -> LeafIndex -> Maybe ClientIdentity
imLookup IndexMap
im LeafIndex
idx
Proposal
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addProposedClient :: (Member (State IndexMap) r) => ClientIdentity -> Sem r ProposalAction
addProposedClient :: forall (r :: EffectRow).
Member (State IndexMap) r =>
ClientIdentity -> Sem r ProposalAction
addProposedClient ClientIdentity
cid = do
IndexMap
im <- Sem r IndexMap
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
let (LeafIndex
idx, IndexMap
im') = IndexMap -> ClientIdentity -> (LeafIndex, IndexMap)
imAddClient IndexMap
im ClientIdentity
cid
IndexMap -> Sem r ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put IndexMap
im'
ProposalAction -> Sem r ProposalAction
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> LeafIndex -> ProposalAction
paAddClient ClientIdentity
cid LeafIndex
idx)
applyProposals ::
( Member (State IndexMap) r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r
) =>
CipherSuiteTag ->
GroupId ->
[Proposal] ->
Sem r ProposalAction
applyProposals :: forall (r :: EffectRow).
(Member (State IndexMap) r, Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> GroupId -> [Proposal] -> Sem r ProposalAction
applyProposals CipherSuiteTag
ciphersuite GroupId
groupId =
(Proposal -> Sem r ProposalAction)
-> [Proposal] -> Sem r ProposalAction
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CipherSuiteTag -> GroupId -> Proposal -> Sem r ProposalAction
forall (r :: EffectRow).
(Member (State IndexMap) r, Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> GroupId -> Proposal -> Sem r ProposalAction
applyProposal CipherSuiteTag
ciphersuite GroupId
groupId)
([Proposal] -> Sem r ProposalAction)
-> ([Proposal] -> [Proposal]) -> [Proposal] -> Sem r ProposalAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proposal -> ProposalProcessingStage) -> [Proposal] -> [Proposal]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Proposal -> ProposalProcessingStage
proposalProcessingStage
applyProposal ::
( Member (State IndexMap) r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r
) =>
CipherSuiteTag ->
GroupId ->
Proposal ->
Sem r ProposalAction
applyProposal :: forall (r :: EffectRow).
(Member (State IndexMap) r, Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> GroupId -> Proposal -> Sem r ProposalAction
applyProposal CipherSuiteTag
ciphersuite GroupId
_groupId (AddProposal RawMLS KeyPackage
kp) = do
(CipherSuiteTag
cs, Lifetime
_lifetime) <-
(Text -> Sem r (CipherSuiteTag, Lifetime))
-> ((CipherSuiteTag, Lifetime) -> Sem r (CipherSuiteTag, Lifetime))
-> Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\Text
msg -> MLSProtocolError -> Sem r (CipherSuiteTag, Lifetime)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError (Text
"Invalid key package in Add proposal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg)))
(CipherSuiteTag, Lifetime) -> Sem r (CipherSuiteTag, Lifetime)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime))
-> Either Text (CipherSuiteTag, Lifetime)
-> Sem r (CipherSuiteTag, Lifetime)
forall a b. (a -> b) -> a -> b
$ Maybe ClientIdentity
-> KeyPackage -> Either Text (CipherSuiteTag, Lifetime)
validateKeyPackage Maybe ClientIdentity
forall a. Maybe a
Nothing RawMLS KeyPackage
kp.value
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CipherSuiteTag
ciphersuite CipherSuiteTag -> CipherSuiteTag -> Bool
forall a. Eq a => a -> a -> Bool
== CipherSuiteTag
cs) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"Key package ciphersuite does not match conversation")
ClientIdentity
cid <- KeyPackage -> Sem r ClientIdentity
forall (r :: EffectRow).
Member (ErrorS 'MLSUnsupportedProposal) r =>
KeyPackage -> Sem r ClientIdentity
getKeyPackageIdentity RawMLS KeyPackage
kp.value
ClientIdentity -> Sem r ProposalAction
forall (r :: EffectRow).
Member (State IndexMap) r =>
ClientIdentity -> Sem r ProposalAction
addProposedClient ClientIdentity
cid
applyProposal CipherSuiteTag
_ciphersuite GroupId
_groupId (RemoveProposal LeafIndex
idx) = do
IndexMap
im <- Sem r IndexMap
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
(ClientIdentity
cid, IndexMap
im') <- forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'MLSInvalidLeafNodeIndex (Maybe (ClientIdentity, IndexMap)
-> Sem r (ClientIdentity, IndexMap))
-> Maybe (ClientIdentity, IndexMap)
-> Sem r (ClientIdentity, IndexMap)
forall a b. (a -> b) -> a -> b
$ IndexMap -> LeafIndex -> Maybe (ClientIdentity, IndexMap)
imRemoveClient IndexMap
im LeafIndex
idx
IndexMap -> Sem r ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put IndexMap
im'
ProposalAction -> Sem r ProposalAction
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> LeafIndex -> ProposalAction
paRemoveClient ClientIdentity
cid LeafIndex
idx)
applyProposal CipherSuiteTag
_activeData GroupId
_groupId Proposal
_ = ProposalAction -> Sem r ProposalAction
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProposalAction
forall a. Monoid a => a
mempty
processProposal ::
(HasProposalEffects r) =>
( Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSStaleMessage) r
) =>
Qualified UserId ->
Local ConvOrSubConv ->
GroupId ->
Epoch ->
IncomingPublicMessageContent ->
RawMLS Proposal ->
Sem r ()
processProposal :: forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSStaleMessage) r) =>
Qualified UserId
-> Local ConvOrSubConv
-> GroupId
-> Epoch
-> IncomingPublicMessageContent
-> RawMLS Proposal
-> Sem r ()
processProposal Qualified UserId
qusr Local ConvOrSubConv
lConvOrSub GroupId
groupId Epoch
epoch IncomingPublicMessageContent
pub RawMLS Proposal
prop = do
let mlsMeta :: ConversationMLSData
mlsMeta = (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub).mlsMeta
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupId
groupId GroupId -> GroupId -> Bool
forall a. Eq a => a -> a -> Bool
== ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
mlsMeta) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'ConvNotFound
case ConversationMLSData -> Maybe ActiveMLSConversationData
cnvmlsActiveData ConversationMLSData
mlsMeta of
Maybe ActiveMLSConversationData
Nothing -> MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MLSProtocolError -> Sem r ()) -> MLSProtocolError -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Text -> MLSProtocolError
mlsProtocolError Text
"Bare proposals at epoch 0 are not supported"
Just ActiveMLSConversationData
activeData -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Epoch
epoch Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
== ActiveMLSConversationData
activeData.epoch) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSStaleMessage
CipherSuiteTag -> IndexMap -> Proposal -> Sem r ()
forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> IndexMap -> Proposal -> Sem r ()
checkProposal ActiveMLSConversationData
activeData.ciphersuite (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub).indexMap RawMLS Proposal
prop.value
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Sender -> Bool
isExternal IncomingPublicMessageContent
pub.sender) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Qualified UserId -> Proposal -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'MLSUnsupportedProposal) r,
Member (Input (Local ())) r) =>
Qualified UserId -> Proposal -> Sem r ()
checkExternalProposalUser Qualified UserId
qusr RawMLS Proposal
prop.value
let propRef :: ProposalRef
propRef =
CipherSuiteTag -> AuthenticatedContent -> ProposalRef
authContentRef
ActiveMLSConversationData
activeData.ciphersuite
(IncomingPublicMessageContent -> AuthenticatedContent
incomingMessageAuthenticatedContent IncomingPublicMessageContent
pub)
GroupId
-> Epoch
-> ProposalRef
-> ProposalOrigin
-> RawMLS Proposal
-> Sem r ()
forall (r :: EffectRow).
Member ProposalStore r =>
GroupId
-> Epoch
-> ProposalRef
-> ProposalOrigin
-> RawMLS Proposal
-> Sem r ()
storeProposal GroupId
groupId Epoch
epoch ProposalRef
propRef ProposalOrigin
ProposalOriginClient RawMLS Proposal
prop
getKeyPackageIdentity ::
(Member (ErrorS 'MLSUnsupportedProposal) r) =>
KeyPackage ->
Sem r ClientIdentity
getKeyPackageIdentity :: forall (r :: EffectRow).
Member (ErrorS 'MLSUnsupportedProposal) r =>
KeyPackage -> Sem r ClientIdentity
getKeyPackageIdentity =
(Text -> Sem r ClientIdentity)
-> (ClientIdentity -> Sem r ClientIdentity)
-> Either Text ClientIdentity
-> Sem r ClientIdentity
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
_ -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSUnsupportedProposal) ClientIdentity -> Sem r ClientIdentity
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either Text ClientIdentity -> Sem r ClientIdentity)
-> (KeyPackage -> Either Text ClientIdentity)
-> KeyPackage
-> Sem r ClientIdentity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPackage -> Either Text ClientIdentity
keyPackageIdentity
isExternal :: Sender -> Bool
isExternal :: Sender -> Bool
isExternal (SenderMember LeafIndex
_) = Bool
False
isExternal Sender
_ = Bool
True
checkExternalProposalUser ::
( Member BrigAccess r,
Member (ErrorS 'MLSUnsupportedProposal) r,
Member (Input (Local ())) r
) =>
Qualified UserId ->
Proposal ->
Sem r ()
checkExternalProposalUser :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'MLSUnsupportedProposal) r,
Member (Input (Local ())) r) =>
Qualified UserId -> Proposal -> Sem r ()
checkExternalProposalUser Qualified UserId
qusr Proposal
prop = do
Local ()
loc <- () -> Sem r (Local ())
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal ()
Local ()
-> (Local UserId -> Sem r ())
-> (Remote UserId -> Sem r ())
-> Qualified UserId
-> Sem r ()
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local ()
loc
( \Local UserId
lusr -> case Proposal
prop of
AddProposal RawMLS KeyPackage
kp -> do
ClientIdentity {UserId
ciUser :: UserId
$sel:ciUser:ClientIdentity :: ClientIdentity -> UserId
ciUser, ClientId
ciClient :: ClientId
$sel:ciClient:ClientIdentity :: ClientIdentity -> ClientId
ciClient} <- KeyPackage -> Sem r ClientIdentity
forall (r :: EffectRow).
Member (ErrorS 'MLSUnsupportedProposal) r =>
KeyPackage -> Sem r ClientIdentity
getKeyPackageIdentity RawMLS KeyPackage
kp.value
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= UserId
ciUser) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSUnsupportedProposal
UserClients {Map UserId (Set ClientId)
userClients :: Map UserId (Set ClientId)
$sel:userClients:UserClients :: UserClients -> Map UserId (Set ClientId)
userClients} <- [UserId] -> Sem r UserClients
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r UserClients
lookupClients [UserId
ciUser]
Sem r ()
-> (Set ClientId -> Sem r ()) -> Maybe (Set ClientId) -> Sem r ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSUnsupportedProposal)
((Bool -> Sem r () -> Sem r ()) -> Sem r () -> Bool -> Sem r ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSUnsupportedProposal) (Bool -> Sem r ())
-> (Set ClientId -> Bool) -> Set ClientId -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ClientId -> Bool
forall a. Set a -> Bool
Set.null (Set ClientId -> Bool)
-> (Set ClientId -> Set ClientId) -> Set ClientId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientId -> Bool) -> Set ClientId -> Set ClientId
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (ClientId -> ClientId -> Bool
forall a. Eq a => a -> a -> Bool
== ClientId
ciClient))
(Maybe (Set ClientId) -> Sem r ())
-> Maybe (Set ClientId) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Map UserId (Set ClientId)
userClients Map UserId (Set ClientId) -> UserId -> Maybe (Set ClientId)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? UserId
ciUser
Proposal
_ -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSUnsupportedProposal
)
(Sem r () -> Remote UserId -> Sem r ()
forall a b. a -> b -> a
const (Sem r () -> Remote UserId -> Sem r ())
-> Sem r () -> Remote UserId -> Sem r ()
forall a b. (a -> b) -> a -> b
$ () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Qualified UserId
qusr