{-# OPTIONS_GHC -Wno-orphans #-}

-- 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.Routes.Public.Spar where

import Control.Lens ((^.))
import Data.Aeson (FromJSON, ToJSON)
import Data.Domain
import Data.Id
import Data.Kind (Type)
import Data.OpenApi qualified as Swagger
import Data.Proxy
import Data.Range
import Data.SOP (I (..), pattern S, pattern Z)
import Data.Schema
import Imports
import SAML2.WebSSO (IdPId (..))
import SAML2.WebSSO qualified as SAML
import Servant
import Servant.API.Extended
import Servant.Multipart
import Servant.Server.Experimental.Auth
import URI.ByteString qualified as URI
import Web.Scim.Capabilities.MetaSchema as Scim.Meta
import Web.Scim.Class.Auth as Scim.Auth
import Web.Scim.Class.Group as Scim.Group
import Web.Scim.Class.User as Scim.User
import Wire.API.Deprecated (Deprecated)
import Wire.API.Error
import Wire.API.Error.Brig
import Wire.API.Routes.API
import Wire.API.Routes.Internal.Spar
import Wire.API.Routes.MultiVerb
import Wire.API.Routes.Named
import Wire.API.Routes.Public
import Wire.API.Routes.Version
import Wire.API.Routes.Versioned
import Wire.API.SwaggerServant
import Wire.API.User (EmailAddress)
import Wire.API.User.Auth (CookieLabel)
import Wire.API.User.IdentityProvider
import Wire.API.User.Saml
import Wire.API.User.Scim

-- FUTUREWORK (thanks jschaul): Use @Header' '[Strict]@ to avoid the need for the 'Maybe' and the
-- extra checks.

-- FUTUREWORK: use https://hackage.haskell.org/package/servant-0.14.1/docs/Servant-API-Generic.html?

type SparAPI =
  "sso" :> APISSO
    :<|> "identity-providers" :> APIIDP
    :<|> "scim" :> APIScim
    :<|> OmitDocs :> InternalAPI

type DeprecateSSOAPIV1 =
  Description
    "DEPRECATED!  use /sso/metadata/:tid instead!  \
    \Details: https://docs.wire.com/understand/single-sign-on/trouble-shooting.html#can-i-use-the-same-sso-login-code-for-multiple-teams"

type APISSO =
  Named
    "sso-metadata"
    ( --  This deprecated endpoint should be removed at some point. However it does not make a lot of sense to apply our versioning mechanism to it,
      -- as this is not a classic client API endpoint. It is used in the SAML IDP flow and should exist independently of the API version,
      -- and requires a different process for decommissioning. See https://wearezeta.atlassian.net/browse/WPB-15319
      DeprecateSSOAPIV1 :> Deprecated :> "metadata" :> ZHostOpt :> SAML.APIMeta
    )
    :<|> Named "sso-team-metadata" ("metadata" :> ZHostOpt :> Capture "team" TeamId :> SAML.APIMeta)
    :<|> "initiate-login" :> APIAuthReqPrecheck
    :<|> "initiate-login" :> APIAuthReq
    :<|> APIAuthRespLegacy
    :<|> APIAuthResp
    :<|> "settings" :> SsoSettingsGet
    :<|> Named
           "sso-get-by-email"
           ( "get-by-email"
               :> From 'V15
               :> ZHostOpt
               :> ReqBody '[JSON] GetByEmailReq
               :> MultiVerb
                    'POST
                    '[JSON]
                    '[ Respond 200 "SSO code found" GetByEmailResp,
                       Respond 404 "SSO code not found or feature disabled" GetByEmailResp
                     ]
                    (Maybe SAML.IdPId)
           )

newtype GetByEmailReq = GetByEmailReq {email :: EmailAddress}
  deriving stock (Eq, Show, Generic)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema GetByEmailReq

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

