{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}

-- 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 Brig.Calling.API
  ( getCallsConfig,
    getCallsConfigV2,
    base26,

    -- * Exposed for testing purposes
    newConfig,
    CallsConfigVersion (..),
    NoTurnServers,
  )
where

import Brig.API.Error
import Brig.API.Handler
import Brig.App
import Brig.Calling
import Brig.Calling qualified as Calling
import Brig.Calling.Internal
import Brig.Options (ListAllSFTServers (..))
import Brig.Options qualified as Opt
import Control.Error (hush, throwE)
import Control.Lens
import Crypto.Hash qualified as Crypto
import Data.ByteArray (convert)
import Data.ByteString qualified as B
import Data.ByteString.Conversion
import Data.ByteString.Lazy qualified as BL
import Data.Id
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Misc (HttpsUrl)
import Data.Range
import Data.Text.Ascii (AsciiBase64, encodeBase64)
import Data.Time.Clock.POSIX
import Data.UUID qualified as UUID
import Imports hiding (head)
import OpenSSL.EVP.Digest (Digest, hmacBS)
import Polysemy
import Polysemy.Error qualified as Polysemy
import System.Logger.Class qualified as Log
import Wire.API.Call.Config qualified as Public
import Wire.API.Team.Feature
import Wire.Error
import Wire.GalleyAPIAccess (GalleyAPIAccess, getAllTeamFeaturesForUser)
import Wire.Network.DNS.SRV (srvTarget)
import Wire.SFT

-- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.)
getCallsConfigV2 ::
  ( Member (Embed IO) r,
    Member SFT r,
    Member GalleyAPIAccess r
  ) =>
  UserId ->
  ConnId ->
  Maybe (Range 1 10 Int) ->
  (Handler r) Public.RTCConfiguration
getCallsConfigV2 uid _ limit = do
  env <- asks (.turnEnv)
  staticUrl <- asks (.settings.sftStaticUrl)
  sftListAllServers <- fromMaybe Opt.HideAllSFTServers <$> asks (.settings.sftListAllServers)
  sftEnv' <- asks (.sftEnv)
  sftFederation <- asks (.enableSFTFederation)
  discoveredServers <- turnServersV2 (env ^. turnServers)
  shared <- do
    ccStatus <- lift $ liftSem $ ((.status) . npProject @ConferenceCallingConfig <$> getAllTeamFeaturesForUser (Just uid))
    pure $ case ccStatus of
      FeatureStatusEnabled -> True
      FeatureStatusDisabled -> False
  eitherConfig <-
    lift
      . liftSem
      . Polysemy.runError
      $ newConfig uid env discoveredServers staticUrl sftEnv' limit sftListAllServers (CallsConfigV2 sftFederation) shared
  handleNoTurnServers eitherConfig

-- | Throws '500 Internal Server Error' when no turn servers are found. This is
-- done to keep backwards compatibility, the previous code initialized an 'IORef'
-- with an 'error' so reading the 'IORef' threw a 500.
--
-- FUTUREWORK: Making this a '404 Not Found' would be more idiomatic, but this
-- should be done after consulting with client teams.
handleNoTurnServers :: Either NoTurnServers a -> (Handler r) a
handleNoTurnServers (Right x) = pure x
handleNoTurnServers (Left NoTurnServers) = do
  Log.err $ Log.msg (Log.val "Call config requested before TURN URIs could be discovered.")
  throwE $ StdError internalServerError

getCallsConfig ::
  ( Member (Embed IO) r,
    Member SFT r,
    Member GalleyAPIAccess r
  ) =>
  UserId ->
  ConnId ->
  (Handler r) Public.RTCConfiguration
getCallsConfig uid _ = do
  env <- asks (.turnEnv)
  discoveredServers <- turnServersV1 (env ^. turnServers)
  shared <- do
    ccStatus <- lift $ liftSem $ ((.status) . npProject @ConferenceCallingConfig <$> getAllTeamFeaturesForUser (Just uid))
    pure $ case ccStatus of
      FeatureStatusEnabled -> True
      FeatureStatusDisabled -> False
  eitherConfig <-
    (dropTransport <$$>)
      . lift
      . liftSem
      . Polysemy.runError
      $ newConfig uid env discoveredServers Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated shared
  handleNoTurnServers eitherConfig
  where
    -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs
    dropTransport :: Public.RTCConfiguration -> Public.RTCConfiguration
    dropTransport =
      set
        (Public.rtcConfIceServers . traverse . Public.iceURLs . traverse . Public.turiTransport)
        Nothing

data CallsConfigVersion
  = CallsConfigDeprecated
  | CallsConfigV2 (Maybe Bool)

data NoTurnServers = NoTurnServers
  deriving (Show)

instance Exception NoTurnServers

