{-# LANGUAGE TemplateHaskell #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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.Routes.Public.Brig.DomainVerification where

import Control.Arrow
import Control.Lens (makePrisms)
import Data.Aeson.Types qualified as A
import Data.Domain
import Data.Id
import Data.Misc
import Data.OpenApi qualified as S
import Data.Schema
import Data.Singletons (SingI)
import Imports
import SAML2.WebSSO qualified as SAML
import Servant
import Wire.API.EnterpriseLogin
import Wire.API.Error
import Wire.API.Error.Brig
import Wire.API.Routes.Bearer
import Wire.API.Routes.MultiVerb
import Wire.API.Routes.Named
import Wire.API.Routes.Public (ZLocalUser)
import Wire.API.Routes.Version
import Wire.API.User.Identity (EmailAddress)
import Wire.Arbitrary

data DomainRedirectConfigV9
  = DomainRedirectConfigRemoveV9
  | DomainRedirectConfigBackendV9
      -- | Backend URL
      HttpsUrl
      -- | WebApp URL
      (Maybe HttpsUrl)
  | DomainRedirectConfigNoRegistrationV9
  deriving stock (Eq, Show)

makePrisms ''DomainRedirectConfigV9

deriving via (Schema DomainRedirectConfigV9) instance A.ToJSON DomainRedirectConfigV9

deriving via (Schema DomainRedirectConfigV9) instance A.FromJSON DomainRedirectConfigV9

deriving via (Schema DomainRedirectConfigV9) instance S.ToSchema DomainRedirectConfigV9

data DomainRedirectConfigTag
  = DomainRedirectConfigRemoveTag
  | DomainRedirectConfigBackendTag
  | DomainRedirectConfigNoRegistrationTag
  deriving (Show, Ord, Eq, Enum, Bounded)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema DomainRedirectConfigTag

instance ToSchema DomainRedirectConfigTag where
  schema =
    enum @Text $
      mconcat
        [ element "remove" DomainRedirectConfigRemoveTag,
          element "backend" DomainRedirectConfigBackendTag,
          element "no-registration" DomainRedirectConfigNoRegistrationTag
        ]

domainRedirectConfigTagObjectSchema :: ObjectSchema SwaggerDoc DomainRedirectConfigTag
domainRedirectConfigTagObjectSchema =
  field "domain_redirect" schema

domainRedirectConfigV9ToTag :: DomainRedirectConfigV9 -> DomainRedirectConfigTag
domainRedirectConfigV9ToTag = \case
  DomainRedirectConfigRemoveV9 -> DomainRedirectConfigRemoveTag
  DomainRedirectConfigBackendV9 _ _ -> DomainRedirectConfigBackendTag
  DomainRedirectConfigNoRegistrationV9 -> DomainRedirectConfigNoRegistrationTag

domainRedirectConfigV9Schema :: ObjectSchema SwaggerDoc DomainRedirectConfigV9
domainRedirectConfigV9Schema =
  snd
    <$> (domainRedirectConfigV9ToTag &&& id)
      .= bind
        (fst .= domainRedirectConfigTagObjectSchema)
        (snd .= dispatch domainRedirectConfigObjectSchema)
  where
    domainRedirectConfigObjectSchema :: DomainRedirectConfigTag -> ObjectSchema SwaggerDoc DomainRedirectConfigV9
    domainRedirectConfigObjectSchema = \case
      DomainRedirectConfigBackendTag -> tag _DomainRedirectConfigBackendV9 backendConfigSchemaV9
      DomainRedirectConfigNoRegistrationTag -> tag _DomainRedirectConfigNoRegistrationV9 (pure ())
      DomainRedirectConfigRemoveTag -> tag _DomainRedirectConfigRemoveV9 (pure ())

instance ToSchema DomainRedirectConfigV9 where
  schema = object domainRedirectConfigV9Schema

data DomainRedirectConfig
  = DomainRedirectConfigRemove
  | DomainRedirectConfigBackend
      -- | Backend URL
      HttpsUrl
      -- | WebApp URL
      HttpsUrl
  | DomainRedirectConfigNoRegistration
  deriving stock (Eq, Show)

makePrisms ''DomainRedirectConfig

deriving via (Schema DomainRedirectConfig) instance A.ToJSON DomainRedirectConfig

deriving via (Schema DomainRedirectConfig) instance A.FromJSON DomainRedirectConfig

deriving via (Schema DomainRedirectConfig) instance S.ToSchema DomainRedirectConfig

domainRedirectConfigSchema :: ObjectSchema SwaggerDoc DomainRedirectConfig
domainRedirectConfigSchema =
  snd
    <$> (domainRedirectConfigToTag &&& id)
      .= bind
        (fst .= domainRedirectConfigTagObjectSchema)
        (snd .= dispatch domainRedirectConfigObjectSchema)
  where
    domainRedirectConfigObjectSchema :: DomainRedirectConfigTag -> ObjectSchema SwaggerDoc DomainRedirectConfig
    domainRedirectConfigObjectSchema = \case
      DomainRedirectConfigBackendTag -> tag _DomainRedirectConfigBackend backendConfigFieldSchema
      DomainRedirectConfigNoRegistrationTag -> tag _DomainRedirectConfigNoRegistration (pure ())
      DomainRedirectConfigRemoveTag -> tag _DomainRedirectConfigRemove (pure ())

    backendConfigFieldSchema :: ObjectSchema SwaggerDoc (HttpsUrl, HttpsUrl)
    backendConfigFieldSchema = field "backend" backendConfigObjectSchema

    backendConfigObjectSchema :: ValueSchema NamedSwaggerDoc (HttpsUrl, HttpsUrl)
    backendConfigObjectSchema =
      object $
        (,)
          <$> fst .= field "config_url" schema
          <*> snd .= field "webapp_url" schema

domainRedirectConfigToTag :: DomainRedirectConfig -> DomainRedirectConfigTag
domainRedirectConfigToTag = \case
  DomainRedirectConfigRemove -> DomainRedirectConfigRemoveTag
  DomainRedirectConfigBackend _ _ -> DomainRedirectConfigBackendTag
  DomainRedirectConfigNoRegistration -> DomainRedirectConfigNoRegistrationTag

instance ToSchema DomainRedirectConfig where
  schema = object domainRedirectConfigSchema

newtype GetDomainRegistrationRequest = GetDomainRegistrationRequest {domainRegistrationRequestEmail :: EmailAddress}
  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via (Schema GetDomainRegistrationRequest)

instance ToSchema GetDomainRegistrationRequest where
  schema =
    object $
      GetDomainRegistrationRequest
        <$> domainRegistrationRequestEmail
          .= field "email" schema

data TeamDomainRedirect
  = TeamSso SAML.IdPId
  | TeamNoRegistration
  | TeamNone
  deriving (Show, Eq)

data TeamDomainRedirectTag = TeamNoRegistrationTag | TeamNoneTag
  deriving (Show, Ord, Eq, Enum, Bounded)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema TeamDomainRedirectTag

instance ToSchema TeamDomainRedirectTag where
  schema =
    enum @Text $
      mconcat
        [ element "no-registration" TeamNoRegistrationTag,
          element "none" TeamNoneTag
        ]

idpIdValueSchema :: ValueSchema SwaggerDoc SAML.IdPId
idpIdValueSchema = SAML.fromIdPId .= fmap SAML.IdPId (Data.Schema.unnamed uuidSchema)

maybeTeamDomainRedirectTargetObjectSchema :: ObjectSchemaP SwaggerDoc (Maybe TeamDomainRedirectTag, Maybe SAML.IdPId) (Maybe TeamDomainRedirect)
maybeTeamDomainRedirectTargetObjectSchema =
  withParser teamDomainRedirectTargetTupleObjectSchema maybeTeamDomainRedirectTargetTargetFromTuple
  where
    teamDomainRedirectTargetTupleObjectSchema :: ObjectSchema SwaggerDoc (Maybe TeamDomainRedirectTag, Maybe SAML.IdPId)
    teamDomainRedirectTargetTupleObjectSchema =
      (,)
        <$> fst .= maybe_ (optField "domain_redirect" schema)
        <*> snd .= maybe_ (optField "sso" idpIdValueSchema)

    fromTag :: TeamDomainRedirectTag -> TeamDomainRedirect
    fromTag = \case
      TeamNoRegistrationTag -> TeamNoRegistration
      TeamNoneTag -> TeamNone

    maybeTeamDomainRedirectTargetTargetFromTuple :: (Maybe TeamDomainRedirectTag, Maybe SAML.IdPId) -> A.Parser (Maybe TeamDomainRedirect)
    maybeTeamDomainRedirectTargetTargetFromTuple = \case
      (Just _, Just _) -> fail "only one of domain_redirect or sso must be present"
      (Just redirect, _) -> pure $ Just (fromTag redirect)
      (_, Just sso) -> pure $ Just (TeamSso sso)
      (Nothing, Nothing) -> pure Nothing

maybeTeamDomainRedirectToTuple :: Maybe TeamDomainRedirect -> (Maybe TeamDomainRedirectTag, Maybe SAML.IdPId)
maybeTeamDomainRedirectToTuple = \case
  (Just TeamNone) -> (Just TeamNoneTag, Nothing)
  (Just TeamNoRegistration) -> (Just TeamNoRegistrationTag, Nothing)
  (Just (TeamSso sso)) -> (Nothing, Just sso)
  Nothing -> (Nothing, Nothing)

data TeamInviteConfig = TeamInviteConfig
  { teamInvite :: TeamInvite,
    domainRedirect :: Maybe TeamDomainRedirect
  }
  deriving (Show, Eq)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TeamInviteConfig)

