User.hs

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

-- 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 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
  { usGetUsers ::
      route
        :- QueryParam "filter" Filter
          :> Get '[SCIM] (ListResponse (StoredUser tag)),
    usGetUser ::
      route
        :- Capture "id" (UserId tag)
          :> Get '[SCIM] (StoredUser tag),
    usPostUser ::
      route
        :- ReqBody '[SCIM] (User tag)
          :> PostCreated '[SCIM] (StoredUser tag),
    usPutUser ::
      route
        :- Capture "id" (UserId tag)
          :> ReqBody '[SCIM] (User tag)
          :> Put '[SCIM] (StoredUser tag),
    usPatchUser ::
      route
        :- Capture "id" (UserId tag)
          :> ReqBody '[SCIM] (PatchOp tag)
          :> Patch '[SCIM] (StoredUser tag),
    usDeleteUser ::
      route
        :- Capture "id" (UserId tag)
          :> DeleteNoContent
  }
  deriving (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 info uid op' = do
    (WithMeta _ (WithId _ (user :: User tag))) <- getUser info uid
    (newUser :: User tag) <- applyPatch user op'
    putUser info uid 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 authData =
  UserSite
    { usGetUsers = \mbFilter -> do
        auth <- authCheck @tag authData
        getUsers @tag auth mbFilter,
      usGetUser = \uid -> do
        auth <- authCheck @tag authData
        getUser @tag auth uid,
      usPostUser = \user -> do
        auth <- authCheck @tag authData
        postUser @tag auth user,
      usPutUser = \uid user -> do
        auth <- authCheck @tag authData
        putUser @tag auth uid user,
      usPatchUser = \uid patch -> do
        auth <- authCheck @tag authData
        patchUser @tag @m auth uid patch,
      usDeleteUser = \uid -> do
        auth <- authCheck @tag authData
        deleteUser @tag auth uid
        pure NoContent
    }