{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

-- 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.API.Call.Config
  ( -- * RTCConfiguration
    RTCConfiguration,
    rtcConfiguration,
    rtcConfIceServers,
    rtcConfSftServers,
    rtcConfSftServersAll,
    rtcConfTTL,
    rtcConfIsFederating,

    -- * RTCIceServer
    RTCIceServer,
    rtcIceServer,
    iceURLs,
    iceUsername,
    iceCredential,

    -- * TurnURI
    TurnURI,
    turnURI,
    turiScheme,
    Scheme (..),
    turiHost,
    turiPort,
    turiTransport,
    Transport (..),
    TurnHost (..),

    -- * SFTUsername
    SFTUsername,
    mkSFTUsername,

    -- * TurnUsername
    TurnUsername,
    turnUsername,
    tuExpiresAt,
    tuVersion,
    tuKeyindex,
    tuT,
    tuRandom,

    -- * SFTServer
    SFTServer,
    sftServer,
    sftURL,

    -- * AuthSFTServer
    AuthSFTServer,
    authSFTServer,
    nauthSFTServer,
    authURL,
    authUsername,
    authCredential,

    -- * convenience
    isUdp,
    isTcp,
    isTls,
    limitServers,
  )
where

import Control.Applicative (optional)
import Control.Lens hiding (element, enum, (.=))
import Data.Aeson qualified as A hiding ((<?>))
import Data.Aeson.Types qualified as A
import Data.Attoparsec.Text hiding (Parser, parse)
import Data.Attoparsec.Text qualified as Text
import Data.ByteString (toStrict)
import Data.ByteString.Builder
import Data.ByteString.Conversion (toByteString)
import Data.ByteString.Conversion qualified as BC
import Data.IP qualified as IP
import Data.List.NonEmpty (NonEmpty)
import Data.Misc (HttpsUrl (..), IpAddr (IpAddr), Port (..))
import Data.OpenApi qualified as S
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Ascii
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error
import Data.Text.Strict.Lens (utf8)
import Data.Time.Clock.POSIX
import Imports
import Test.QuickCheck qualified as QC
import Text.Hostname (validHostname)
import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))

--------------------------------------------------------------------------------
-- RTCConfiguration

-- | A configuration object resembling \"RTCConfiguration\"
--
-- The \"ttl\" field is a proprietary extension
-- The \"sft_servers\" field is a proprietary extension
--
-- cf. https://developer.mozilla.org/en-US/docs/Web/API/RTCPeerConnection/RTCPeerConnection#RTCConfiguration_dictionary
data RTCConfiguration = RTCConfiguration
  { _rtcConfIceServers :: NonEmpty RTCIceServer,
    _rtcConfSftServers :: Maybe (NonEmpty SFTServer),
    _rtcConfTTL :: Word32,
    _rtcConfSftServersAll :: Maybe [AuthSFTServer],
    _rtcConfIsFederating :: Maybe Bool
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform RTCConfiguration)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RTCConfiguration)

rtcConfiguration ::
  NonEmpty RTCIceServer ->
  Maybe (NonEmpty SFTServer) ->
  Word32 ->
  Maybe [AuthSFTServer] ->
  Maybe Bool ->
  RTCConfiguration
rtcConfiguration = RTCConfiguration

instance ToSchema RTCConfiguration where
  schema =
    objectWithDocModifier (description ?~ "A subset of the WebRTC 'RTCConfiguration' dictionary") $
      RTCConfiguration
        <$> _rtcConfIceServers
          .= fieldWithDocModifier "ice_servers" (description ?~ "Array of 'RTCIceServer' objects") (nonEmptyArray schema)
        <*> _rtcConfSftServers
          .= maybe_ (optFieldWithDocModifier "sft_servers" (description ?~ "Array of 'SFTServer' objects (optional)") (nonEmptyArray schema))
        <*> _rtcConfTTL
          .= fieldWithDocModifier "ttl" (description ?~ "Number of seconds after which the configuration should be refreshed (advisory)") schema
        <*> _rtcConfSftServersAll
          .= maybe_ (optFieldWithDocModifier "sft_servers_all" (description ?~ "Array of all SFT servers") (array schema))
        <*> _rtcConfIsFederating
          .= maybe_ (optFieldWithDocModifier "is_federating" (description ?~ "True if the client should connect to an SFT in the sft_servers_all and request it to federate") schema)

--------------------------------------------------------------------------------
-- SFTServer

