-- 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.Welcome
  ( sendWelcomes,
    sendLocalWelcomes,
  )
where

import Control.Comonad
import Data.Aeson qualified as A
import Data.Domain
import Data.Id
import Data.Json.Util
import Data.List1
import Data.Map qualified as Map
import Data.Qualified
import Data.Time
import Galley.API.Push
import Galley.Effects.ExternalAccess
import Galley.Effects.FederatorAccess
import Gundeck.Types.Push.V2 (RecipientClients (..))
import Imports
import Network.Wai.Utilities.JSONResponse
import Polysemy
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import System.Logger.Class qualified as Logger
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Event.Conversation
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.Credential
import Wire.API.MLS.Message
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.MLS.Welcome
import Wire.API.Message
import Wire.NotificationSubsystem

sendWelcomes ::
  ( Member FederatorAccess r,
    Member ExternalAccess r,
    Member P.TinyLog r,
    Member (Input UTCTime) r,
    Member NotificationSubsystem r
  ) =>
  Local ConvOrSubConvId ->
  Qualified UserId ->
  Maybe ConnId ->
  [ClientIdentity] ->
  RawMLS Welcome ->
  Sem r ()
sendWelcomes :: forall (r :: EffectRow).
(Member FederatorAccess r, Member ExternalAccess r,
 Member TinyLog r, Member (Input UTCTime) r,
 Member NotificationSubsystem r) =>
Local ConvOrSubConvId
-> Qualified UserId
-> Maybe ConnId
-> [ClientIdentity]
-> RawMLS Welcome
-> Sem r ()
sendWelcomes Local ConvOrSubConvId
loc Qualified UserId
qusr Maybe ConnId
con [ClientIdentity]
cids RawMLS Welcome
welcome = do
  UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  let qcnv :: Qualified ConvId
qcnv = ConvOrSubConvId -> ConvId
forall {c} {s}. ConvOrSubChoice c s -> c
convFrom (ConvOrSubConvId -> ConvId)
-> Qualified ConvOrSubConvId -> Qualified ConvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local ConvOrSubConvId -> Qualified ConvOrSubConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local ConvOrSubConvId
loc
      ([(UserId, ClientId)]
locals, [Remote (UserId, ClientId)]
remotes) = Local ConvOrSubConvId
-> [Qualified (UserId, ClientId)]
-> ([(UserId, ClientId)], [Remote (UserId, ClientId)])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local ConvOrSubConvId
loc ((ClientIdentity -> Qualified (UserId, ClientId))
-> [ClientIdentity] -> [Qualified (UserId, ClientId)]
forall a b. (a -> b) -> [a] -> [b]
map ClientIdentity -> Qualified (UserId, ClientId)
cidQualifiedClient [ClientIdentity]
cids)
      msg :: RawMLS Message
msg = Message -> RawMLS Message
forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS (Message -> RawMLS Message) -> Message -> RawMLS Message
forall a b. (a -> b) -> a -> b
$ MessageContent -> Message
mkMessage (RawMLS Welcome -> MessageContent
MessageWelcome RawMLS Welcome
welcome)
  Qualified ConvId
-> Qualified UserId
-> Maybe ConnId
-> UTCTime
-> RawMLS Message
-> Local [(UserId, ClientId)]
-> Sem r ()
forall (r :: EffectRow).
(Member TinyLog r, Member ExternalAccess r,
 Member NotificationSubsystem r) =>
Qualified ConvId
-> Qualified UserId
-> Maybe ConnId
-> UTCTime
-> RawMLS Message
-> Local [(UserId, ClientId)]
-> Sem r ()
sendLocalWelcomes Qualified ConvId
qcnv Qualified UserId
qusr Maybe ConnId
con UTCTime
now RawMLS Message
msg (Local ConvOrSubConvId
-> [(UserId, ClientId)] -> Local [(UserId, ClientId)]
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvOrSubConvId
loc [(UserId, ClientId)]
locals)
  Qualified ConvId
-> Qualified UserId
-> RawMLS Message
-> [Remote (UserId, ClientId)]
-> Sem r ()
forall (r :: EffectRow).
(Member FederatorAccess r, Member TinyLog r) =>
Qualified ConvId
-> Qualified UserId
-> RawMLS Message
-> [Remote (UserId, ClientId)]
-> Sem r ()
sendRemoteWelcomes Qualified ConvId
qcnv Qualified UserId
qusr RawMLS Message
msg [Remote (UserId, ClientId)]
remotes
  where
    convFrom :: ConvOrSubChoice c s -> c
convFrom (Conv c
c) = c
c
    convFrom (SubConv c
c s
_) = c
c

sendLocalWelcomes ::
  ( Member P.TinyLog r,
    Member ExternalAccess r,
    Member NotificationSubsystem r
  ) =>
  Qualified ConvId ->
  Qualified UserId ->
  Maybe ConnId ->
  UTCTime ->
  RawMLS Message ->
  Local [(UserId, ClientId)] ->
  Sem r ()
sendLocalWelcomes :: forall (r :: EffectRow).
(Member TinyLog r, Member ExternalAccess r,
 Member NotificationSubsystem r) =>
