{-# LANGUAGE AllowAmbiguousTypes #-}

-- 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.Client
  ( HasScimClient,

    -- * config
    spConfig,
    getSchemas,
    schema,
    resourceTypes,

    -- * user
    scimClients,
    getUsers,
    getUser,
    postUser,
    patchUser,
    deleteUser,

    -- * group
    getGroups,
    getGroup,
    postGroup,
    putGroup,
    patchGroup,
    deleteGroup,
  )
where

import Control.Exception
import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Text
import Servant.API
import Servant.Client
import Servant.Client.Generic
import qualified Web.Scim.Capabilities.MetaSchema as MetaSchema
import Web.Scim.Class.Auth
import Web.Scim.Class.Group (Group, GroupId, StoredGroup)
import Web.Scim.Class.User (StoredUser)
import Web.Scim.Filter (Filter)
import Web.Scim.Schema.ListResponse (ListResponse)
import Web.Scim.Schema.PatchOp (PatchOp)
import qualified Web.Scim.Schema.ResourceType as ResourceType
import Web.Scim.Schema.User (User)
import Web.Scim.Schema.UserTypes (UserExtra, UserId)
import Web.Scim.Server

type HasScimClient tag =
  ( AuthTypes tag,
    ToJSON (UserExtra tag),
    FromJSON (UserExtra tag),
    FromJSON (UserId tag),
    FromJSON (GroupId tag),
    ToHttpApiData (AuthData tag),
    ToHttpApiData (UserId tag),
    ToHttpApiData (GroupId tag)
  )

scimClients :: (HasScimClient tag) => ClientEnv -> Site tag (AsClientT IO)
scimClients :: forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env = (forall x. ClientM x -> IO x) -> Site tag (AsClientT IO)
forall (routes :: * -> *) (m :: * -> *) (n :: * -> *).
(HasClient m (ToServantApi routes),
 GenericServant routes (AsClientT n),
 Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)) =>
(forall x. m x -> n x) -> routes (AsClientT n)
genericClientHoist ((forall x. ClientM x -> IO x) -> Site tag (AsClientT IO))
-> (forall x. ClientM x -> IO x) -> Site tag (AsClientT IO)
forall a b. (a -> b) -> a -> b
$ \ClientM x
x -> ClientM x -> ClientEnv -> IO (Either ClientError x)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM x
x ClientEnv
env IO (Either ClientError x) -> (Either ClientError x -> IO x) -> IO x
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClientError -> IO x)
-> (x -> IO x) -> Either ClientError x -> IO x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> IO x
forall e a. Exception e => e -> IO a
throwIO x -> IO x
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- config

spConfig ::
  forall tag.
  (HasScimClient tag) =>
  ClientEnv ->
  IO MetaSchema.Configuration
spConfig :: forall tag. HasScimClient tag => ClientEnv -> IO Configuration
spConfig ClientEnv
env = case forall tag route. Site tag route -> route :- ConfigAPI
config @tag (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) of ((IO Configuration
r :<|> IO (ListResponse Value)
_) :<|> (Text -> IO Value
_ :<|> IO (ListResponse Resource)
_)) -> IO Configuration
r

getSchemas ::
  forall tag.
  (HasScimClient tag) =>
  ClientEnv ->
  IO (ListResponse Value)
getSchemas :: forall tag.
HasScimClient tag =>
ClientEnv -> IO (ListResponse Value)
getSchemas ClientEnv
env = case forall tag route. Site tag route -> route :- ConfigAPI
config @tag (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) of ((IO Configuration
_ :<|> IO (ListResponse Value)
r) :<|> (Text -> IO Value
_ :<|> IO (ListResponse Resource)
_)) -> IO (ListResponse Value)
r

schema ::
  forall tag.
  (HasScimClient tag) =>
  ClientEnv ->
  Text ->
  IO Value
schema :: forall tag. HasScimClient tag => ClientEnv -> Text -> IO Value
schema ClientEnv
env = case forall tag route. Site tag route -> route :- ConfigAPI
config @tag (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) of ((IO Configuration
_ :<|> IO (ListResponse Value)
_) :<|> (Text -> IO Value
r :<|> IO (ListResponse Resource)
_)) -> Text -> IO Value
r