newtype SFTServer = SFTServer
  { _sftURL :: HttpsUrl
  }
  deriving stock (Eq, Show, Ord, Generic)
  deriving (Arbitrary) via (GenericUniform SFTServer)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema SFTServer)

instance ToSchema SFTServer where
  schema =
    objectWithDocModifier (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $
      SFTServer
        <$> (pure . _sftURL)
          .= fieldWithDocModifier "urls" (description ?~ "Array containing exactly one SFT server address of the form 'https://<addr>:<port>'") (withParser (array schema) p)
    where
      p :: [HttpsUrl] -> A.Parser HttpsUrl
      p [url] = pure url
      p xs = fail $ "SFTServer can only have exactly one URL, found " <> show (length xs)

sftServer :: HttpsUrl -> SFTServer
sftServer = SFTServer

--------------------------------------------------------------------------------
-- AuthSFTServer

data AuthSFTServer = AuthSFTServer
  { _authURL :: HttpsUrl,
    _authUsername :: Maybe SFTUsername,
    _authCredential :: Maybe AsciiBase64
  }
  deriving stock (Eq, Show, Ord, Generic)
  deriving (Arbitrary) via (GenericUniform AuthSFTServer)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema AuthSFTServer)

instance ToSchema AuthSFTServer where
  schema =
    objectWithDocModifier (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $
      AuthSFTServer
        <$> (pure . _authURL)
          .= fieldWithDocModifier "urls" (description ?~ "Array containing exactly one SFT server address of the form 'https://<addr>:<port>'") (withParser (array schema) p)
        <*> _authUsername
          .= maybe_ (optFieldWithDocModifier "username" (description ?~ "String containing the SFT username") schema)
        <*> _authCredential
          .= maybe_ (optFieldWithDocModifier "credential" (description ?~ "String containing the SFT credential") schema)
    where
      p :: [HttpsUrl] -> A.Parser HttpsUrl
      p [url] = pure url
      p xs = fail $ "SFTServer can only have exactly one URL, found " <> show (length xs)

nauthSFTServer :: SFTServer -> AuthSFTServer
nauthSFTServer = (\u -> AuthSFTServer u Nothing Nothing) . _sftURL

authSFTServer :: SFTServer -> SFTUsername -> AsciiBase64 -> AuthSFTServer
authSFTServer svr u = AuthSFTServer (_sftURL svr) (Just u) . Just

--------------------------------------------------------------------------------
-- RTCIceServer

-- | A configuration object resembling \"RTCIceServer\"
--
-- cf. https://developer.mozilla.org/en-US/docs/Web/API/RTCIceServer
data RTCIceServer = RTCIceServer
  { _iceURLs :: NonEmpty TurnURI,
    _iceUsername :: TurnUsername,
    _iceCredential :: AsciiBase64
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform RTCIceServer)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RTCIceServer)

rtcIceServer :: NonEmpty TurnURI -> TurnUsername -> AsciiBase64 -> RTCIceServer
rtcIceServer = RTCIceServer

instance ToSchema RTCIceServer where
  schema =
    objectWithDocModifier (description ?~ "A subset of the WebRTC 'RTCIceServer' object") $
      RTCIceServer
        <$> _iceURLs
          .= fieldWithDocModifier "urls" (description ?~ "Array of TURN server addresses of the form 'turn:<addr>:<port>'") (nonEmptyArray schema)
        <*> _iceUsername
          .= fieldWithDocModifier "username" (description ?~ "Username to use for authenticating against the given TURN servers") schema
        <*> _iceCredential
          .= fieldWithDocModifier "credential" (description ?~ "Password to use for authenticating against the given TURN servers") schema

--------------------------------------------------------------------------------
-- TurnURI

-- | TURN server URI as described in https://tools.ietf.org/html/rfc7065, minus ext
-- |
-- | turnURI       = scheme ":" host [ ":" port ]
-- |                 [ "?transport=" transport ]
-- | scheme        = "turn" / "turns"
-- | transport     = "udp" / "tcp" / transport-ext
-- | transport-ext = 1*unreserved
--
-- FUTUREWORK: Can contain, but refuses to deserialize IPv6 hosts, see 'parseTurnURI'
-- and the 'Arbitrary' instance. Please fix this.
data TurnURI = TurnURI
  { _turiScheme :: Scheme,
    _turiHost :: TurnHost,
    _turiPort :: Port,
    _turiTransport :: Maybe Transport
  }
  deriving stock (Eq, Show, Ord, Generic)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnURI)

instance ToSchema TurnURI where
  schema =
    (TE.decodeUtf8With lenientDecode . toStrict . toByteString)
      .= parsedText "TurnURI" parseTurnURI