instance ToSchema TeamInviteConfig where
  schema =
    object $
      TeamInviteConfig
        <$> (.teamInvite) .= teamInviteObjectSchema
        <*> (maybeTeamDomainRedirectToTuple . (.domainRedirect)) .= maybeTeamDomainRedirectTargetObjectSchema

samlIdpIdSchema :: ValueSchema NamedSwaggerDoc SAML.IdPId
samlIdpIdSchema = SAML.fromIdPId .= fmap SAML.IdPId uuidSchema

data DomainVerificationChallenge = DomainVerificationChallenge
  { challengeId :: ChallengeId,
    -- | unhashed/plaintext short lived challenge auth token
    token :: Token,
    dnsVerificationToken :: DnsVerificationToken
  }
  deriving (Eq, Show)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema DomainVerificationChallenge)

instance ToSchema DomainVerificationChallenge where
  schema =
    object $
      DomainVerificationChallenge
        <$> challengeId .= field "id" schema
        <*> token .= field "token" schema
        <*> (.dnsVerificationToken) .= field "dns_verification_token" schema

newtype ChallengeToken = ChallengeToken {unChallengeToken :: Token}
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema ChallengeToken)

instance ToSchema ChallengeToken where
  schema =
    object $
      ChallengeToken
        <$> unChallengeToken .= field "challenge_token" schema