newtype GetByEmailResp = GetByEmailResp {ssoCode :: Maybe SAML.IdPId}
  deriving stock (Eq, Show, Generic)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema GetByEmailResp

instance ToSchema GetByEmailResp where
  schema =
    object $
      GetByEmailResp
        <$> (fmap fromIdPId . ssoCode) .= maybe_ (optField "sso_code" (IdPId <$> uuidSchema))

instance
  AsUnion
    '[ Respond 200 "SSO code found" GetByEmailResp,
       Respond 404 "SSO code not found or feature disabled" GetByEmailResp
     ]
    (Maybe SAML.IdPId)
  where
  toUnion (Just idpId) = Z (I (GetByEmailResp (Just idpId)))
  toUnion Nothing = S (Z (I (GetByEmailResp Nothing)))
  fromUnion (Z (I (GetByEmailResp mbIdpId))) = mbIdpId
  fromUnion (S (Z (I (GetByEmailResp mbIdpId)))) = mbIdpId
  fromUnion (S (S x)) = case x of {}

type CheckOK = Verb 'HEAD 200

type APIAuthReqPrecheck =
  Named
    "auth-req-precheck"
    ( QueryParam "success_redirect" URI.URI
        :> QueryParam "error_redirect" URI.URI
        :> QueryParam "label" CookieLabel
        :> Capture "idp" SAML.IdPId
        :> ZHostOpt
        :> CheckOK '[PlainText] NoContent
    )

type APIAuthReq =
  Named
    "auth-req"
    ( QueryParam "success_redirect" URI.URI
        :> QueryParam "error_redirect" URI.URI
        :> QueryParam "label" CookieLabel
        -- (SAML.APIAuthReq from here on, except for the cookies)
        :> Capture "idp" SAML.IdPId
        :> ZHostOpt
        :> Get '[SAML.HTML] (SAML.FormRedirect SAML.AuthnRequest)
    )

-- | This deprecated endpoint should be removed at some point. However it does not make a lot of sense to apply our versioning mechanism to it,
-- as this is not a classic client API endpoint. It is used in the SAML IDP flow and should exist independently of the API version,
-- and requires a different process for decommissioning. See https://wearezeta.atlassian.net/browse/WPB-15319
type APIAuthRespLegacy =
  Named
    "auth-resp-legacy"
    ( DeprecateSSOAPIV1
        :> Deprecated
        :> "finalize-login"
        -- (SAML.APIAuthResp from here on, except for response)
        :> MultipartForm Mem SAML.AuthnResponseBody
        :> ZHostOpt
        :> Post '[PlainText] Void
    )

type APIAuthResp =
  Named
    "auth-resp"
    ( "finalize-login"
        :> Capture "team" TeamId
        -- (SAML.APIAuthResp from here on, except for response)
        :> MultipartForm Mem SAML.AuthnResponseBody -- this is the *http request* body containing the *saml response*.
        :> ZHostOpt
        :> Post '[PlainText] Void
    )

type instance AuthServerData (AuthProtect "TeamAdmin") = TeamId

