-- 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.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.Map qualified as Map
import Data.Qualified
import Data.Time
import Imports
import Network.Wai.Utilities.JSONResponse
import Polysemy
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.Client (FederatorClient)
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.API.Push.V2 (RecipientClients (..))
import Wire.ExternalAccess
import Wire.FederationAPIAccess
import Wire.NotificationSubsystem
import Wire.Sem.Now (Now)
import Wire.Sem.Now qualified as Now

sendWelcomes ::
  ( Member (FederationAPIAccess FederatorClient) r,
    Member ExternalAccess r,
    Member P.TinyLog r,
    Member Now r,
    Member NotificationSubsystem r
  ) =>
  Local ConvOrSubConvId ->
  Qualified UserId ->
  Maybe ConnId ->
  [ClientIdentity] ->
  RawMLS Welcome ->
  Sem r ()
sendWelcomes loc qusr con cids welcome = do
  now <- Now.get
  let qcnv = convFrom <$> tUntagged loc
      (locals, remotes) = partitionQualified loc (map cidQualifiedClient cids)
      msg = mkRawMLS $ mkMessage (MessageWelcome welcome)
  sendLocalWelcomes qcnv qusr con now msg (qualifyAs loc locals)
  sendRemoteWelcomes qcnv qusr msg remotes
  where
    convFrom (Conv c) = c
    convFrom (SubConv 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 qcnv qusr con now welcome lclients = do
  -- only create one notification per user
  let rcpts =
        map (\(u, cs) -> Recipient u (RecipientClientsSome cs))
          . Map.assocs
          . foldr
            (\(u, c) -> Map.insertWith (<>) u (pure c))
            mempty
          $ tUnqualified lclients
  let e = Event qcnv Nothing (EventFromUser qusr) now Nothing $ EdMLSWelcome welcome.raw
  runMessagePush lclients (Just qcnv) $
    newMessagePush mempty con defMessageMetadata rcpts e

sendRemoteWelcomes ::
  ( Member (FederationAPIAccess FederatorClient) r,
    Member P.TinyLog r
  ) =>
  Qualified ConvId ->
  Qualified UserId ->
  RawMLS Message ->
  [Remote (UserId, ClientId)] ->
  Sem r ()
sendRemoteWelcomes qcnv qusr welcome clients = do
  let msg = Base64ByteString welcome.raw
  traverse_ handleError <=< runFederatedConcurrentlyEither clients $ \rcpts ->
    fedClient @'Galley @"mls-welcome"
      MLSWelcomeRequest
        { originatingUser = qUnqualified qusr,
          welcomeMessage = msg,
          recipients = tUnqualified rcpts,
          qualifiedConvId = qcnv
        }
  where
    handleError ::
      (Member P.TinyLog r) =>
      Either (Remote [a], FederationError) (Remote MLSWelcomeResponse) ->
      Sem r ()
    handleError (Right x) = case tUnqualified x of
      MLSWelcomeSent -> pure ()
      MLSWelcomeMLSNotEnabled -> logFedError x (errorToResponse @'MLSNotEnabled)
    handleError (Left (r, e)) = logFedError r (toResponse e)

    logFedError :: (Member P.TinyLog r) => Remote x -> JSONResponse -> Sem r ()
    logFedError r e =
      P.warn $
        Logger.msg ("A welcome message could not be delivered to a remote backend" :: ByteString)
          . Logger.field "remote_domain" (domainText (tDomain r))
          . Logger.field "error" (A.encode e.value)