resourceTypes ::
  forall tag.
  (HasScimClient tag) =>
  ClientEnv ->
  IO (ListResponse ResourceType.Resource)
resourceTypes :: forall tag.
HasScimClient tag =>
ClientEnv -> IO (ListResponse Resource)
resourceTypes ClientEnv
env = case forall tag route. Site tag route -> route :- ConfigAPI
config @tag (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) of ((IO Configuration
_ :<|> IO (ListResponse Value)
_) :<|> (Text -> IO Value
_ :<|> IO (ListResponse Resource)
r)) -> IO (ListResponse Resource)
r

-- users

getUsers ::
  (HasScimClient tag) =>
  ClientEnv ->
  Maybe (AuthData tag) ->
  Maybe Filter ->
  IO (ListResponse (StoredUser tag))
getUsers :: forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag)
-> Maybe Filter
-> IO (ListResponse (StoredUser tag))
getUsers ClientEnv
env Maybe (AuthData tag)
tok = case Site tag (AsClientT IO)
-> AsClientT IO
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
forall tag route.
Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) Maybe (AuthData tag)
tok of ((Maybe Filter -> IO (ListResponse (StoredUser tag))
r :<|> (UserId tag -> IO (StoredUser tag)
_ :<|> User tag -> IO (StoredUser tag)
_)) :<|> (UserId tag -> User tag -> IO (StoredUser tag)
_ :<|> (UserId tag -> PatchOp tag -> IO (StoredUser tag)
_ :<|> UserId tag -> IO NoContent
_))) -> Maybe Filter -> IO (ListResponse (StoredUser tag))
r

getUser ::
  (HasScimClient tag) =>
  ClientEnv ->
  Maybe (AuthData tag) ->
  UserId tag ->
  IO (StoredUser tag)
getUser :: forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag) -> UserId tag -> IO (StoredUser tag)
getUser ClientEnv
env Maybe (AuthData tag)
tok = case Site tag (AsClientT IO)
-> AsClientT IO
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
forall tag route.
Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) Maybe (AuthData tag)
tok of ((Maybe Filter -> IO (ListResponse (StoredUser tag))
_ :<|> (UserId tag -> IO (StoredUser tag)
r :<|> User tag -> IO (StoredUser tag)
_)) :<|> (UserId tag -> User tag -> IO (StoredUser tag)
_ :<|> (UserId tag -> PatchOp tag -> IO (StoredUser tag)
_ :<|> UserId tag -> IO NoContent
_))) -> UserId tag -> IO (StoredUser tag)
r

postUser ::
  (HasScimClient tag) =>
  ClientEnv ->
  Maybe (AuthData tag) ->
  User tag ->
  IO (StoredUser tag)
postUser :: forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag) -> User tag -> IO (StoredUser tag)
postUser ClientEnv
env Maybe (AuthData tag)
tok = case Site tag (AsClientT IO)
-> AsClientT IO
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
forall tag route.
Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) Maybe (AuthData tag)
tok of ((Maybe Filter -> IO (ListResponse (StoredUser tag))
_ :<|> (UserId tag -> IO (StoredUser tag)
_ :<|> User tag -> IO (StoredUser tag)
r)) :<|> (UserId tag -> User tag -> IO (StoredUser tag)
_ :<|> (UserId tag -> PatchOp tag -> IO (StoredUser tag)
_ :<|> UserId tag -> IO NoContent
_))) -> User tag -> IO (StoredUser tag)
r

patchUser ::
  (HasScimClient tag) =>
  ClientEnv ->
  Maybe (AuthData tag) ->
  UserId tag ->
  PatchOp tag ->
  IO (StoredUser tag)
