{-# LANGUAGE AllowAmbiguousTypes #-}

-- 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.Server
  ( -- * WAI application
    app,
    mkapp,
    App,

    -- * API tree
    SiteAPI,
    Site (..),
    siteServer,

    -- ** API subtrees, useful for tests
    ConfigAPI,
    configServer,
    UserAPI,
    userServer,
    GroupAPI,
    groupServer,
  )
where

import Network.Wai
import Servant
import Servant.API.Generic
import Servant.Server.Generic
import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer)
import Web.Scim.Class.Auth (AuthDB (..), AuthTypes (..))
import Web.Scim.Class.Group (GroupDB, GroupSite (..), GroupTypes (..), groupServer)
import Web.Scim.Class.User (UserDB (..), UserSite (..), userServer)
import Web.Scim.Handler

----------------------------------------------------------------------------
-- API specification

-- | A constraint indicating that monad @m@ supports operations with users and groups marked
-- with tag @t@.
type DB tag m = (UserDB tag m, GroupDB tag m, AuthDB tag m)

type ConfigAPI = ToServantApi ConfigSite

type UserAPI tag = ToServantApi (UserSite tag)

type GroupAPI tag = ToServantApi (GroupSite tag)

type SiteAPI tag = ToServantApi (Site tag)

data Site tag route = Site
  { Site tag route -> route :- ConfigAPI
config ::
      route
        :- ConfigAPI,
    Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Users" :> UserAPI tag))
users ::
      route
        :- Header "Authorization" (AuthData tag)
        :> "Users"
        :> UserAPI tag,
    Site tag route
-> route
   :- (Header "Authorization" (AuthData tag)
       :> ("Groups" :> GroupAPI tag))
groups ::
      route
        :- Header "Authorization" (AuthData tag)
        :> "Groups"
        :> GroupAPI tag
  }
  deriving ((forall x. Site tag route -> Rep (Site tag route) x)
-> (forall x. Rep (Site tag route) x -> Site tag route)
-> Generic (Site tag route)
forall x. Rep (Site tag route) x -> Site tag route
forall x. Site tag route -> Rep (Site tag route) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tag route x. Rep (Site tag route) x -> Site tag route
forall tag route x. Site tag route -> Rep (Site tag route) x
$cto :: forall tag route x. Rep (Site tag route) x -> Site tag route
$cfrom :: forall tag route x. Site tag route -> Rep (Site tag route) x
Generic)

----------------------------------------------------------------------------
-- API implementation

siteServer ::
  forall tag m.
  (DB tag m, Show (GroupId tag)) =>
  Configuration ->
  Site tag (AsServerT (ScimHandler m))
siteServer :: Configuration -> Site tag (AsServerT (ScimHandler m))
siteServer Configuration
conf =
  Site :: forall tag route.
(route :- ConfigAPI)
-> (route
    :- (Header "Authorization" (AuthData tag)
        :> ("Users" :> UserAPI tag)))
-> (route
    :- (Header "Authorization" (AuthData tag)
        :> ("Groups" :> GroupAPI tag)))
-> Site tag route
Site
    { config :: AsServerT (ScimHandler m) :- ConfigAPI
config = ConfigSite (AsServerT (ScimHandler m))
-> ToServant ConfigSite (AsServerT (ScimHandler m))
forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant (ConfigSite (AsServerT (ScimHandler m))
 -> ToServant ConfigSite (AsServerT (ScimHandler m)))
-> ConfigSite (AsServerT (ScimHandler m))
-> ToServant ConfigSite (AsServerT (ScimHandler m))
forall a b. (a -> b) -> a -> b
$ Configuration -> ConfigSite (AsServerT (ScimHandler m))
forall (m :: * -> *).
Monad m =>
Configuration -> ConfigSite (AsServerT (ScimHandler m))
configServer Configuration
conf,
      users :: AsServerT (ScimHandler m)
:- (Header "Authorization" (AuthData tag)
    :> ("Users" :> UserAPI tag))
users = \Maybe (AuthData tag)
authData -> UserSite tag (AsServerT (ScimHandler m))
-> ToServant (UserSite tag) (AsServerT (ScimHandler m))
forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant (Maybe (AuthData tag) -> UserSite tag (AsServerT (ScimHandler m))
forall tag (m :: * -> *).
(AuthDB tag m, UserDB tag m) =>
Maybe (AuthData tag) -> UserSite tag (AsServerT (ScimHandler m))
userServer @tag Maybe (AuthData tag)
authData),
      groups :: AsServerT (ScimHandler m)
:- (Header "Authorization" (AuthData tag)
    :> ("Groups" :> GroupAPI tag))
groups = \Maybe (AuthData tag)
authData -> GroupSite tag (AsServerT (ScimHandler m))
-> ToServant (GroupSite tag) (AsServerT (ScimHandler m))
forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant (Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m))
forall tag (m :: * -> *).
(Show (GroupId tag), GroupDB tag m) =>
Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m))
groupServer @tag Maybe (AuthData tag)
authData)
    }
  where