newtype DomainOwnershipToken = DomainOwnershipToken {unDomainOwnershipToken :: Token}
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema DomainOwnershipToken)

instance ToSchema DomainOwnershipToken where
  schema =
    object $
      DomainOwnershipToken
        <$> unDomainOwnershipToken .= field "domain_ownership_token" schema

newtype RegisteredDomains (v :: Version) = RegisteredDomains {unRegisteredDomains :: [DomainRegistrationResponse v]}
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema (RegisteredDomains v)

instance (Typeable v, SingI v) => ToSchema (RegisteredDomains v) where
  schema =
    object $
      RegisteredDomains
        <$> unRegisteredDomains .= field "registered_domains" (array schema)

type DomainRedirectResponseV9 = DomainRedirectResponse V9

data DomainRedirectResponse (v :: Version) = DomainRedirectResponse
  { propagateUserExists :: Bool,
    redirect :: DomainRedirect
  }
  deriving (Eq, Show, Generic)

deriving via GenericUniform DomainRedirectResponseV9 instance Arbitrary DomainRedirectResponseV9

deriving via Schema DomainRedirectResponseV9 instance A.ToJSON DomainRedirectResponseV9

deriving via Schema DomainRedirectResponseV9 instance A.FromJSON DomainRedirectResponseV9

deriving via Schema DomainRedirectResponseV9 instance S.ToSchema DomainRedirectResponseV9

instance ToSchema DomainRedirectResponseV9 where
  schema =
    object $
      DomainRedirectResponse
        <$> (\r -> True <$ guard r.propagateUserExists)
          .= maybe_
            (fromMaybe False <$> optField "due_to_existing_account" schema)
        <*> (.redirect) .= domainRedirectSchemaV9

type DomainRedirectResponseV10 = DomainRedirectResponse V10

deriving via GenericUniform DomainRedirectResponseV10 instance Arbitrary DomainRedirectResponseV10

deriving via Schema DomainRedirectResponseV10 instance A.ToJSON DomainRedirectResponseV10

deriving via Schema DomainRedirectResponseV10 instance A.FromJSON DomainRedirectResponseV10

deriving via Schema DomainRedirectResponseV10 instance S.ToSchema DomainRedirectResponseV10

instance ToSchema DomainRedirectResponseV10 where
  schema =
    object $
      DomainRedirectResponse
        <$> (\r -> True <$ guard r.propagateUserExists)
          .= maybe_
            (fromMaybe False <$> optField "due_to_existing_account" schema)
        <*> (.redirect) .= domainRedirectSchema V10

type DomainVerificationChallengeAPI =
  Named
    "domain-verification-challenge"
    ( Summary "Get a DNS verification challenge"
        :> "domain-verification"
        :> Capture "domain" Domain
        :> "challenges"
        :> Post '[JSON] DomainVerificationChallenge
    )
    :<|> Named
           "verify-challenge"
           ( Summary "Verify a DNS verification challenge"
               :> CanThrow DomainVerificationChallengeNotFound
               :> CanThrow DomainVerificationAuthFailure
               :> CanThrow DomainVerificationDomainVerificationFailed
               :> "domain-verification"
               :> Capture "domain" Domain
               :> "challenges"
               :> Capture "challengeId" ChallengeId
               :> ReqBody '[JSON] ChallengeToken
               :> Post '[JSON] DomainOwnershipToken
           )

