-- 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 Wire.ConversationSubsystem.MLS.Message
  ( MLSMessageStaticErrors,
    postMLSCommitBundle,
    postMLSCommitBundleFromLocalUser,
    postMLSMessageFromLocalUser,
    postMLSMessage,
  )
where

import Control.Monad.Codensity
import Crypto.Hash (Digest, SHA256, hash)
import Data.ByteArray.Encoding (Base (Base16), convertToBase)
import Data.ByteString.Conversion (toByteString')
import Data.Domain
import Data.Hex
import Data.Id
import Data.IntMap qualified as IntMap
import Data.Json.Util
import Data.LegalHold
import Data.Map qualified as Map
import Data.Qualified
import Data.Set qualified as Set
import Data.Tagged
import Data.Text.Lazy qualified as LT
import Data.Tuple.Extra
import Galley.Types.Error
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.Output
import Polysemy.Resource (Resource)
import Polysemy.TinyLog
import System.Logger qualified as Log
import Wire.API.Conversation hiding (Member)
import Wire.API.Conversation.Config (ConversationSubsystemConfig)
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Client (FederatorClient)
import Wire.API.Federation.Error
import Wire.API.History
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Commit hiding (output)
import Wire.API.MLS.CommitBundle
import Wire.API.MLS.Credential
import Wire.API.MLS.GroupInfo
import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys)
import Wire.API.MLS.Message
import Wire.API.MLS.OutOfSync
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.Routes.Version
import Wire.API.Team.LegalHold
import Wire.BrigAPIAccess (BrigAPIAccess)
import Wire.ConversationStore
import Wire.ConversationStore.MLS.Types
import Wire.ConversationSubsystem.Action
import Wire.ConversationSubsystem.MLS.Commit.Core (getCommitData)
import Wire.ConversationSubsystem.MLS.Commit.ExternalCommit
import Wire.ConversationSubsystem.MLS.Commit.InternalCommit
import Wire.ConversationSubsystem.MLS.Conversation
import Wire.ConversationSubsystem.MLS.Enabled
import Wire.ConversationSubsystem.MLS.GroupInfoCheck
import Wire.ConversationSubsystem.MLS.IncomingMessage
import Wire.ConversationSubsystem.MLS.One2One
import Wire.ConversationSubsystem.MLS.OutOfSync
import Wire.ConversationSubsystem.MLS.Propagate
import Wire.ConversationSubsystem.MLS.Proposal
import Wire.ConversationSubsystem.MLS.Util
import Wire.ConversationSubsystem.MLS.Welcome (sendWelcomes)
import Wire.ConversationSubsystem.Util
import Wire.ExternalAccess
import Wire.FeaturesConfigSubsystem
import Wire.FederationAPIAccess
import Wire.FederationSubsystem
import Wire.MeetingNotifier
import Wire.NotificationSubsystem
import Wire.Sem.Now qualified as Now
import Wire.Sem.Random (Random)
import Wire.StoredConversation
import Wire.TeamStore qualified as TeamStore
import Wire.TeamSubsystem (TeamSubsystem, getUserStatus)

-- FUTUREWORK
-- - Check that the capabilities of a leaf node in an add proposal contains all
--   the required_capabilities of the group context. This would require fetching
--   the group info from the DB in order to read the group context.
-- - Verify message signature, this also requires the group context. (see above)

type MLSMessageStaticErrors =
  '[ ErrorS 'ConvAccessDenied,
     ErrorS 'ConvMemberNotFound,
     ErrorS 'ConvNotFound,
     ErrorS 'MLSNotEnabled,
     ErrorS 'MLSUnsupportedMessage,
     ErrorS 'MLSStaleMessage,
     ErrorS 'MLSProposalNotFound,
     ErrorS 'MissingLegalholdConsent,
     ErrorS 'MLSCommitMissingReferences,
     ErrorS 'MLSSelfRemovalNotAllowed,
     ErrorS 'MLSClientSenderUserMismatch,
     ErrorS 'MLSSubConvClientNotInParent,
     ErrorS 'MLSHistoryClientConflict,
     ErrorS 'MLSHistoryClientDuplication
   ]

