{-# LANGUAGE OverloadedLists #-}
{-# 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/>.

-- TODO remove -Wno-orphans (orphans can be avoided by only implementing
-- functions here, and gathering them in the instance near the Spar type;
-- alternatively, @hscim@ could be changed)

-- | An implementation of the SCIM API for doing bulk operations with users.
--
-- See <https://en.wikipedia.org/wiki/System_for_Cross-domain_Identity_Management>
--
-- = SCIM user creation flow
--
-- When a user is created via SCIM, a SAML user identity has to be created with it. Currently
-- we don't allow SCIM users without SAML user identities.
--
-- Creating these two user identities (SCIM and SAML) together requires constructing a
-- 'UserRef' from the SCIM request, which is then stored by 'Spar.Data.insertUser'.
--
-- The 'UserRef' consists of:
--
--   * tenant (the url-shaped ID the IdP assigns to itself);
--
--   * subject (usually an email, or an unstructured nickname, or a few more obscure
--     alternatives).
--
-- /Tenant:/ if there is only one IdP for the current team, the tenant can be found by calling
-- 'getIdPConfigsByTeam' and looking up @^. idpMetadata . edIssuer@ on the result. If there is
-- more than one IdP, we need a way to associate user creation requests with specific IdPs.
-- Currently we disallow teams with more than one IdP.
--
-- /Subject:/ there are different reasonable ways to pick a subject for a user; this should be
-- configurable in the team settings page (e.g. a choice of one field from the SCIM user
-- schema, optionally transformed with one of a few hard-coded functions). A simple default
-- could be "take the email address, and type it as an email address", or in saml2-web-sso
-- pseudo-code: @\email -> entityNameID (parseURI ("email:" <> renderEmail email))@.
module Spar.Scim
  ( -- * Reexports
    module Wire.API.User.Scim,
    module Spar.Scim.Auth,
    module Spar.Scim.User,

    -- * API implementation
    apiScim,
  )
where

import Data.ByteString (toStrict)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Encoding.Error
import Imports
import Network.Wai.Utilities.Exception
import Polysemy
import Polysemy.Error (Error, fromExceptionSem, runError, throw, try)
import Polysemy.Input (Input)
import qualified SAML2.WebSSO as SAML
import Servant
import Servant.Server.Generic (AsServerT)
import Spar.App (sparToServerErrorWithLogging, throwSparSem)
import Spar.Error
  ( SparCustomError (SparScimError),
    SparError,
  )
import Spar.Options
import Spar.Scim.Auth
import Spar.Scim.Group ()
import Spar.Scim.User
import Spar.Sem.SAMLUserStore (SAMLUserStore)
import Spar.Sem.ScimTokenStore (ScimTokenStore)
import System.Logger (Msg)
import qualified Web.Scim.Capabilities.MetaSchema as Scim.Meta
import qualified Web.Scim.Class.Group as Scim.Group
import qualified Web.Scim.Class.User as Scim.User
import qualified Web.Scim.Handler as Scim
import qualified Web.Scim.Schema.Error as Scim
import qualified Web.Scim.Schema.Schema as Scim.Schema
import qualified Web.Scim.Server as Scim
import Wire.API.Routes.Public.Spar
import Wire.API.User.Scim
import Wire.BrigAPIAccess (BrigAPIAccess)
import Wire.GalleyAPIAccess (GalleyAPIAccess)
import Wire.IdPConfigStore (IdPConfigStore)
import Wire.Reporter (Reporter)
import Wire.ScimExternalIdStore (ScimExternalIdStore)
import Wire.ScimSubsystem
import Wire.ScimUserTimesStore (ScimUserTimesStore)
import Wire.Sem.Logger (Logger)
import Wire.Sem.Now (Now)
import Wire.Sem.Random (Random)

-- | SCIM config for our server.
--
-- TODO: the 'Scim.Meta.empty' configuration claims that we don't support filters, but we
-- actually do; it's a bug in hscim
configuration :: Scim.Meta.Configuration
configuration = Scim.Meta.empty

apiScim ::
  forall r.
  ( Member Random r,
    Member (Input Opts) r,
    Member (Logger (Msg -> Msg)) r,
    Member (Logger String) r,
    Member Now r,
    Member (Error SparError) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member ScimSubsystem r,
    Member ScimExternalIdStore r,
    Member ScimUserTimesStore r,
    Member ScimTokenStore r,
    Member Reporter r,
    Member IdPConfigStore r,
    Member
      ( -- TODO(sandy): Only necessary for 'fromExceptionSem'. But can these errors even happen?
        Final IO
      )
      r,
    Member SAMLUserStore r
  ) =>
  ServerT APIScim (Sem r)
apiScim =
  hoistScim (toServant (server configuration))
    :<|> apiScimToken
  where
    hoistScim =
      hoistServer
        (Proxy @(ScimSiteAPI SparTag))
        (wrapScimErrors . Scim.fromScimHandler (throwSparSem . SparScimError))
    -- Wrap /all/ errors into the format required by SCIM, even server exceptions that have
    -- nothing to do with SCIM.
    --
    -- FIXME: this doesn't catch impure exceptions (e.g. thrown with 'error').
    -- Let's hope that SCIM clients can handle non-SCIM-formatted errors
    -- properly. See <https://github.com/haskell-servant/servant/issues/1022>
    -- for why it's hard to catch impure exceptions.
    wrapScimErrors :: Sem r a -> Sem r a
    wrapScimErrors act = do
      result :: Either SomeException (Either SparError a) <-
        runError $ fromExceptionSem @SomeException $ raise $ try @SparError act
      case result of
        Left someException -> do
          -- We caught an exception that's not a Spar exception at all. It is wrapped into
          -- Scim.serverError.
          throw . SAML.CustomError . SparScimError $
            Scim.serverError (T.pack (displayExceptionNoBacktrace someException))
        Right (Left err@(SAML.CustomError (SparScimError _))) ->
          -- We caught a 'SparScimError' exception. It is left as-is.
          throw err
        Right (Left sparError) -> do
          -- We caught some other Spar exception. It is rendered and wrapped into a scim error
          -- with the same status and message, and no scim error type.
          err :: ServerError <- sparToServerErrorWithLogging sparError
          throw . SAML.CustomError . SparScimError $
            Scim.ScimError
              { schemas = [Scim.Schema.Error20],
                status = Scim.Status $ errHTTPCode err,
                scimType = Nothing,
                detail =
                  Just . T.decodeUtf8With lenientDecode . toStrict . errBody $
                    err
              }
        Right (Right x) -> do
          -- No exceptions! Good.
          pure x

-- | This is similar to 'Scim.siteServer'.
server ::
  forall tag m.
  (Scim.User.UserDB tag m, Scim.Group.GroupDB tag m) =>
  Scim.Meta.Configuration ->
  ScimSite tag (AsServerT (Scim.ScimHandler m))
server conf =
  ScimSite
    { config = toServant $ Scim.configServer conf,
      users = \authData -> toServant (Scim.userServer @tag authData),
      groups = \authData -> toServant (Scim.groupServer @tag authData)
    }