turnURI :: Scheme -> TurnHost -> Port -> Maybe Transport -> TurnURI
turnURI = TurnURI

instance BC.ToByteString TurnURI where
  builder (TurnURI s h (Port p) tp) =
    BC.builder s
      <> byteString ":"
      <> BC.builder h
      <> byteString ":"
      <> BC.builder p
      <> foldMap ((byteString "?transport=" <>) . BC.builder) tp

instance BC.FromByteString TurnURI where
  parser = BC.parser >>= either fail pure . parseTurnURI

parseTurnURI :: Text -> Either String TurnURI
parseTurnURI = parseOnly (parser <* endOfInput)
  where
    parser =
      TurnURI
        <$> ((takeWhile1 (/= ':') <* char ':' >>= parseScheme) <?> "parsingScheme")
        <*> ((takeWhile1 (/= ':') <* char ':' >>= parseHost) <?> "parsingHost")
        <*> (decimal <?> "parsingPort")
        <*> (optional ((string "?transport=" *> takeText) >>= parseTransport) <?> "parsingTransport")
    parseScheme = parse "parseScheme"
    parseHost = parse "parseHost"
    parseTransport = parse "parseTransport"
    parse :: (BC.FromByteString b, MonadFail m) => String -> Text -> m b
    parse err x = case BC.fromByteString (TE.encodeUtf8 x) of
      Just ok -> pure ok
      Nothing -> fail (err ++ " failed when parsing: " ++ show x)

instance Arbitrary TurnURI where
  arbitrary = (getGenericUniform <$> arbitrary) `QC.suchThat` (not . isIPv6)
    where
      isIPv6 h = case _turiHost h of
        TurnHostIp (IpAddr (IP.IPv6 _)) -> True
        _ -> False

data Scheme
  = SchemeTurn
  | SchemeTurns
  deriving stock (Eq, Show, Ord, Generic)
  deriving (Arbitrary) via (GenericUniform Scheme)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Scheme)

instance BC.ToByteString Scheme where
  builder SchemeTurn = "turn"
  builder SchemeTurns = "turns"

instance BC.FromByteString Scheme where
  parser =
    BC.parser >>= \t -> case (t :: ByteString) of
      "turn" -> pure SchemeTurn
      "turns" -> pure SchemeTurns
      _ -> fail $ "Invalid turn scheme: " ++ show t

instance ToSchema Scheme where
  schema =
    enum @Text $
      mconcat
        [ element "turn" SchemeTurn,
          element "turns" SchemeTurns
        ]

data TurnHost
  = TurnHostIp IpAddr
  | TurnHostName Text
  deriving stock (Eq, Show, Ord, Generic)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnHost)

instance ToSchema TurnHost where
  schema = turnHostSchema

data TurnHostTag = TurnHostIpTag | TurnHostNameTag
  deriving (Eq, Enum, Bounded)

tagSchema :: ValueSchema NamedSwaggerDoc TurnHostTag
tagSchema =
  enum @Text $
    mconcat
      [ element "TurnHostIp" TurnHostIpTag,
        element "TurnHostName" TurnHostNameTag
      ]

turnHostSchema :: ValueSchema NamedSwaggerDoc TurnHost
turnHostSchema =
  object $
    fromTagged
      <$> toTagged
        .= bind
          (fst .= field "tag" tagSchema)
          (snd .= fieldOver _1 "contents" untaggedSchema)
  where
    toTagged :: TurnHost -> (TurnHostTag, TurnHost)
    toTagged d@(TurnHostIp _) = (TurnHostIpTag, d)
    toTagged d@(TurnHostName _) = (TurnHostNameTag, d)

    fromTagged :: (TurnHostTag, TurnHost) -> TurnHost
    fromTagged = snd

    untaggedSchema = dispatch $ \case
      TurnHostIpTag -> tag _TurnHostIp (unnamed schema)
      TurnHostNameTag -> tag _TurnHostName (unnamed schema)

    _TurnHostIp :: Prism' TurnHost IpAddr
    _TurnHostIp = prism' TurnHostIp $ \case
      TurnHostIp a -> Just a
      _ -> Nothing

    _TurnHostName :: Prism' TurnHost Text
    _TurnHostName = prism' TurnHostName $ \case
      TurnHostName b -> Just b
      _ -> Nothing

instance BC.FromByteString TurnHost where
  parser = BC.parser >>= maybe (fail "Invalid turn host") pure . parseTurnHost