-- | FUTUREWORK: It is not reflected in the function type the part of the
-- business logic that says that the SFT static URL parameter cannot be set at
-- the same time as the SFT environment parameter. See how to allow either none
-- to be set or only one of them (perhaps Data.These combined with error
-- handling).
newConfig ::
  ( Member (Embed IO) r,
    Member SFT r,
    Member (Polysemy.Error NoTurnServers) r
  ) =>
  UserId ->
  Calling.TurnEnv ->
  Discovery (NonEmpty Public.TurnURI) ->
  Maybe HttpsUrl ->
  Maybe SFTEnv ->
  Maybe (Range 1 10 Int) ->
  ListAllSFTServers ->
  CallsConfigVersion ->
  Bool ->
  Sem r Public.RTCConfiguration
newConfig uid env discoveredServers sftStaticUrl mSftEnv limit listAllServers version shared = do
  -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set)
  randomizedUris <-
    liftIO . randomize
      =<< Polysemy.note NoTurnServers (discoveryToMaybe discoveredServers)
  let limitedUris = case limit of
        Nothing -> randomizedUris
        Just lim -> limitedList randomizedUris lim
  -- randomize again (as limitedList partially re-orders uris)
  finalUris <- liftIO $ randomize limitedUris
  srvs <- for finalUris $ \uri -> do
    u <- liftIO $ genTurnUsername (env ^. turnTokenTTL)
    pure . Public.rtcIceServer (pure uri) u $ computeCred (env ^. turnSHA512) (env ^. turnSecret) u

  let staticSft = pure . Public.sftServer <$> sftStaticUrl
  allSrvEntries <-
    fmap join $
      for mSftEnv $
        (unSFTServers <$$>) . fmap discoveryToMaybe . readIORef . sftServers
  srvEntries <- fmap join $
    for mSftEnv $ \actualSftEnv -> liftIO $ do
      let subsetLength = Calling.sftListLength actualSftEnv
      mapM (getRandomElements subsetLength) allSrvEntries

  let sftFederation' = case version of
        CallsConfigDeprecated -> Nothing
        CallsConfigV2 fed -> fed

  mSftServersAll <-
    case version of
      CallsConfigDeprecated -> pure Nothing
      CallsConfigV2 _ ->
        case (listAllServers, sftStaticUrl) of
          (HideAllSFTServers, _) -> pure Nothing
          (ListAllSFTServers, Nothing) -> mapM (mapM authenticate) . pure $ sftServerFromSrvTarget . srvTarget <$> maybe [] toList allSrvEntries
          (ListAllSFTServers, Just url) -> mapM (mapM authenticate) . hush . unSFTGetResponse =<< sftGetAllServers url

  let mSftServers = staticSft <|> sftServerFromSrvTarget . srvTarget <$$> srvEntries
  pure $ Public.rtcConfiguration srvs mSftServers (env ^. turnConfigTTL) mSftServersAll sftFederation'
  where
    limitedList :: NonEmpty Public.TurnURI -> Range 1 10 Int -> NonEmpty Public.TurnURI
    limitedList uris lim =
      -- assuming limitServers is safe with respect to the length of its return value
      -- since the input is NonEmpty and limit is in Range 1 10
      -- it should also be safe to assume the returning list has length >= 1
      NonEmpty.nonEmpty (Public.limitServers (NonEmpty.toList uris) (fromRange lim))
        & fromMaybe (error "newConfig:limitedList: empty list of servers")

    hash :: ByteString -> ByteString
    hash = convert . Crypto.hash @ByteString @Crypto.SHA256

    genUsername :: UserId -> Text
    genUsername =
      base26
        . foldr (\x r -> fromIntegral x + r * 256) 0
        . take 16
        . B.unpack
        . hash
        . BL.toStrict
        . UUID.toByteString
        . toUUID

    getTime :: Word32 -> IO POSIXTime
    getTime ttl = fromIntegral . (+ ttl) . round <$> getPOSIXTime

    genTurnUsername :: Word32 -> IO Public.TurnUsername
    genTurnUsername ttl =
      Public.turnUsername
        <$> getTime ttl
        <*> pure (genUsername uid)

    genSFTUsername :: Word32 -> IO Public.SFTUsername
    genSFTUsername ttl =
      Public.mkSFTUsername shared
        <$> getTime ttl
        <*> pure (genUsername uid)

    computeCred :: (ToByteString a) => Digest -> ByteString -> a -> AsciiBase64
    computeCred dig secret = encodeBase64 . hmacBS dig secret . toByteString'

    authenticate ::
      (Member (Embed IO) r) =>
      Public.SFTServer ->
      Sem r Public.AuthSFTServer
    authenticate =
      maybe
        (pure . Public.nauthSFTServer)
        ( \SFTTokenEnv {..} sftsvr -> do
            username <- liftIO $ genSFTUsername sftTokenTTL
            let credential = computeCred sftTokenSHA sftTokenSecret username
            pure $ Public.authSFTServer sftsvr username credential
        )
        (sftToken =<< mSftEnv)
