{-# 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.MLS.Credential where

import Control.Lens (makePrisms, (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Binary
import Data.Binary.Get
import Data.Binary.Parser
import Data.Binary.Parser.Char8
import Data.Binary.Put
import Data.ByteString.Base64.URL qualified as B64URL
import Data.ByteString.Lazy qualified as L
import Data.Domain
import Data.Id
import Data.OpenApi qualified as S
import Data.Qualified
import Data.Schema
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.UUID
import Imports
import Web.HttpApiData
import Wire.API.MLS.Serialisation
import Wire.Arbitrary

-- | An MLS credential.
--
-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.3-3
data Credential = BasicCredential ByteString | X509Credential [ByteString]
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via GenericUniform Credential

data CredentialTag = BasicCredentialTag | X509CredentialTag
  deriving stock (Enum, Bounded, Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform CredentialTag)

instance ParseMLS CredentialTag where
  parseMLS = parseMLSEnum @Word16 "credential type"

instance SerialiseMLS CredentialTag where
  serialiseMLS = serialiseMLSEnum @Word16

instance ParseMLS Credential where
  parseMLS =
    parseMLS >>= \case
      BasicCredentialTag ->
        BasicCredential
          <$> parseMLSBytes @VarInt
      X509CredentialTag ->
        X509Credential
          <$> parseMLSVector @VarInt (parseMLSBytes @VarInt)

instance SerialiseMLS Credential where
  serialiseMLS (BasicCredential i) = do
    serialiseMLS BasicCredentialTag
    serialiseMLSBytes @VarInt i
  serialiseMLS (X509Credential certs) = do
    serialiseMLS X509CredentialTag
    serialiseMLSVector @VarInt (serialiseMLSBytes @VarInt) certs

credentialTag :: Credential -> CredentialTag
credentialTag (BasicCredential _) = BasicCredentialTag
credentialTag (X509Credential _) = X509CredentialTag

data ClientIdentity = ClientIdentity
  { ciDomain :: Domain,
    ciUser :: UserId,
    ciClient :: ClientId
  }
  deriving stock (Eq, Ord, Generic)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientIdentity
  deriving (Arbitrary) via (GenericUniform ClientIdentity)

instance Show ClientIdentity where
  show (ClientIdentity dom u c) =
    show u
      <> ":"
      <> T.unpack (clientToText c)
      <> "@"
      <> T.unpack (domainText dom)

cidQualifiedClient :: ClientIdentity -> Qualified (UserId, ClientId)
cidQualifiedClient cid = Qualified (ciUser cid, ciClient cid) (ciDomain cid)

cidQualifiedUser :: ClientIdentity -> Qualified UserId
cidQualifiedUser = fmap fst . cidQualifiedClient

instance ToSchema ClientIdentity where
  schema =
    object $
      ClientIdentity
        <$> ciDomain .= field "domain" schema
        <*> ciUser .= field "user_id" schema
        <*> ciClient .= field "client_id" schema

instance S.ToParamSchema ClientIdentity where
  toParamSchema _ = mempty & S.type_ ?~ S.OpenApiString

instance FromHttpApiData ClientIdentity where
  parseHeader = decodeMLS'
  parseUrlPiece = decodeMLS' . T.encodeUtf8

instance ToHttpApiData ClientIdentity where
  toHeader = encodeMLS'
  toUrlPiece = T.decodeUtf8 . encodeMLS'

parseId :: Get (Id a)
parseId = maybe (fail "Invalid UUID") (pure . Id) . fromASCIIBytes =<< getByteString 36

instance ParseMLS ClientIdentity where
  parseMLS = do
    uid <- parseId
    char ':'
    cid <- ClientId <$> hexadecimal
    char '@'
    dom <-
      either fail pure . (mkDomain . T.pack) =<< many' anyChar
    pure $ ClientIdentity dom uid cid

data GroupMember = RegularClient ClientIdentity | HistoryClient HistoryClientId
  deriving (Eq, Show)

isHistoryClient :: GroupMember -> Bool
isHistoryClient (HistoryClient _) = True
isHistoryClient (RegularClient _) = False

parseHistoryClient :: Get HistoryClientId
parseHistoryClient = string "history-client:" *> parseId

instance ParseMLS GroupMember where
  parseMLS =
    (HistoryClient <$> parseHistoryClient)
      <|> (RegularClient <$> parseMLS)

-- format of the x509 client identity: {userid}%21{deviceid}@{host}
parseX509ClientIdentity :: Get ClientIdentity
parseX509ClientIdentity = do
  b64uuid <- getByteString 22
  uidBytes <- either fail pure $ B64URL.decodeUnpadded b64uuid
  uid <- maybe (fail "Invalid UUID") (pure . Id) $ fromByteString (L.fromStrict uidBytes)
  string "%21"
  cid <- ClientId <$> hexadecimal
  char '@'
  dom <-
    either fail pure . (mkDomain . T.pack) =<< many' anyChar
  pure $ ClientIdentity dom uid cid

instance SerialiseMLS ClientIdentity where
  serialiseMLS cid = do
    putByteString $ toASCIIBytes (toUUID (ciUser cid))
    putCharUtf8 ':'
    putStringUtf8 $ T.unpack (clientToText (ciClient cid))
    putCharUtf8 '@'
    putStringUtf8 $ T.unpack (domainText (ciDomain cid))

mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity (Qualified uid domain) = ClientIdentity domain uid

makePrisms ''GroupMember

instance ToSchema GroupMember where
  schema =
    named "GroupMember" $
      tag _RegularClient (unnamed schema)
        <> tag _HistoryClient (unnamed schema)