type DomainVerificationTeamAPI =
  Named
    "verify-challenge-team"
    ( Summary "Verify a DNS verification challenge for a team"
        :> CanThrow DomainVerificationAuthFailure
        :> CanThrow DomainVerificationPaymentRequired
        :> CanThrow DomainVerificationOperationForbidden
        :> ZLocalUser
        :> "domain-verification"
        :> Capture "domain" Domain
        :> "team"
        :> "challenges"
        :> Capture "challengeId" ChallengeId
        :> ReqBody '[JSON] ChallengeToken
        :> Post '[JSON] DomainOwnershipToken
    )
    :<|> Named
           "domain-verification-authorize-team"
           ( Summary "Authorize a team to operate on a verified domain"
               :> CanThrow DomainVerificationAuthFailure
               :> CanThrow DomainVerificationPaymentRequired
               :> CanThrow DomainVerificationOperationForbidden
               :> ZLocalUser
               :> "domain-verification"
               :> Capture "domain" Domain
               :> "authorize-team"
               :> ReqBody '[JSON] DomainOwnershipToken
               :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Authorized")
           )
    :<|> Named
           "update-team-invite"
           ( Summary "Update the team-invite configuration"
               :> CanThrow DomainVerificationPaymentRequired
               :> CanThrow DomainVerificationOperationForbidden
               :> ZLocalUser
               :> "domain-verification"
               :> Capture "domain" Domain
               :> "team"
               :> ReqBody '[JSON] TeamInviteConfig
               :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
           )
    :<|> Named
           "get-all-registered-domains@v9"
           ( Summary "Get all registered domains"
               :> Until V10
               :> ZLocalUser
               :> "teams"
               :> Capture "teamId" TeamId
               :> "registered-domains"
               :> Get '[JSON] (RegisteredDomains V9)
           )
    :<|> Named
           "get-all-registered-domains"
           ( Summary "Get all registered domains"
               :> From V10
               :> ZLocalUser
               :> "teams"
               :> Capture "teamId" TeamId
               :> "registered-domains"
               :> Get '[JSON] (RegisteredDomains V10)
           )
    :<|> Named
           "delete-registered-domain"
           ( Summary "Delete a registered domain"
               :> CanThrow DomainVerificationPaymentRequired
               :> CanThrow DomainVerificationOperationForbidden
               :> ZLocalUser
               :> "teams"
               :> Capture "teamId" TeamId
               :> "registered-domains"
               :> Capture "domain" Domain
               :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 204 "Deleted")
           )

type DomainVerificationAPI =
  Named
    "update-domain-redirect@v9"
    ( Summary "Update the domain redirect configuration"
        :> Until V10
        :> CanThrow DomainVerificationAuthFailure
        :> CanThrow DomainVerificationOperationForbidden
        :> Header' '[Required, Strict] "Authorization" (Bearer Token)
        :> "domain-verification"
        :> Capture "domain" Domain
        :> "backend"
        :> ReqBody '[JSON] DomainRedirectConfigV9
        :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
    )
    :<|> Named
           "update-domain-redirect"
           ( Summary "Update the domain redirect configuration"
               :> From V10
               :> CanThrow DomainVerificationAuthFailure
               :> CanThrow DomainVerificationOperationForbidden
               :> Header' '[Required, Strict] "Authorization" (Bearer Token)
               :> "domain-verification"
               :> Capture "domain" Domain
               :> "backend"
               :> ReqBody '[JSON] DomainRedirectConfig
               :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
           )
    :<|> Named
           "get-domain-registration@v9"
           ( Summary "Get domain registration configuration by email"
               :> Until V10
               :> CanThrow DomainVerificationInvalidDomain
               :> "get-domain-registration"
               :> ReqBody '[JSON] GetDomainRegistrationRequest
               :> Post '[JSON] DomainRedirectResponseV9
           )
    :<|> Named
           "get-domain-registration"
           ( Summary "Get domain registration configuration by email"
               :> Description
                    "- `due_to_existing_account`: boolean (optional, only present if `domain_redirect` is `no-registration`)\n\
                    \- `backend`: object (optional, must be present if `domain_redirect` is `backend`)\n\
                    \  - `config_url`: string (required)\n\
                    \  - `webapp_url`: string (optional)\n\
                    \- `sso_code`: string (optional, must be present if `domain_redirect` is `sso`)"
               :> From V10
               :> CanThrow DomainVerificationInvalidDomain
               :> "get-domain-registration"
               :> ReqBody '[JSON] GetDomainRegistrationRequest
               :> Post '[JSON] DomainRedirectResponseV10
           )