instance BC.ToByteString TurnHost where
  builder (TurnHostIp ip) = BC.builder ip
  builder (TurnHostName n) = BC.builder n

instance Arbitrary TurnHost where
  arbitrary =
    QC.oneof
      [ TurnHostIp <$> arbitrary,
        TurnHostName <$> genHostName
      ]
    where
      -- values that should fulfill 'validHostname'
      genHostName =
        QC.elements
          [ "host.name",
            "a-c",
            "123",
            "007.com",
            "xn--mgbh0fb.xn--kgbechtv"
          ]

parseTurnHost :: Text -> Maybe TurnHost
parseTurnHost h = case BC.fromByteString host of
  Just ip@(IpAddr _) -> Just $ TurnHostIp ip
  Nothing | validHostname host -> Just $ TurnHostName h -- NOTE: IP addresses are also valid hostnames
  _ -> Nothing
  where
    host = TE.encodeUtf8 h

data Transport
  = TransportUDP
  | TransportTCP
  deriving stock (Eq, Show, Ord, Generic)
  deriving (Arbitrary) via (GenericUniform Transport)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Transport)

instance BC.ToByteString Transport where
  builder TransportUDP = "udp"
  builder TransportTCP = "tcp"

instance BC.FromByteString Transport where
  parser =
    BC.parser >>= \t -> case (t :: ByteString) of
      "udp" -> pure TransportUDP
      "tcp" -> pure TransportTCP
      _ -> fail $ "Invalid turn transport: " ++ show t

instance ToSchema Transport where
  schema =
    enum @Text $
      mconcat
        [ element "udp" TransportUDP,
          element "tcp" TransportTCP
        ]

--------------------------------------------------------------------------------
-- SFTUsername

data SFTUsername = SFTUsername
  { -- | must be positive, integral number of seconds
    _suExpiresAt :: POSIXTime,
    _suVersion :: Word,
    -- | seems to large, but uint32_t is used in C
    _suKeyindex :: Word32,
    -- | whether the user is allowed to initialise an SFT conference
    _suShared :: Bool,
    -- | [a-z0-9]+
    _suRandom :: Text
  }
  deriving stock (Eq, Ord, Show, Generic)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema SFTUsername)

-- note that the random value is not checked for well-formedness
mkSFTUsername :: Bool -> POSIXTime -> Text -> SFTUsername
mkSFTUsername shared expires rnd =
  SFTUsername
    { _suExpiresAt = expires,
      _suVersion = 1,
      _suKeyindex = 0,
      _suShared = shared,
      _suRandom = rnd
    }

instance ToSchema SFTUsername where
  schema = toText .= parsedText "SFTUsername" fromText
    where
      fromText :: Text -> Either String SFTUsername
      fromText = parseOnly (parseSFTUsername <* endOfInput)

      toText :: SFTUsername -> Text
      toText = TE.decodeUtf8With lenientDecode . toStrict . toByteString

instance BC.ToByteString SFTUsername where
  builder su =
    shortByteString "d="
      <> word64Dec (round (_suExpiresAt su))
      <> shortByteString ".v="
      <> wordDec (_suVersion su)
      <> shortByteString ".k="
      <> word32Dec (_suKeyindex su)
      <> shortByteString ".s="
      <> wordDec (boolToWord $ _suShared su)
      <> shortByteString ".r="
      <> byteString (view (re utf8) (_suRandom su))
    where
      boolToWord :: (Num a) => Bool -> a
      boolToWord False = 0
      boolToWord True = 1

parseSFTUsername :: Text.Parser SFTUsername
parseSFTUsername =
  SFTUsername
    <$> (string "d=" *> fmap (fromIntegral :: Word64 -> POSIXTime) decimal)
    <*> (string ".v=" *> decimal)
    <*> (string ".k=" *> decimal)
    <*> (string ".s=" *> (wordToBool <$> decimal))
    <*> (string ".r=" *> takeWhile1 (inClass "a-z0-9"))
  where
    wordToBool :: Word -> Bool
    wordToBool = odd

instance Arbitrary SFTUsername where
  arbitrary =
    SFTUsername
      <$> (fromIntegral <$> arbitrary @Word64)
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> (Text.pack <$> QC.listOf1 genAlphaNum)
    where
      genAlphaNum = QC.elements $ ['a' .. 'z'] <> ['0' .. '9']

--------------------------------------------------------------------------------
-- TurnUsername

