{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2020 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 Web.Scim.Class.User
  ( UserDB (..),
    StoredUser,
    UserSite (..),
    userServer,
  )
where

import Data.Aeson.Types (FromJSON)
import Servant
import Servant.API.Generic
import Servant.Server.Generic
import Web.Scim.Class.Auth
import Web.Scim.ContentType
import Web.Scim.Filter
import Web.Scim.Handler
import Web.Scim.Schema.Common
import Web.Scim.Schema.ListResponse hiding (schemas)
import Web.Scim.Schema.Meta
import Web.Scim.Schema.PatchOp
import Web.Scim.Schema.User

----------------------------------------------------------------------------
-- /Users API

type StoredUser tag = WithMeta (WithId (UserId tag) (User tag))

data UserSite tag route = UserSite
  { UserSite tag route
-> route
   :- (QueryParam "filter" Filter
       :> Get '[SCIM] (ListResponse (StoredUser tag)))
usGetUsers ::
      route
        :- QueryParam "filter" Filter
        :> Get '[SCIM] (ListResponse (StoredUser tag)),
    UserSite tag route
-> route
   :- (Capture "id" (UserId tag) :> Get '[SCIM] (StoredUser tag))
usGetUser ::
      route
        :- Capture "id" (UserId tag)
        :> Get '[SCIM] (StoredUser tag),
    UserSite tag route
-> route
   :- (ReqBody '[SCIM] (User tag)
       :> PostCreated '[SCIM] (StoredUser tag))
usPostUser ::
      route
        :- ReqBody '[SCIM] (User tag)
        :> PostCreated '[SCIM] (StoredUser tag),
    UserSite tag route
-> route
   :- (Capture "id" (UserId tag)
       :> (ReqBody '[SCIM] (User tag) :> Put '[SCIM] (StoredUser tag)))
usPutUser ::
      route
        :- Capture "id" (UserId tag)
        :> ReqBody '[SCIM] (User tag)
        :> Put '[SCIM] (StoredUser tag),
    UserSite tag route
-> route
   :- (Capture "id" (UserId tag)
       :> (ReqBody '[SCIM] (PatchOp tag)
           :> Patch '[SCIM] (StoredUser tag)))
usPatchUser ::
      route
        :- Capture "id" (UserId tag)
        :> ReqBody '[SCIM] (PatchOp tag)
        :> Patch '[SCIM] (StoredUser tag),
    UserSite tag route
-> route :- (Capture "id" (UserId tag) :> DeleteNoContent)
usDeleteUser ::
      route
        :- Capture "id" (UserId tag)
        :> DeleteNoContent
  }
  deriving ((forall x. UserSite tag route -> Rep (UserSite tag route) x)
-> (forall x. Rep (UserSite tag route) x -> UserSite tag route)
-> Generic (UserSite tag route)
forall x. Rep (UserSite tag route) x -> UserSite tag route
forall x. UserSite tag route -> Rep (UserSite tag route) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tag route x.
Rep (UserSite tag route) x -> UserSite tag route
forall tag route x.
UserSite tag route -> Rep (UserSite tag route) x
$cto :: forall tag route x.
Rep (UserSite tag route) x -> UserSite tag route
$cfrom :: forall tag route x.
UserSite tag route -> Rep (UserSite tag route) x
Generic)

----------------------------------------------------------------------------
-- Methods used by the API

class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where
  -- | Get all users, optionally filtered by a 'Filter'.
  getUsers ::
    AuthInfo tag ->
    Maybe Filter ->
    ScimHandler m (ListResponse (StoredUser tag))

  -- | Get a single user by ID.
  --
  -- Should throw 'notFound' if the user doesn't exist.
  getUser ::
    AuthInfo tag ->
    UserId tag ->
    ScimHandler m (StoredUser tag)

  -- | Create a new user.
  --
  -- Should throw 'conflict' if uniqueness constraints are violated.
  postUser ::
    AuthInfo tag ->
    User tag ->
    ScimHandler m (StoredUser tag)

  -- | Overwrite an existing user.
  --
  -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if
  -- uniqueness constraints are violated.
  putUser ::
    AuthInfo tag ->
    UserId tag ->
    User tag ->
    ScimHandler m (StoredUser tag)

  -- | Modify an existing user.
  --
  -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if
  -- uniqueness constraints are violated.
  --
  --  https://tools.ietf.org/html/rfc7644#section-3.5.2
  --
  --    If the target location already contains the value specified, no changes
  --    SHOULD be made to the resource, and a success response SHOULD be
  --    returned.  Unless other operations change the resource, this operation
  --    SHALL NOT change the modify timestamp of the resource.
  --
  --  Given that PUT has the same constraints, we can implement PATCH in terms
  --  of some magic in this library, GET and PUT.
  --
  --  SCIM's Patch semantics are hard to get right. So we advice using the
  --  library built-in implementation.  we implement PATCH in terms of a GET
  --  followed by a PUT.  GET will retrieve the entire record; we then modify
  --  this record by a series of PATCH operations, and then PUT the entire
  --  record.
  patchUser ::
    AuthInfo tag ->
    UserId tag ->
    -- | PATCH payload
    PatchOp tag ->
    ScimHandler m (StoredUser tag)
  default patchUser ::
    (Patchable (UserExtra tag), FromJSON (UserExtra tag)) =>
    AuthInfo tag ->
    UserId tag ->
    -- | PATCH payload
    PatchOp tag ->
    ScimHandler m (StoredUser tag)
  patchUser AuthInfo tag
info UserId tag
uid PatchOp tag
op' = do
    (WithMeta Meta
_ (WithId UserId tag
_ (User tag
user :: User tag))) <- AuthInfo tag -> UserId tag -> ScimHandler m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag -> UserId tag -> ScimHandler m (StoredUser tag)
getUser AuthInfo tag
info UserId tag
uid
    (User tag
newUser :: User tag) <- User tag -> PatchOp tag -> ExceptT ScimError m (User tag)
forall tag (m :: * -> *).
(Patchable (UserExtra tag), FromJSON (UserExtra tag),
 MonadError ScimError m, UserTypes tag) =>
User tag -> PatchOp tag -> m (User tag)
applyPatch User tag
user PatchOp tag
op'
    AuthInfo tag
-> UserId tag -> User tag -> ScimHandler m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag
-> UserId tag -> User tag -> ScimHandler m (StoredUser tag)
putUser AuthInfo tag
info UserId tag
uid User tag
newUser

  -- | Delete a user.
  --
  -- Should throw 'notFound' if the user doesn't exist.
  deleteUser ::
    AuthInfo tag ->
    UserId tag ->
    ScimHandler m ()

----------------------------------------------------------------------------
-- API handlers

userServer ::
  forall tag m.
  (AuthDB tag m, UserDB tag m) =>
  Maybe (AuthData tag) ->
  UserSite tag (AsServerT (ScimHandler m))
userServer :: Maybe (AuthData tag) -> UserSite tag (AsServerT (ScimHandler m))
userServer Maybe (AuthData tag)
authData =
  UserSite :: forall tag route.
(route
 :- (QueryParam "filter" Filter
     :> Get '[SCIM] (ListResponse (StoredUser tag))))
-> (route
    :- (Capture "id" (UserId tag) :> Get '[SCIM] (StoredUser tag)))
-> (route
    :- (ReqBody '[SCIM] (User tag)
        :> PostCreated '[SCIM] (StoredUser tag)))
-> (route
    :- (Capture "id" (UserId tag)
        :> (ReqBody '[SCIM] (User tag) :> Put '[SCIM] (StoredUser tag))))
-> (route
    :- (Capture "id" (UserId tag)
        :> (ReqBody '[SCIM] (PatchOp tag)
            :> Patch '[SCIM] (StoredUser tag))))
-> (route :- (Capture "id" (UserId tag) :> DeleteNoContent))
-> UserSite tag route
UserSite
    { usGetUsers :: AsServerT (ScimHandler m)
:- (QueryParam "filter" Filter
    :> Get '[SCIM] (ListResponse (StoredUser tag)))
usGetUsers = \Maybe Filter
mbFilter -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag
-> Maybe Filter
-> ExceptT ScimError m (ListResponse (StoredUser tag))
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag
-> Maybe Filter -> ScimHandler m (ListResponse (StoredUser tag))
getUsers @tag AuthInfo tag
auth Maybe Filter
mbFilter,
      usGetUser :: AsServerT (ScimHandler m)
:- (Capture "id" (UserId tag) :> Get '[SCIM] (StoredUser tag))
usGetUser = \UserId tag
uid -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag -> UserId tag -> ExceptT ScimError m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag -> UserId tag -> ScimHandler m (StoredUser tag)
getUser @tag AuthInfo tag
auth UserId tag
uid,
      usPostUser :: AsServerT (ScimHandler m)
:- (ReqBody '[SCIM] (User tag)
    :> PostCreated '[SCIM] (StoredUser tag))
usPostUser = \User tag
user -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag -> User tag -> ExceptT ScimError m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag -> User tag -> ScimHandler m (StoredUser tag)
postUser @tag AuthInfo tag
auth User tag
user,
      usPutUser :: AsServerT (ScimHandler m)
:- (Capture "id" (UserId tag)
    :> (ReqBody '[SCIM] (User tag) :> Put '[SCIM] (StoredUser tag)))
usPutUser = \UserId tag
uid User tag
user -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag
-> UserId tag -> User tag -> ExceptT ScimError m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag
-> UserId tag -> User tag -> ScimHandler m (StoredUser tag)
putUser @tag AuthInfo tag
auth UserId tag
uid User tag
user,
      usPatchUser :: AsServerT (ScimHandler m)
:- (Capture "id" (UserId tag)
    :> (ReqBody '[SCIM] (PatchOp tag)
        :> Patch '[SCIM] (StoredUser tag)))
usPatchUser = \UserId tag
uid PatchOp tag
patch -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag
-> UserId tag
-> PatchOp tag
-> ExceptT ScimError m (StoredUser tag)
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag
-> UserId tag -> PatchOp tag -> ScimHandler m (StoredUser tag)
patchUser @tag @m AuthInfo tag
auth UserId tag
uid PatchOp tag
patch,
      usDeleteUser :: AsServerT (ScimHandler m)
:- (Capture "id" (UserId tag) :> DeleteNoContent)
usDeleteUser = \UserId tag
uid -> do
        AuthInfo tag
auth <- Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
forall tag (m :: * -> *).
AuthDB tag m =>
Maybe (AuthData tag) -> ScimHandler m (AuthInfo tag)
authCheck @tag Maybe (AuthData tag)
authData
        AuthInfo tag -> UserId tag -> ScimHandler m ()
forall tag (m :: * -> *).
UserDB tag m =>
AuthInfo tag -> UserId tag -> ScimHandler m ()
deleteUser @tag AuthInfo tag
auth UserId tag
uid
        NoContent -> ExceptT ScimError m NoContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent
    }