Qualified ConvId
-> Qualified UserId
-> Maybe ConnId
-> UTCTime
-> RawMLS Message
-> Local [(UserId, ClientId)]
-> Sem r ()
sendLocalWelcomes Qualified ConvId
qcnv Qualified UserId
qusr Maybe ConnId
con UTCTime
now RawMLS Message
welcome Local [(UserId, ClientId)]
lclients = do
  -- only create one notification per user
  let rcpts :: [Recipient]
rcpts =
        ((UserId, NonEmpty ClientId) -> Recipient)
-> [(UserId, NonEmpty ClientId)] -> [Recipient]
forall a b. (a -> b) -> [a] -> [b]
map (\(UserId
u, NonEmpty ClientId
cs) -> UserId -> RecipientClients -> Recipient
Recipient UserId
u (List1 ClientId -> RecipientClients
RecipientClientsSome (NonEmpty ClientId -> List1 ClientId
forall a. NonEmpty a -> List1 a
List1 NonEmpty ClientId
cs)))
          ([(UserId, NonEmpty ClientId)] -> [Recipient])
-> ([(UserId, ClientId)] -> [(UserId, NonEmpty ClientId)])
-> [(UserId, ClientId)]
-> [Recipient]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (NonEmpty ClientId) -> [(UserId, NonEmpty ClientId)]
forall k a. Map k a -> [(k, a)]
Map.assocs
          (Map UserId (NonEmpty ClientId) -> [(UserId, NonEmpty ClientId)])
-> ([(UserId, ClientId)] -> Map UserId (NonEmpty ClientId))
-> [(UserId, ClientId)]
-> [(UserId, NonEmpty ClientId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserId, ClientId)
 -> Map UserId (NonEmpty ClientId)
 -> Map UserId (NonEmpty ClientId))
-> Map UserId (NonEmpty ClientId)
-> [(UserId, ClientId)]
-> Map UserId (NonEmpty ClientId)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\(UserId
u, ClientId
c) -> (NonEmpty ClientId -> NonEmpty ClientId -> NonEmpty ClientId)
-> UserId
-> NonEmpty ClientId
-> Map UserId (NonEmpty ClientId)
-> Map UserId (NonEmpty ClientId)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NonEmpty ClientId -> NonEmpty ClientId -> NonEmpty ClientId
forall a. Semigroup a => a -> a -> a
(<>) UserId
u (ClientId -> NonEmpty ClientId
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientId
c))
            Map UserId (NonEmpty ClientId)
forall a. Monoid a => a
mempty
          ([(UserId, ClientId)] -> [Recipient])
-> [(UserId, ClientId)] -> [Recipient]
forall a b. (a -> b) -> a -> b
$ Local [(UserId, ClientId)] -> [(UserId, ClientId)]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local [(UserId, ClientId)]
lclients
  let e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
qcnv Maybe SubConvId
forall a. Maybe a
Nothing Qualified UserId
qusr UTCTime
now (EventData -> Event) -> EventData -> Event
forall a b. (a -> b) -> a -> b
$ ByteString -> EventData
EdMLSWelcome RawMLS Message
welcome.raw
  Local [(UserId, ClientId)]
-> Maybe (Qualified ConvId) -> MessagePush -> Sem r ()
forall x (r :: EffectRow).
(Member ExternalAccess r, Member TinyLog r,
 Member NotificationSubsystem r) =>
Local x -> Maybe (Qualified ConvId) -> MessagePush -> Sem r ()
runMessagePush Local [(UserId, ClientId)]
lclients (Qualified ConvId -> Maybe (Qualified ConvId)
forall a. a -> Maybe a
Just Qualified ConvId
qcnv) (MessagePush -> Sem r ()) -> MessagePush -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    BotMap
-> Maybe ConnId
-> MessageMetadata
-> [Recipient]
-> Event
-> MessagePush
forall r.
ToRecipient r =>
BotMap
-> Maybe ConnId -> MessageMetadata -> [r] -> Event -> MessagePush
newMessagePush BotMap
forall a. Monoid a => a
mempty Maybe ConnId
con MessageMetadata
defMessageMetadata [Recipient]
rcpts Event
e

sendRemoteWelcomes ::
  ( Member FederatorAccess r,
    Member P.TinyLog r
  ) =>
  Qualified ConvId ->
  Qualified UserId ->
  RawMLS Message ->
  [Remote (UserId, ClientId)] ->
  Sem r ()
sendRemoteWelcomes :: forall (r :: EffectRow).
(Member FederatorAccess r, Member TinyLog r) =>
Qualified ConvId
-> Qualified UserId
-> RawMLS Message
-> [Remote (UserId, ClientId)]
-> Sem r ()
sendRemoteWelcomes Qualified ConvId
qcnv Qualified UserId
qusr RawMLS Message
welcome [Remote (UserId, ClientId)]
clients = do
  let msg :: Base64ByteString