patchUser :: forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag)
-> UserId tag
-> PatchOp tag
-> IO (StoredUser tag)
patchUser ClientEnv
env Maybe (AuthData tag)
tok = case Site tag (AsClientT IO)
-> AsClientT IO
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
forall tag route.
Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) Maybe (AuthData tag)
tok of ((Maybe Filter -> IO (ListResponse (StoredUser tag))
_ :<|> (UserId tag -> IO (StoredUser tag)
_ :<|> User tag -> IO (StoredUser tag)
_)) :<|> (UserId tag -> User tag -> IO (StoredUser tag)
_ :<|> (UserId tag -> PatchOp tag -> IO (StoredUser tag)
r :<|> UserId tag -> IO NoContent
_))) -> UserId tag -> PatchOp tag -> IO (StoredUser tag)
r

deleteUser ::
  forall tag.
  (HasScimClient tag) =>
  ClientEnv ->
  Maybe (AuthData tag) ->
  UserId tag ->
  IO NoContent
deleteUser :: forall tag.
HasScimClient tag =>
ClientEnv -> Maybe (AuthData tag) -> UserId tag -> IO NoContent
deleteUser ClientEnv
env Maybe (AuthData tag)
tok = case forall tag route.
Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users @tag (ClientEnv -> Site tag (AsClientT IO)
forall tag.
HasScimClient tag =>
ClientEnv -> Site tag (AsClientT IO)
scimClients ClientEnv
env) Maybe (AuthData tag)
tok of ((Maybe Filter
-> IO (ListResponse (WithMeta (WithId (UserId tag) (User tag))))
_ :<|> (UserId tag -> IO (WithMeta (WithId (UserId tag) (User tag)))
_ :<|> User tag -> IO (WithMeta (WithId (UserId tag) (User tag)))
_)) :<|> (UserId tag
-> User tag -> IO (WithMeta (WithId (UserId tag) (User tag)))
_ :<|> (UserId tag
-> PatchOp tag -> IO (WithMeta (WithId (UserId tag) (User tag)))
_ :<|> UserId tag -> IO NoContent
r))) -> UserId tag -> IO NoContent
r

-- groups

getGroups ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  IO (ListResponse (StoredGroup tag))
getGroups :: forall tag.
ClientEnv
-> Maybe (AuthData tag) -> IO (ListResponse (StoredGroup tag))
getGroups = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> IO (ListResponse (WithMeta (WithId (GroupId tag) Group)))
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"

getGroup ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  GroupId tag ->
  IO (StoredGroup tag)
getGroup :: forall tag.
ClientEnv
-> Maybe (AuthData tag) -> GroupId tag -> IO (StoredGroup tag)
getGroup = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> GroupId tag
-> IO (WithMeta (WithId (GroupId tag) Group))
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"

postGroup ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  Group ->
  IO (StoredGroup tag)
postGroup :: forall tag.
ClientEnv -> Maybe (AuthData tag) -> Group -> IO (StoredGroup tag)
postGroup = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> Group
-> IO (WithMeta (WithId (GroupId tag) Group))
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"

putGroup ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  GroupId tag ->
  IO (StoredGroup tag)
putGroup :: forall tag.
ClientEnv
-> Maybe (AuthData tag) -> GroupId tag -> IO (StoredGroup tag)
putGroup = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> GroupId tag
-> IO (WithMeta (WithId (GroupId tag) Group))
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"

patchGroup ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  GroupId tag ->
  IO (StoredGroup tag)
patchGroup :: forall tag.
ClientEnv
-> Maybe (AuthData tag) -> GroupId tag -> IO (StoredGroup tag)
patchGroup = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> GroupId tag
-> IO (WithMeta (WithId (GroupId tag) Group))
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"

deleteGroup ::
  ClientEnv ->
  Maybe (AuthData tag) ->
  GroupId tag ->
  IO DeleteNoContent
deleteGroup :: forall tag.
ClientEnv
-> Maybe (AuthData tag) -> GroupId tag -> IO DeleteNoContent
deleteGroup = [Char]
-> ClientEnv
-> Maybe (AuthData tag)
-> GroupId tag
-> IO DeleteNoContent
forall a. HasCallStack => [Char] -> a
error [Char]
"groups are not authenticated at the moment; implement that first!"