enableOutOfSyncCheckFromVersion :: Version -> EnableOutOfSyncCheck
enableOutOfSyncCheckFromVersion v
  | v < V13 = DisableOutOfSyncCheck
  | otherwise = EnableOutOfSyncCheck

postMLSMessageFromLocalUser ::
  ( HasProposalEffects r,
    Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (ErrorS 'ConvMemberNotFound) r,
    Member (ErrorS 'ConvNotFound) r,
    Member (ErrorS 'MissingLegalholdConsent) r,
    Member (ErrorS 'MLSClientSenderUserMismatch) r,
    Member (ErrorS 'MLSCommitMissingReferences) r,
    Member (ErrorS 'MLSNotEnabled) r,
    Member (ErrorS 'MLSProposalNotFound) r,
    Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSUnsupportedMessage) r,
    Member (ErrorS 'MLSSubConvClientNotInParent) r,
    Member (ErrorS MLSInvalidLeafNodeSignature) r,
    Member (Error MLSOutOfSyncError) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (ErrorS MLSHistoryClientConflict) r,
    Member (ErrorS MLSHistoryClientDuplication) r
  ) =>
  Version ->
  Local UserId ->
  ClientId ->
  ConnId ->
  RawMLS Message ->
  Sem r MLSMessageSendingStatus
postMLSMessageFromLocalUser v lusr c conn smsg = do
  assertMLSEnabled
  imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg
  (ctype, cnvOrSub) <- getConvFromGroupId imsg.groupId
  events <-
    map lcuEvent
      <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) imsg
  t <- toUTCTimeMillis <$> Now.get
  pure $ MLSMessageSendingStatus events t

postMLSCommitBundle ::
  ( Member MeetingNotifier r,
    Member (ErrorS MLSLegalholdIncompatible) r,
    Member (ErrorS MLSIdentityMismatch) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (Error MLSOutOfSyncError) r,
    Member (ErrorS GroupIdVersionNotSupported) r,
    Member (Input (Maybe GroupInfoCheckEnabled)) r,
    Member Random r,
    Member Resource r,
    Members MLSMessageStaticErrors r,
    Member (ErrorS 'MLSInvalidLeafNodeSignature) r,
    HasProposalEffects r,
    Member MLSCommitLockStore r,
    Member FederationSubsystem r,
    Member TeamSubsystem r,
    Member (Input ConversationSubsystemConfig) r,
    Member FeaturesConfigSubsystem r
  ) =>
  Local x ->
  Qualified UserId ->
  ClientId ->
  ConvType ->
  Qualified ConvOrSubConvId ->
  Maybe ConnId ->
  EnableOutOfSyncCheck ->
  IncomingBundle ->
  Sem r [LocalConversationUpdate]
postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle =
  runInputConst oosCheck $
    foldQualified
      loc
      (postMLSCommitBundleToLocalConv qusr c conn bundle ctype)
      (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype)
      qConvOrSub

postMLSCommitBundleFromLocalUser ::
  ( Member MeetingNotifier r,
    Member (ErrorS MLSLegalholdIncompatible) r,
    Member (ErrorS MLSIdentityMismatch) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (Error MLSOutOfSyncError) r,
    Member (ErrorS GroupIdVersionNotSupported) r,
    Member (Input (Maybe GroupInfoCheckEnabled)) r,
    Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r,
    Member Random r,
    Member Resource r,
    Members MLSMessageStaticErrors r,
    Member (ErrorS 'MLSInvalidLeafNodeSignature) r,
    HasProposalEffects r,
    Member MLSCommitLockStore r,
    Member FederationSubsystem r,
    Member TeamSubsystem r,
    Member (Input ConversationSubsystemConfig) r,
    Member FeaturesConfigSubsystem r
  ) =>
  Version ->
  Local UserId ->
  ClientId ->
  ConnId ->
  RawMLS CommitBundle ->
  Sem r MLSMessageSendingStatus
postMLSCommitBundleFromLocalUser v lusr c conn bundle = do
  assertMLSEnabled
  ibundle <- noteS @'MLSUnsupportedMessage $ mkIncomingBundle bundle
  (ctype, qConvOrSub) <- getConvFromGroupId ibundle.groupId

  events <-
    map lcuEvent
      <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) ibundle
  t <- toUTCTimeMillis <$> Now.get
  pure $ MLSMessageSendingStatus events t

postMLSCommitBundleToLocalConv ::
  ( Member MeetingNotifier r,
    Member (ErrorS MLSLegalholdIncompatible) r,
    Member (ErrorS MLSIdentityMismatch) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (Error MLSOutOfSyncError) r,
    Member (ErrorS GroupIdVersionNotSupported) r,
    Member (Input EnableOutOfSyncCheck) r,
    Member (Input (Maybe GroupInfoCheckEnabled)) r,
    Member Random r,
    Member Resource r,
    Members MLSMessageStaticErrors r,
    Member (ErrorS 'MLSInvalidLeafNodeSignature) r,
    HasProposalEffects r,
    Member MLSCommitLockStore r,
    Member FederationSubsystem r,
    Member TeamSubsystem r,
    Member (Input ConversationSubsystemConfig) r,
    Member FeaturesConfigSubsystem r
  ) =>
  Qualified UserId ->
  ClientId ->
  Maybe ConnId ->
  IncomingBundle ->
  ConvType ->
  Local ConvOrSubConvId ->
  Sem r [LocalConversationUpdate]
postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do
  lConvOrSub <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId
  let convOrSub = tUnqualified lConvOrSub

  -- validate application message
  traverse_ (validateMessage qusr c lConvOrSub (Just (succ bundle.epoch))) bundle.appMessage

  ciphersuite <-
    note (mlsProtocolError "Unsupported ciphersuite") $
      cipherSuiteTag bundle.groupInfo.value.groupContext.cipherSuite

  -- when a user tries to join any mls conversation while being under legalhold
  -- they receive a 409 stating that mls and legalhold are incompatible
  case qusr `relativeTo` lConvOrSubId of
    Local luid ->
      when (isNothing convOrSub.mlsMeta.cnvmlsActiveData) do
        usrTeams <- TeamStore.getUserTeams (tUnqualified luid)
        for_ usrTeams \tid -> do
          -- this would only return 'Left' if the team member did vanish directly in the process of this
          -- request or if the legalhold state was somehow inconsistent. We can safely assume that this
          -- should be a server error
          resp <- runError @(Tagged TeamMemberNotFound ()) $ getUserStatus luid tid (tUnqualified luid)
          case resp of
            Left _ -> throw $ InternalErrorWithDescription "Server error. Team member must have vanished with the legal hold check"
            Right r -> case r.ulhsrStatus of
              UserLegalHoldPending -> throwS @MLSLegalholdIncompatible
              UserLegalHoldEnabled -> throwS @MLSLegalholdIncompatible
              UserLegalHoldDisabled -> pure ()
              UserLegalHoldNoConsent -> pure ()

    -- we can skip the remote case because we currently to not support creating conversations on the remote backend
    Remote _ -> pure ()

  ciphersuiteUpdate <- case convOrSub.mlsMeta.cnvmlsActiveData of
    -- if this is the first commit of the conversation, update ciphersuite
    Nothing -> pure True
    -- otherwise, make sure the ciphersuite matches
    Just activeData -> do
      unless (ciphersuite == activeData.ciphersuite) $
        throw $
          mlsProtocolError "GroupInfo ciphersuite does not match conversation"
      unless (bundle.epoch == activeData.epoch) $ do
        logStaleCommitBundle
          "commit-bundle-epoch-mismatch"
          lConvOrSub
          bundle.groupId
          bundle.epoch
          activeData.epoch
          bundle.groupInfo
          activeData.ciphersuite
        throwS @'MLSStaleMessage
      pure False

  senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub

  (events, newClients, lConvOrSub') <- handleGroupInfoMismatch lConvOrSubId bundle $ lowerCodensity $ do
    (events, newClients) <- case senderIdentity.index of
      Just _ -> do
        -- extract added/removed clients from bundle
        (newIndexMap, action) <-
          lift $
            getCommitData senderIdentity lConvOrSub bundle.epoch ciphersuite bundle

        lift $ do
          case convOrSub of
            Conv _ -> do
              let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory
              let historyClients = filter isHistoryClient (IntMap.elems newIndexMap.unIndexMap)
              case historyClients of
                (_ : _ : _) -> throwS @'MLSHistoryClientDuplication
                _ -> pure ()
              let historyClientExists = not (null historyClients)
              when (sharedHistoryEnabled /= historyClientExists) $ throwS @'MLSHistoryClientConflict
            SubConv _ _ -> pure ()

          -- reject message if the conversation is out of sync
          let newUsers = Map.keysSet (unClientMap action.paAdd)
          checkConversationOutOfSync newUsers lConvOrSub ciphersuite

          checkGroupState convOrSub newIndexMap bundle.groupInfo.value

        -- process additions and removals
        events <-
          processInternalCommit
            senderIdentity
            conn
            lConvOrSub
            ciphersuite
            ciphersuiteUpdate
            bundle.epoch
            action
            bundle.commit.value
        -- the sender client is included in the Add action on the first commit,
        -- but it doesn't need to get a welcome message, so we filter it out here
        let newClients = cmRemoveClient senderIdentity.client (paAdd action)
        pure (events, newClients)
      Nothing -> do
        (newIndexMap, action) <- lift $ getExternalCommitData senderIdentity.client lConvOrSub bundle.epoch bundle.commit.value
        lift $ checkGroupState convOrSub newIndexMap bundle.groupInfo.value
        let senderIdentity' = senderIdentity {index = Just action.add}
        processExternalCommit
          senderIdentity'
          lConvOrSub
          ciphersuite
          ciphersuiteUpdate
          bundle.epoch
          action
          bundle.commit.value.path
        pure ([], mempty)
    lConvOrSub' <- lift $ do
      updateOutOfSyncFlag senderIdentity.client lConvOrSub
      storeGroupInfo convOrSub.id (GroupInfoData bundle.groupInfo.raw)
      -- reload conversation from db to make sure we have an up-to-date list of members
      lConvOrSub' <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId
      let convOrSub' = tUnqualified lConvOrSub'
          mems = cmIntersect (void convOrSub.members) convOrSub'.members
      propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage mems
      pure lConvOrSub'
    pure (events, newClients, lConvOrSub')

  notifyNewMeetingMembers qusr lConvOrSub lConvOrSub'

  -- send welcome messages
  for_ bundle.welcome $ \welcome ->
    sendWelcomes lConvOrSubId qusr conn (cmIdentities newClients) welcome

  -- send application message
  for_ bundle.appMessage $ \msg -> do
    let convOrSub' = tUnqualified lConvOrSub'
    propagateMessage qusr (Just c) lConvOrSub' conn msg.rawMessage convOrSub'.members

  pure events

notifyNewMeetingMembers ::
  (Member MeetingNotifier r) =>
  Qualified UserId ->
  Local ConvOrSubConv ->
  Local ConvOrSubConv ->
  Sem r ()
notifyNewMeetingMembers qUser before after =
  case (tUnqualified before, tUnqualified after) of
    (Conv beforeConv, Conv afterConv)
      | isMeetingConv afterConv -> do
          let beforeUsers = Set.fromList (map (.id_) beforeConv.mcLocalMembers)
              afterUsers = Set.fromList (map (.id_) afterConv.mcLocalMembers)
              addedUsers = newLocalMeetingMembers beforeUsers afterUsers
          unless (null addedUsers) $
            notifyMeetingMembersAdded
              qUser
              (Qualified afterConv.mcId (tDomain after))
              afterConv.mcMetadata.cnvmTeam
              addedUsers
    _ -> pure ()
  where
    isMeetingConv conv =
      conv.mcMetadata.cnvmGroupConvType == Just MeetingConversation
    newLocalMeetingMembers prev curr =
      Set.toList (Set.difference curr prev)

handleGroupInfoMismatch ::
  (Member (Error GroupInfoDiagnostics) r) =>
  Local ConvOrSubConvId ->
  IncomingBundle ->
  InterpreterFor (Error GroupInfoMismatch) r
handleGroupInfoMismatch lConvId bundle m =
  runError m >>= \case
    Right x -> pure x
    Left mismatch -> do
      throw
        GroupInfoDiagnostics
          { commit = bundle.rawMessage.raw,
            groupInfo = bundle.groupInfo.raw,
            groupId = bundle.groupId,
            clients = mismatch.clients,
            convId = tUnqualified lConvId,
            domain = tDomain lConvId
          }

logStaleCommitBundle ::
  (Member TinyLog r) =>
  ByteString ->
  Local ConvOrSubConv ->
  GroupId ->
  Epoch ->
  Epoch ->
  RawMLS GroupInfo ->
  CipherSuiteTag ->
  Sem r ()
logStaleCommitBundle reason lConvOrSub gid messageEpoch storedEpoch groupInfo storedCipherSuite = do
  let convOrSub = tUnqualified lConvOrSub
      convOrSubId = tUnqualified (fmap (.id) lConvOrSub)
      groupContext = groupInfo.value.groupContext
  warn $
    Log.msg ("rejecting stale MLS commit bundle" :: ByteString)
      . Log.field "reason" reason
      . Log.field "groupId" ("0x" <> hex (unGroupId gid))
      . Log.field "messageEpoch" (epochNumber messageEpoch)
      . Log.field "storedEpoch" (epochNumber storedEpoch)
      . Log.field "storedCipherSuite" (cipherSuiteNumber (tagCipherSuite storedCipherSuite))
      . Log.field "activeDataPresent" True
      . Log.field "groupInfoPresent" True
      . Log.field "groupInfoSha256" (sha256Hex groupInfo.raw)
      . Log.field "groupInfoGroupId" ("0x" <> hex (unGroupId groupContext.groupId))
      . Log.field "groupInfoEpoch" (epochNumber groupContext.epoch)
      . Log.field "groupInfoCipherSuite" (cipherSuiteNumber groupContext.cipherSuite)
      . Log.field "domain" (toByteString' (show (tDomain lConvOrSub)))
      . Log.field "parentConvId" (toByteString' (show convOrSubId.conv))
      . Log.field "subConvId" (maybe ("none" :: ByteString) (toByteString' . show) convOrSubId.subconv)
      . Log.field
        "convOrSubConvId"
        (toByteString' (show convOrSubId))
      . Log.field "isSubConversation" (isSubConv convOrSub)
      . Log.field "memberCount" (length (cmAssocs convOrSub.members))

sha256Hex :: ByteString -> ByteString
sha256Hex bs = convertToBase Base16 (hash bs :: Digest SHA256)

postMLSCommitBundleToRemoteConv ::
  ( Member BrigAPIAccess r,
    Members MLSMessageStaticErrors r,
    Member (Error FederationError) r,
    Member (Error MLSProtocolError) r,
    Member (Error MLSProposalFailure) r,
    Member (Error NonFederatingBackends) r,
    Member (Error UnreachableBackends) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (Error MLSOutOfSyncError) r,
    Member (Input EnableOutOfSyncCheck) r,
    Member ExternalAccess r,
    Member (FederationAPIAccess FederatorClient) r,
    Member NotificationSubsystem r,
    Member ConversationStore r,
    Member TinyLog r
  ) =>
  Local x ->
  Qualified UserId ->
  ClientId ->
  Maybe ConnId ->
  IncomingBundle ->
  ConvType ->
  Remote ConvOrSubConvId ->
  Sem r [LocalConversationUpdate]
postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do
  -- only local users can send messages to remote conversations
  lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr

  unless (bundle.epoch == Epoch 0 && ctype == One2OneConv) $
    -- only members may send commit bundles to a remote conversation
    flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId)

  enableOutOfSyncCheck <- Just <$> input
  resp <-
    runFederated rConvOrSubId $
      fedClient @'Galley @"send-mls-commit-bundle" $
        MLSMessageSendRequest
          { convOrSubId = tUnqualified rConvOrSubId,
            sender = tUnqualified lusr,
            senderClient = c,
            rawMessage = Base64ByteString bundle.serialized,
            enableOutOfSyncCheck
          }
  case resp of
    MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e
    MLSMessageResponseProtocolError e -> throw (mlsProtocolError e)
    MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e)
    MLSMessageResponseUnreachableBackends ds -> throw (UnreachableBackends (toList ds))
    MLSMessageResponseGroupInfoDiagnostics e -> throw e
    MLSMessageResponseOutOfSyncError e -> throw e
    MLSMessageResponseUpdates updates -> do
      fmap fst . runOutputList . runInputConst (void loc) $
        for_ updates $ \update -> do
          me <- updateLocalStateOfRemoteConv (qualifyAs rConvOrSubId update) con
          for_ me $ \e -> output (LocalConversationUpdate e update)
    MLSMessageResponseNonFederatingBackends e -> throw e

postMLSMessage ::
  ( HasProposalEffects r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (ErrorS 'ConvMemberNotFound) r,
    Member (ErrorS 'ConvNotFound) r,
    Member (ErrorS 'MLSNotEnabled) r,
    Member (ErrorS 'MissingLegalholdConsent) r,
    Member (ErrorS 'MLSClientSenderUserMismatch) r,
    Member (ErrorS 'MLSCommitMissingReferences) r,
    Member (ErrorS 'MLSProposalNotFound) r,
    Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSUnsupportedMessage) r,
    Member (ErrorS 'MLSSubConvClientNotInParent) r,
    Member (ErrorS MLSInvalidLeafNodeSignature) r,
    Member (Error MLSOutOfSyncError) r,
    Member (Error GroupInfoDiagnostics) r,
    Member (ErrorS MLSHistoryClientConflict) r,
    Member (ErrorS MLSHistoryClientDuplication) r
  ) =>
  Local x ->
  Qualified UserId ->
  ClientId ->
  ConvType ->
  Qualified ConvOrSubConvId ->
  Maybe ConnId ->
  EnableOutOfSyncCheck ->
  IncomingMessage ->
  Sem r [LocalConversationUpdate]
postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg = do
  runInputConst oosCheck $
    foldQualified
      loc
      (postMLSMessageToLocalConv qusr c con msg ctype)
      (postMLSMessageToRemoteConv loc qusr c con msg)
      qconvOrSub

getSenderIdentity ::
  ( Member (ErrorS 'MLSClientSenderUserMismatch) r,
    Member (Error MLSProtocolError) r
  ) =>
  Qualified UserId ->
  ClientId ->
  Sender ->
  Local ConvOrSubConv ->
  Sem r SenderIdentity
getSenderIdentity qusr c mSender lConvOrSubConv = do
  let cid = mkClientIdentity qusr c
  let epoch = epochNumber . cnvmlsEpoch . (.mlsMeta) . tUnqualified $ lConvOrSubConv
  index <- case mSender of
    SenderMember idx -> do
      when (epoch > 0) $ do
        cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup (tUnqualified lConvOrSubConv).indexMap idx
        unless (cid' == RegularClient cid) $ throwS @'MLSClientSenderUserMismatch
      pure (Just idx)
    _ -> pure Nothing
  pure SenderIdentity {client = cid, index}

postMLSMessageToLocalConv ::
  ( HasProposalEffects r,
    Member (ErrorS 'ConvNotFound) r,
    Member (ErrorS 'MLSClientSenderUserMismatch) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSUnsupportedMessage) r,
    Member (Error MLSOutOfSyncError) r,
    Member (ErrorS MLSInvalidLeafNodeSignature) r,
    Member (Input EnableOutOfSyncCheck) r,
    Member (ErrorS MLSHistoryClientConflict) r
  ) =>
  Qualified UserId ->
  ClientId ->
  Maybe ConnId ->
  IncomingMessage ->
  ConvType ->
  Local ConvOrSubConvId ->
  Sem r [LocalConversationUpdate]
postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do
  lConvOrSub <- fetchConvOrSub qusr msg.groupId ctype convOrSubId
  validateMessage qusr c lConvOrSub Nothing msg

  propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members
  pure []

validateMessage ::
  ( HasProposalEffects r,
    Member (ErrorS ConvNotFound) r,
    Member (ErrorS MLSClientSenderUserMismatch) r,
    Member (ErrorS MLSStaleMessage) r,
    Member (ErrorS MLSUnsupportedMessage) r,
    Member (Error MLSOutOfSyncError) r,
    Member (ErrorS MLSInvalidLeafNodeSignature) r,
    Member (Input EnableOutOfSyncCheck) r,
    Member (ErrorS MLSHistoryClientConflict) r
  ) =>
  Qualified UserId ->
  ClientId ->
  Local ConvOrSubConv ->
  Maybe Epoch ->
  IncomingMessage ->
  Sem r ()
validateMessage qusr c lConvOrSub mEpoch msg = do
  let convOrSub = tUnqualified lConvOrSub
  for_ msg.sender $ \sender ->
    void $ getSenderIdentity qusr c sender lConvOrSub

  -- validate message
  case msg.content of
    IncomingMessageContentPublic pub -> case pub.content of
      FramedContentCommit _commit -> throwS @'MLSUnsupportedMessage
      FramedContentApplicationData _ -> throwS @'MLSUnsupportedMessage
      -- proposal message
      FramedContentProposal prop ->
        processProposal qusr lConvOrSub msg.groupId msg.epoch pub prop
    IncomingMessageContentPrivate -> do
      -- application message:

      -- reject all application messages if the conv is in mixed state
      when (convOrSub.migrationState == MLSMigrationMixed) $
        throwS @'MLSUnsupportedMessage

      -- reject message if the conversation is out of sync
      for_ convOrSub.ciphersuite $ \ciphersuite -> do
        checkConversationOutOfSync mempty lConvOrSub ciphersuite

      -- reject application messages for epoch 0
      let epochInt :: Epoch -> Integer
          epochInt = fromIntegral . epochNumber

      when (epochInt msg.epoch == 0) . throw $
        mlsProtocolError "Application messages at epoch 0 are not supported"

      -- reject application messages older than 2 epochs
      let mEpoch' = mEpoch <|> fmap (.epoch) convOrSub.mlsMeta.cnvmlsActiveData
      case mEpoch' of
        Nothing -> throw $ mlsProtocolError "Application messages at epoch 0 are not supported"
        Just epoch ->
          when
            ( epochInt msg.epoch < epochInt epoch - 2
                || epochInt msg.epoch > epochInt epoch
            )
            $ throwS @'MLSStaleMessage

      case convOrSub of
        Conv _ -> do
          -- once an admin toggles history sharing, every subsequent application message will be rejected
          -- until a commit that adds or removes the history client is processed.
          let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory
          let historyClientExists = any isHistoryClient (IntMap.elems convOrSub.indexMap.unIndexMap)
          when (sharedHistoryEnabled /= historyClientExists) $ throwS @'MLSHistoryClientConflict
        SubConv _ _ -> pure ()

postMLSMessageToRemoteConv ::
  ( Members MLSMessageStaticErrors r,
    HasProposalEffects r,
    Member (Error GroupInfoDiagnostics) r,
    Member (Error MLSOutOfSyncError) r,
    Member (Input EnableOutOfSyncCheck) r
  ) =>
  Local x ->
  Qualified UserId ->
  ClientId ->
  Maybe ConnId ->
  IncomingMessage ->
  Remote ConvOrSubConvId ->
  Sem r [LocalConversationUpdate]
postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do
  -- only local users can send messages to remote conversations
  lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr
  -- only members may send messages to the remote conversation
  flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId)

  enableOutOfSyncCheck <- Just <$> input
  resp <-
    runFederated rConvOrSubId $
      fedClient @'Galley @"send-mls-message" $
        MLSMessageSendRequest
          { convOrSubId = tUnqualified rConvOrSubId,
            sender = tUnqualified lusr,
            senderClient = senderClient,
            rawMessage = Base64ByteString msg.rawMessage.raw,
            enableOutOfSyncCheck
          }
  case resp of
    MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e
    MLSMessageResponseProtocolError e ->
      throw (mlsProtocolError e)
    MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e)
    MLSMessageResponseUnreachableBackends ds ->
      throw . InternalErrorWithDescription $
        "An application or proposal message to a remote conversation should \
        \not ever return a non-empty list of domains a commit could not be \
        \sent to. The remote end returned: "
          <> LT.pack (intercalate ", " (show <$> Set.toList (Set.map domainText ds)))
    MLSMessageResponseUpdates updates -> do
      fmap fst . runOutputList $
        for_ updates $ \update -> do
          me <- updateLocalStateOfRemoteConv (qualifyAs rConvOrSubId update) con
          for_ me $ \e -> output (LocalConversationUpdate e update)
    MLSMessageResponseNonFederatingBackends e -> throw e
    MLSMessageResponseGroupInfoDiagnostics e -> throw e
    MLSMessageResponseOutOfSyncError e -> throw e

storeGroupInfo ::
  (Member ConversationStore r) =>
  ConvOrSubConvId ->
  GroupInfoData ->
  Sem r ()
storeGroupInfo convOrSub ginfo = case convOrSub of
  Conv cid -> setGroupInfo cid (Just ginfo)
  SubConv cid subconvid -> setSubConversationGroupInfo cid subconvid (Just ginfo)

fetchConvOrSub ::
  forall r.
  ( Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r,
    Member (Error MLSProtocolError) r
  ) =>
  Qualified UserId ->
  GroupId ->
  ConvType ->
  Local ConvOrSubConvId ->
  Sem r (Local ConvOrSubConv)
fetchConvOrSub qusr groupId ctype convOrSubId = for convOrSubId $ \case
  Conv convId -> Conv <$> getMLSConv qusr (Just groupId) ctype (qualifyAs convOrSubId convId)
  SubConv convId sconvId -> do
    let lconv = qualifyAs convOrSubId convId
    c <- getMLSConv qusr Nothing ctype lconv
    msubconv <- getSubConversation convId sconvId
    subconv <- case msubconv of
      Nothing -> pure $ newSubConversationFromParent lconv sconvId
      Just subconv -> do
        when (groupId /= subconv.scMLSData.cnvmlsGroupId) $
          throw (mlsProtocolError "The message group ID does not match the subconversation")
        pure subconv
    pure (SubConv c subconv)

getMLSConv ::
  ( Member (ErrorS 'ConvNotFound) r,
    Member (Error MLSProtocolError) r,
    Member ConversationStore r
  ) =>
  Qualified UserId ->
  Maybe GroupId ->
  ConvType ->
  Local ConvId ->
  Sem r MLSConversation
getMLSConv u mGroupId ctype lcnv = do
  mlsConv <- case ctype of
    One2OneConv -> do
      mconv <- getConversation (tUnqualified lcnv)
      case mconv of
        Just conv -> mkMLSConversation conv >>= noteS @'ConvNotFound
        Nothing ->
          let (meta, mlsData) = localMLSOne2OneConversationMetadata (tUntagged lcnv)
           in pure (newMLSConversation lcnv meta mlsData)
    _ ->
      getLocalConvForUser u lcnv
        >>= mkMLSConversation
        >>= noteS @'ConvNotFound
  -- check that the group ID in the message matches that of the conversation
  for_ mGroupId $ \groupId ->
    when (groupId /= mlsConv.mcMLSData.cnvmlsGroupId) $
      throw (mlsProtocolError "The message group ID does not match the conversation")
  pure mlsConv