msg = ByteString -> Base64ByteString
Base64ByteString RawMLS Message
welcome.raw
  (Either
   (Remote [(UserId, ClientId)], FederationError)
   (Remote MLSWelcomeResponse)
 -> Sem r ())
-> [Either
      (Remote [(UserId, ClientId)], FederationError)
      (Remote MLSWelcomeResponse)]
-> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Either
  (Remote [(UserId, ClientId)], FederationError)
  (Remote MLSWelcomeResponse)
-> Sem r ()
forall (r :: EffectRow) a.
Member TinyLog r =>
Either (Remote [a], FederationError) (Remote MLSWelcomeResponse)
-> Sem r ()
handleError ([Either
    (Remote [(UserId, ClientId)], FederationError)
    (Remote MLSWelcomeResponse)]
 -> Sem r ())
-> ((Remote [(UserId, ClientId)]
     -> FederatorClient 'Galley MLSWelcomeResponse)
    -> Sem
         r
         [Either
            (Remote [(UserId, ClientId)], FederationError)
            (Remote MLSWelcomeResponse)])
-> (Remote [(UserId, ClientId)]
    -> FederatorClient 'Galley MLSWelcomeResponse)
-> Sem r ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Remote (UserId, ClientId)]
-> (Remote [(UserId, ClientId)]
    -> FederatorClient 'Galley MLSWelcomeResponse)
-> Sem
     r
     [Either
        (Remote [(UserId, ClientId)], FederationError)
        (Remote MLSWelcomeResponse)]
forall (r :: EffectRow) (c :: Component) (f :: * -> *) x a.
(Member FederatorAccess r, KnownComponent c, Foldable f,
 Functor f) =>
f (Remote x)
-> (Remote [x] -> FederatorClient c a)
-> Sem r [Either (Remote [x], FederationError) (Remote a)]
runFederatedConcurrentlyEither [Remote (UserId, ClientId)]
clients ((Remote [(UserId, ClientId)]
  -> FederatorClient 'Galley MLSWelcomeResponse)
 -> Sem r ())
-> (Remote [(UserId, ClientId)]
    -> FederatorClient 'Galley MLSWelcomeResponse)
-> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Remote [(UserId, ClientId)]
rcpts ->
    forall {k} (comp :: Component) (name :: k)
       (fedM :: Component -> * -> *) (showcomp :: Symbol) api x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
 HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
 FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
       (fedM :: Component -> * -> *) (showcomp :: Symbol) api x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
 HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
 FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Galley @"mls-welcome"
      MLSWelcomeRequest
        { $sel:originatingUser:MLSWelcomeRequest :: UserId
originatingUser = Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
qusr,
          $sel:welcomeMessage:MLSWelcomeRequest :: Base64ByteString
welcomeMessage = Base64ByteString
msg,
          $sel:recipients:MLSWelcomeRequest :: [(UserId, ClientId)]
recipients = Remote [(UserId, ClientId)] -> [(UserId, ClientId)]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [(UserId, ClientId)]
rcpts,
          $sel:qualifiedConvId:MLSWelcomeRequest :: Qualified ConvId
qualifiedConvId = Qualified ConvId
qcnv
        }
  where
    handleError ::
      (Member P.TinyLog r) =>
      Either (Remote [a], FederationError) (Remote MLSWelcomeResponse) ->
      Sem r ()
    handleError :: forall (r :: EffectRow) a.
Member TinyLog r =>
Either (Remote [a], FederationError) (Remote MLSWelcomeResponse)
-> Sem r ()
handleError (Right Remote MLSWelcomeResponse
x) = case Remote MLSWelcomeResponse -> MLSWelcomeResponse
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote MLSWelcomeResponse
x of
      MLSWelcomeResponse
MLSWelcomeSent -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      MLSWelcomeResponse
MLSWelcomeMLSNotEnabled -> Remote MLSWelcomeResponse -> JSONResponse -> Sem r ()
forall (r :: EffectRow) x.
Member TinyLog r =>
Remote x -> JSONResponse -> Sem r ()
logFedError Remote MLSWelcomeResponse
x (forall {k} (e :: k). KnownError (MapError e) => JSONResponse
forall (e :: GalleyError). KnownError (MapError e) => JSONResponse
errorToResponse @'MLSNotEnabled)
    handleError (Left (Remote [a]
r, FederationError
e)) = Remote [a] -> JSONResponse -> Sem r ()
forall (r :: EffectRow) x.
Member TinyLog r =>
Remote x -> JSONResponse -> Sem r ()
logFedError Remote [a]
r (FederationError -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse FederationError
e)

    logFedError :: (Member P.TinyLog r) => Remote x -> JSONResponse -> Sem r ()
    logFedError :: forall (r :: EffectRow) x.
Member TinyLog r =>
Remote x -> JSONResponse -> Sem r ()
logFedError Remote x
r JSONResponse
e =
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.warn ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        ByteString -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Logger.msg (ByteString
"A welcome message could not be delivered to a remote backend" :: ByteString)
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Logger.field ByteString
"remote_domain" (Domain -> Text
domainText (Remote x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote x
r))
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Logger.field ByteString
"error" (Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode JSONResponse
e.value)