type APIIDP =
  Named "idp-get" (ZOptUser :> IdpGet)
    :<|> Named "idp-get-raw" (ZOptUser :> IdpGetRaw)
    :<|> Named "idp-get-all" (ZOptUser :> IdpGetAll)
    :<|> Named "idp-create@v7" (Until 'V8 :> AuthProtect "TeamAdmin" :> ZOptUser :> IdpCreate) -- (change is semantic, see handler)
    :<|> Named "idp-create" (From 'V8 :> AuthProtect "TeamAdmin" :> ZOptUser :> ZHostOpt :> IdpCreate)
    :<|> Named "idp-update" (ZOptUser :> ZHostOpt :> IdpUpdate)
    :<|> Named "idp-delete" (ZOptUser :> IdpDelete)

type IdpGetRaw = Capture "id" SAML.IdPId :> "raw" :> Get '[RawXML] RawIdPMetadata

type IdpGet = Capture "id" SAML.IdPId :> Get '[JSON] IdP

type IdpGetAll = Get '[JSON] IdPList

-- | See also: 'validateNewIdP', 'idpCreate', 'idpCreateXML'.
type IdpCreate =
  Description
    "Create a new identity provider.\n\
    \\n\
    \The `api_version` parameter controls the uniqueness constraint for IdP issuers:\n\
    \- `v1`: IdP issuers must be globally unique across the entire backend (all teams)\n\
    \- `v2` (default): IdP issuers must be unique per team (can be reused across different teams)\n\
    \\n\
    \These constraints apply to both, multi-ingress and standard backends."
    :> ReqBodyCustomError '[RawXML, JSON] "wai-error" IdPMetadataInfo
    :> QueryParam' '[Optional, Strict] "replaces" SAML.IdPId
    :> QueryParam' '[Optional, Strict] "api_version" WireIdPAPIVersion -- see also: 'DeprecateSSOAPIV1'
    -- FUTUREWORK: The handle is restricted to 32 characters. Can we find a more reasonable upper bound and create a type for it? Also see `IdpUpdate`.
    :> QueryParam' '[Optional, Strict] "handle" (Range 1 32 Text)
    :> PostCreated '[JSON] IdP

type IdpUpdate =
  ReqBodyCustomError '[RawXML, JSON] "wai-error" IdPMetadataInfo
    :> Capture "id" SAML.IdPId
    -- FUTUREWORK: The handle is restricted to 32 characters. Can we find a more reasonable upper bound and create a type for it? Also see `IdpCreate`.
    :> QueryParam' '[Optional, Strict] "handle" (Range 1 32 Text)
    :> Put '[JSON] IdP

type IdpDelete =
  Capture "id" SAML.IdPId
    :> QueryParam' '[Optional, Strict] "purge" Bool
    :> DeleteNoContent

type SsoSettingsGet =
  Named
    "sso-settings"
    (Get '[JSON] SsoSettings)

sparSPIssuer :: (Functor m, SAML.HasConfig m) => Maybe TeamId -> Maybe Domain -> m (Maybe SAML.Issuer)
sparSPIssuer mbtid = (SAML.Issuer <$$>) . sparResponseURI mbtid

sparResponseURI :: (Functor m, SAML.HasConfig m) => Maybe TeamId -> Maybe Domain -> m (Maybe URI.URI)
sparResponseURI Nothing =
  getSsoURI (Proxy @APISSO) (Proxy @APIAuthRespLegacy)
sparResponseURI (Just tid) =
  getSsoURI' (Proxy @APISSO) (Proxy @APIAuthResp) tid

getSsoURI ::
  forall m endpoint api.
  ( HasCallStack,
    Functor m,
    SAML.HasConfig m,
    IsElem endpoint api,
    HasLink endpoint,
    ToHttpApiData (MkLink endpoint Link)
  ) =>
  Proxy api ->
  Proxy endpoint ->
  Maybe Domain ->
  m (Maybe URI.URI)
getSsoURI proxyAPI proxyAPIAuthResp mbDomain = (extpath . (^. SAML.cfgSPSsoURI)) <$$> (domainConfig <$> SAML.getConfig)
  where
    extpath :: URI.URI -> URI.URI
    extpath = (SAML.=/ (toUrlPiece $ safeLink proxyAPI proxyAPIAuthResp))

    domainConfig :: SAML.Config -> Maybe SAML.MultiIngressDomainConfig
    domainConfig config = SAML.getMultiIngressDomainConfig config mbDomain

-- | 'getSsoURI' for links that have one variable path segment.
--
-- FUTUREWORK: this is only sometimes what we need.  it would be nice to have a type class with a
-- method 'getSsoURI' for arbitrary path arities.
getSsoURI' ::
  forall endpoint api a (f :: Type -> Type) t.
  ( Functor f,
    SAML.HasConfig f,
    MkLink endpoint Link ~ (t -> a),
    HasLink endpoint,
    ToHttpApiData a,
    IsElem endpoint api
  ) =>
  Proxy api ->
  Proxy endpoint ->
  t ->
  Maybe Domain ->
  f (Maybe URI.URI)
getSsoURI' proxyAPI proxyAPIAuthResp idpid mbDomain = (extpath . (^. SAML.cfgSPSsoURI)) <$$> (domainConfig <$> SAML.getConfig)
  where
    extpath :: URI.URI -> URI.URI
    extpath = (SAML.=/ (toUrlPiece $ safeLink proxyAPI proxyAPIAuthResp idpid))

    domainConfig :: SAML.Config -> Maybe SAML.MultiIngressDomainConfig
    domainConfig config = SAML.getMultiIngressDomainConfig config mbDomain

getContactPersons ::
  ( Functor f,
    SAML.HasConfig f
  ) =>
  Maybe Domain ->
  f [SAML.ContactPerson]
getContactPersons mbDomain = domainConfig <$> SAML.getConfig
  where
    domainConfig :: SAML.Config -> [SAML.ContactPerson]
    domainConfig config = concatMap SAML._cfgContacts (SAML.getMultiIngressDomainConfig config mbDomain)

-- SCIM

type APIScim =
  OmitDocs :> "v2" :> ScimSiteAPI SparTag
    :<|> "auth-tokens"
      :> CanThrow 'CodeAuthenticationFailed
      :> CanThrow 'CodeAuthenticationRequired
      :> APIScimToken

type ScimSiteAPI tag = ToServantApi (ScimSite tag)

-- | This is similar to 'Scim.Site', but does not include the 'Scim.GroupAPI',
-- as we don't support it (we don't implement 'Web.Scim.Class.Group.GroupDB').
data ScimSite tag route = ScimSite
  { config ::
      route
        :- ToServantApi Scim.Meta.ConfigSite,
    users ::
      route
        :- Header "Authorization" (Scim.Auth.AuthData tag)
          :> "Users"
          :> ToServantApi (Scim.User.UserSite tag),
    groups ::
      route
        :- Header "Authorization" (Scim.Auth.AuthData tag)
          :> "Groups"
          :> ToServantApi (Scim.Group.GroupSite tag)
  }
  deriving (Generic)

type APIScimToken =
  Named "auth-tokens-create@v7" (Until 'V8 :> ZOptUser :> APIScimTokenCreateV7)
    :<|> Named "auth-tokens-create" (From 'V8 :> ZOptUser :> APIScimTokenCreate)
    :<|> Named "auth-tokens-put-name" (From 'V8 :> ZUser :> APIScimTokenPutName)
    :<|> Named "auth-tokens-delete" (ZOptUser :> APIScimTokenDelete)
    :<|> Named "auth-tokens-list@v7" (Until 'V8 :> ZOptUser :> APIScimTokenListV7)
    :<|> Named "auth-tokens-list" (From 'V8 :> ZOptUser :> APIScimTokenList)

type APIScimTokenPutName =
  Capture "id" ScimTokenId
    :> ReqBody '[JSON] ScimTokenName
    :> Put '[JSON] ()

type APIScimTokenCreateV7 =
  VersionedReqBody 'V7 '[JSON] CreateScimToken
    :> Post '[JSON] CreateScimTokenResponseV7

type APIScimTokenCreate =
  ReqBody '[JSON] CreateScimToken
    :> Post '[JSON] CreateScimTokenResponse

type APIScimTokenDelete =
  QueryParam' '[Required, Strict] "id" ScimTokenId
    :> DeleteNoContent

type APIScimTokenList =
  Get '[JSON] ScimTokenList

type APIScimTokenListV7 =
  Get '[JSON] ScimTokenListV7

data SparAPITag

instance ServiceAPI SparAPITag v where
  type ServiceAPIRoutes SparAPITag = SparAPI