----------------------------------------------------------------------------
-- Server-starting utilities

type App tag m api =
  ( DB tag m,
    Show (GroupId tag),
    HasServer api '[]
  )

mkapp ::
  forall tag m api.
  (App tag m api) =>
  Proxy api ->
  ServerT api (ScimHandler m) ->
  (forall a. ScimHandler m a -> Handler a) ->
  Application
mkapp :: Proxy api
-> ServerT api (ScimHandler m)
-> (forall a. ScimHandler m a -> Handler a)
-> Application
mkapp Proxy api
proxy ServerT api (ScimHandler m)
api forall a. ScimHandler m a -> Handler a
nt =
  Proxy api -> Server api -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy api
proxy (Server api -> Application) -> Server api -> Application
forall a b. (a -> b) -> a -> b
$
    Proxy api
-> (forall a. ScimHandler m a -> Handler a)
-> ServerT api (ScimHandler m)
-> Server api
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer Proxy api
proxy forall a. ScimHandler m a -> Handler a
nt ServerT api (ScimHandler m)
api

app ::
  forall tag m.
  App tag m (SiteAPI tag) =>
  Configuration ->
  (forall a. ScimHandler m a -> Handler a) ->
  Application
app :: Configuration
-> (forall a. ScimHandler m a -> Handler a) -> Application
app Configuration
c =
  Proxy
  (((("ServiceProviderConfig" :> Get '[SCIM] Configuration)
     :<|> ("Schemas" :> Get '[SCIM] (ListResponse Value)))
    :<|> (("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value))
          :<|> ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource))))
   :<|> ((Header "Authorization" (AuthData tag)
          :> ("Users"
              :> (((QueryParam "filter" Filter
                    :> Get
                         '[SCIM] (ListResponse (WithMeta (WithId (UserId tag) (User tag)))))
                   :<|> ((Capture "id" (UserId tag)
                          :> Get '[SCIM] (WithMeta (WithId (UserId tag) (User tag))))
                         :<|> (ReqBody '[SCIM] (User tag)
                               :> PostCreated
                                    '[SCIM] (WithMeta (WithId (UserId tag) (User tag))))))
                  :<|> ((Capture "id" (UserId tag)
                         :> (ReqBody '[SCIM] (User tag)
                             :> Put '[SCIM] (WithMeta (WithId (UserId tag) (User tag)))))
                        :<|> ((Capture "id" (UserId tag)
                               :> (ReqBody '[SCIM] (PatchOp tag)
                                   :> Patch '[SCIM] (WithMeta (WithId (UserId tag) (User tag)))))
                              :<|> (Capture "id" (UserId tag) :> DeleteNoContent))))))
         :<|> (Header "Authorization" (AuthData tag)
               :> ("Groups"
                   :> ((Verb
                          'GET
                          200
                          '[SCIM]
                          (ListResponse (WithMeta (WithId (GroupId tag) Group)))
                        :<|> ((Capture "id" (GroupId tag)
                               :> Get '[SCIM] (WithMeta (WithId (GroupId tag) Group)))
                              :<|> (ReqBody '[SCIM] Group
                                    :> PostCreated
                                         '[SCIM] (WithMeta (WithId (GroupId tag) Group)))))
                       :<|> ((Capture "id" (GroupId tag)
                              :> (ReqBody '[SCIM] Group
                                  :> Put '[SCIM] (WithMeta (WithId (GroupId tag) Group))))
                             :<|> ((Capture "id" (GroupId tag)
                                    :> (ReqBody '[SCIM] Value
                                        :> Patch '[SCIM] (WithMeta (WithId (GroupId tag) Group))))
                                   :<|> (Capture "id" (GroupId tag) :> DeleteNoContent))))))))
-> ServerT
     (((("ServiceProviderConfig" :> Get '[SCIM] Configuration)
        :<|> ("Schemas" :> Get '[SCIM] (ListResponse Value)))
       :<|> (("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value))
             :<|> ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource))))
      :<|> ((Header "Authorization" (AuthData tag)
             :> ("Users"
                 :> (((QueryParam "filter" Filter
                       :> Get
                            '[SCIM] (ListResponse (WithMeta (WithId (UserId tag) (User tag)))))
                      :<|> ((Capture "id" (UserId tag)
                             :> Get '[SCIM] (WithMeta (WithId (UserId tag) (User tag))))
                            :<|> (ReqBody '[SCIM] (User tag)
                                  :> PostCreated
                                       '[SCIM] (WithMeta (WithId (UserId tag) (User tag))))))
                     :<|> ((Capture "id" (UserId tag)
                            :> (ReqBody '[SCIM] (User tag)
                                :> Put '[SCIM] (WithMeta (WithId (UserId tag) (User tag)))))
                           :<|> ((Capture "id" (UserId tag)
                                  :> (ReqBody '[SCIM] (PatchOp tag)
                                      :> Patch '[SCIM] (WithMeta (WithId (UserId tag) (User tag)))))
                                 :<|> (Capture "id" (UserId tag) :> DeleteNoContent))))))
            :<|> (Header "Authorization" (AuthData tag)
                  :> ("Groups"
                      :> ((Verb
                             'GET
                             200
                             '[SCIM]
                             (ListResponse (WithMeta (WithId (GroupId tag) Group)))
                           :<|> ((Capture "id" (GroupId tag)
                                  :> Get '[SCIM] (WithMeta (WithId (GroupId tag) Group)))
                                 :<|> (ReqBody '[SCIM] Group
                                       :> PostCreated
                                            '[SCIM] (WithMeta (WithId (GroupId tag) Group)))))
                          :<|> ((Capture "id" (GroupId tag)
                                 :> (ReqBody '[SCIM] Group
                                     :> Put '[SCIM] (WithMeta (WithId (GroupId tag) Group))))
                                :<|> ((Capture "id" (GroupId tag)
                                       :> (ReqBody '[SCIM] Value
                                           :> Patch
                                                '[SCIM] (WithMeta (WithId (GroupId tag) Group))))
                                      :<|> (Capture "id" (GroupId tag) :> DeleteNoContent))))))))
     (ScimHandler m)
-> (forall a. ScimHandler m a -> Handler a)
-> Application
forall tag (m :: * -> *) api.
App tag m api =>
Proxy api
-> ServerT api (ScimHandler m)
-> (forall a. ScimHandler m a -> Handler a)
-> Application
mkapp @tag
    (Proxy (SiteAPI tag)
forall k (t :: k). Proxy t
Proxy @(SiteAPI tag))
    (Site tag (AsServerT (ScimHandler m))
-> ToServant (Site tag) (AsServerT (ScimHandler m))
forall (routes :: * -> *) mode.
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant (Site tag (AsServerT (ScimHandler m))
 -> ToServant (Site tag) (AsServerT (ScimHandler m)))
-> Site tag (AsServerT (ScimHandler m))
-> ToServant (Site tag) (AsServerT (ScimHandler m))
forall a b. (a -> b) -> a -> b
$ Configuration -> Site tag (AsServerT (ScimHandler m))
forall tag (m :: * -> *).
(DB tag m, Show (GroupId tag)) =>
Configuration -> Site tag (AsServerT (ScimHandler m))
siteServer Configuration
c)