data TurnUsername = TurnUsername
  { -- | must be positive, integral number of seconds
    _tuExpiresAt :: POSIXTime,
    _tuVersion :: Word,
    -- | seems to large, but uint32_t is used in C
    _tuKeyindex :: Word32,
    -- | undocumented, always 's'
    _tuT :: Char,
    -- | [a-z0-9]+
    _tuRandom :: Text
  }
  deriving stock (Eq, Show, Generic)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TurnUsername)

-- note that the random value is not checked for well-formedness
turnUsername :: POSIXTime -> Text -> TurnUsername
turnUsername expires rnd =
  TurnUsername
    { _tuExpiresAt = expires,
      _tuVersion = 1,
      _tuKeyindex = 0,
      _tuT = 's',
      _tuRandom = rnd
    }

instance ToSchema TurnUsername where
  schema = toText .= parsedText "TurnUsername" fromText
    where
      fromText :: Text -> Either String TurnUsername
      fromText = parseOnly (parseTurnUsername <* endOfInput)

      toText :: TurnUsername -> Text
      toText = TE.decodeUtf8With lenientDecode . toStrict . toByteString

instance BC.ToByteString TurnUsername where
  builder tu =
    shortByteString "d="
      <> word64Dec (round (_tuExpiresAt tu))
      <> shortByteString ".v="
      <> wordDec (_tuVersion tu)
      <> shortByteString ".k="
      <> word32Dec (_tuKeyindex tu)
      <> shortByteString ".t="
      <> charUtf8 (_tuT tu)
      <> shortByteString ".r="
      <> byteString (view (re utf8) (_tuRandom tu))

parseTurnUsername :: Text.Parser TurnUsername
parseTurnUsername =
  TurnUsername
    <$> (string "d=" *> fmap (fromIntegral :: Word64 -> POSIXTime) decimal)
    <*> (string ".v=" *> decimal)
    <*> (string ".k=" *> decimal)
    <*> (string ".t=" *> anyChar)
    <*> (string ".r=" *> takeWhile1 (inClass "a-z0-9"))

instance Arbitrary TurnUsername where
  arbitrary =
    TurnUsername
      <$> (fromIntegral <$> arbitrary @Word64)
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> (Text.pack <$> QC.listOf1 genAlphaNum)
    where
      genAlphaNum = QC.elements $ ['a' .. 'z'] <> ['0' .. '9']

--------------------------------------------------------------------------------
-- convenience

-- | given a list of URIs and a size, limit URIs
-- with order priority from highest to lowest: UDP -> TLS -> TCP
-- i.e. (if enough servers of each type are available)
--   1 -> 1x UDP
--   2 -> 1x UDP, 1x TLS
--   3 -> 1x UDP, 1x TLS, 1x TCP
--   4 -> 2x UDP, 1x TLS, 1x TCP
--   5 -> 2x UDP, 2x TLS, 1x TCP
--    ... etc
-- if not enough servers are available, prefer udp, then tls
limitServers :: [TurnURI] -> Int -> [TurnURI]
limitServers uris limit = limitServers' [] limit uris
  where
    limitServers' acc x _ | x <= 0 = acc -- Already have accumulated enough
    limitServers' acc _ [] = acc -- No more input
    limitServers' acc _ input = do
      let (udps, noUdps) = partition isUdp input
          (udp, forTls) = (Imports.take 1 udps, noUdps ++ drop 1 udps)
          (tlss, noTlss) = partition isTls forTls
          (tls, forTcp) = (Imports.take 1 tlss, noTlss ++ drop 1 tlss)
          (tcps, noTcps) = partition isTcp forTcp
          (tcp, rest) = (Imports.take 1 tcps, noTcps ++ drop 1 tcps)
          new = udp ++ tls ++ tcp
          newAcc = Imports.take limit $ acc ++ new
      if null new -- Did we find anything interesting? If not, time to go
        then Imports.take limit $ acc ++ rest
        else limitServers' newAcc (limit - length newAcc) rest

isUdp :: TurnURI -> Bool
isUdp uri =
  _turiScheme uri == SchemeTurn
    && ( _turiTransport uri == Just TransportUDP
           || isNothing (_turiTransport uri)
       )

isTcp :: TurnURI -> Bool
isTcp uri =
  _turiScheme uri == SchemeTurn
    && _turiTransport uri == Just TransportTCP

isTls :: TurnURI -> Bool
isTls uri =
  _turiScheme uri == SchemeTurns
    && _turiTransport uri == Just TransportTCP

makeLenses ''RTCConfiguration
makeLenses ''RTCIceServer
makeLenses ''TurnURI
makeLenses ''TurnUsername
makeLenses ''SFTServer
makeLenses ''AuthSFTServer
