-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.API.MLS.Proposal
  ( -- * Proposal processing
    derefOrCheckProposal,
    checkProposal,
    processProposal,
    proposalProcessingStage,
    addProposedClient,
    applyProposals,

    -- * Proposal actions
    paAddClient,
    paRemoveClient,

    -- * Types
    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}

-- | This is used to sort proposals into the correct processing order, as defined by the spec
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
    -- we are not checking lifetime constraints here
    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 =
  -- proposals are sorted before processing
  (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")
  -- we are not checking lifetime constraints here
  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
  -- Check if the group ID matches that of a conversation
  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
      -- Check if the epoch number matches that of a conversation
      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

      -- FUTUREWORK: validate the member's conversation role
      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

-- check owner/subject of the key package exists and belongs to the user
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
          -- requesting user must match key package owner
          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
          -- client referenced in key package must be one of the user's clients
          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 ()) -- FUTUREWORK: check external proposals from remote backends
    Qualified UserId
qusr