{-# 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.Class.Group
  ( GroupSite (..),
    GroupDB (..),
    GroupTypes (..),
    StoredGroup,
    Group (..),
    Member (..),
    groupServer,
  )
where

import Data.Aeson
import qualified Data.Aeson as Aeson
import Data.Text
import Servant
import Servant.API.Generic
import Servant.Server.Generic
import Web.Scim.Class.Auth
import Web.Scim.ContentType
import Web.Scim.Handler
import Web.Scim.Schema.Common
import Web.Scim.Schema.ListResponse
import Web.Scim.Schema.Meta

----------------------------------------------------------------------------
-- /Groups API

type Schema = Text

-- | Configurable parts of 'Group'.
class GroupTypes tag where
  -- | Group ID type.
  type GroupId tag

-- TODO
data Member = Member
  { Member -> Text
value :: Text,
    Member -> Text
typ :: Text,
    Member -> Text
ref :: Text
  }
  deriving (Int -> Member -> ShowS
[Member] -> ShowS
Member -> String
(Int -> Member -> ShowS)
-> (Member -> String) -> ([Member] -> ShowS) -> Show Member
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Member] -> ShowS
$cshowList :: [Member] -> ShowS
show :: Member -> String
$cshow :: Member -> String
showsPrec :: Int -> Member -> ShowS
$cshowsPrec :: Int -> Member -> ShowS
Show, Member -> Member -> Bool
(Member -> Member -> Bool)
-> (Member -> Member -> Bool) -> Eq Member
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Member -> Member -> Bool
$c/= :: Member -> Member -> Bool
== :: Member -> Member -> Bool
$c== :: Member -> Member -> Bool
Eq, (forall x. Member -> Rep Member x)
-> (forall x. Rep Member x -> Member) -> Generic Member
forall x. Rep Member x -> Member
forall x. Member -> Rep Member x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Member x -> Member
$cfrom :: forall x. Member -> Rep Member x
Generic)

instance FromJSON Member where
  parseJSON :: Value -> Parser Member
parseJSON = Options -> Value -> Parser Member
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions (Value -> Parser Member)
-> (Value -> Value) -> Value -> Parser Member
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
jsonLower

instance ToJSON Member where
  toJSON :: Member -> Value
toJSON = Options -> Member -> Value
forall a.
(Generic a, GToJSON Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
serializeOptions

data Group = Group
  { Group -> [Text]
schemas :: [Schema],
    Group -> Text
displayName :: Text,
    Group -> [Member]
members :: [Member]
  }
  deriving (Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
(Int -> Group -> ShowS)
-> (Group -> String) -> ([Group] -> ShowS) -> Show Group
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Group] -> ShowS
$cshowList :: [Group] -> ShowS
show :: Group -> String
$cshow :: Group -> String
showsPrec :: Int -> Group -> ShowS
$cshowsPrec :: Int -> Group -> ShowS
Show, Group -> Group -> Bool
(Group -> Group -> Bool) -> (Group -> Group -> Bool) -> Eq Group
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Group -> Group -> Bool
$c/= :: Group -> Group -> Bool
== :: Group -> Group -> Bool
$c== :: Group -> Group -> Bool
Eq, (forall x. Group -> Rep Group x)
-> (forall x. Rep Group x -> Group) -> Generic Group
forall x. Rep Group x -> Group
forall x. Group -> Rep Group x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Group x -> Group
$cfrom :: forall x. Group -> Rep Group x
Generic)

instance FromJSON Group where
  parseJSON :: Value -> Parser Group
parseJSON = Options -> Value -> Parser Group
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions (Value -> Parser Group)
-> (Value -> Value) -> Value -> Parser Group
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
jsonLower

instance ToJSON Group where
  toJSON :: Group -> Value
toJSON = Options -> Group -> Value
forall a.
(Generic a, GToJSON Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
serializeOptions

type StoredGroup tag = WithMeta (WithId (GroupId tag) Group)

data GroupSite tag route = GroupSite
  { GroupSite tag route
-> route :- Get '[SCIM] (ListResponse (StoredGroup tag))
gsGetGroups ::
      route
        :- Get '[SCIM] (ListResponse (StoredGroup tag)),
    GroupSite tag route
-> route
   :- (Capture "id" (GroupId tag) :> Get '[SCIM] (StoredGroup tag))
gsGetGroup ::
      route
        :- Capture "id" (GroupId tag)
        :> Get '[SCIM] (StoredGroup tag),
    GroupSite tag route
-> route
   :- (ReqBody '[SCIM] Group :> PostCreated '[SCIM] (StoredGroup tag))
gsPostGroup ::
      route
        :- ReqBody '[SCIM] Group
        :> PostCreated '[SCIM] (StoredGroup tag),
    GroupSite tag route
-> route
   :- (Capture "id" (GroupId tag)
       :> (ReqBody '[SCIM] Group :> Put '[SCIM] (StoredGroup tag)))
gsPutGroup ::
      route
        :- Capture "id" (GroupId tag)
        :> ReqBody '[SCIM] Group
        :> Put '[SCIM] (StoredGroup tag),
    GroupSite tag route
-> route
   :- (Capture "id" (GroupId tag)
       :> (ReqBody '[SCIM] Value :> Patch '[SCIM] (StoredGroup tag)))
gsPatchGroup ::
      route
        :- Capture "id" (GroupId tag)
        :> ReqBody '[SCIM] Aeson.Value
        :> Patch '[SCIM] (StoredGroup tag),
    GroupSite tag route
-> route :- (Capture "id" (GroupId tag) :> DeleteNoContent)
gsDeleteGroup ::
      route
        :- Capture "id" (GroupId tag)
        :> DeleteNoContent
  }
  deriving ((forall x. GroupSite tag route -> Rep (GroupSite tag route) x)
-> (forall x. Rep (GroupSite tag route) x -> GroupSite tag route)
-> Generic (GroupSite tag route)
forall x. Rep (GroupSite tag route) x -> GroupSite tag route
forall x. GroupSite tag route -> Rep (GroupSite tag route) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tag route x.
Rep (GroupSite tag route) x -> GroupSite tag route
forall tag route x.
GroupSite tag route -> Rep (GroupSite tag route) x
$cto :: forall tag route x.
Rep (GroupSite tag route) x -> GroupSite tag route
$cfrom :: forall tag route x.
GroupSite tag route -> Rep (GroupSite tag route) x
Generic)

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

class (Monad m, GroupTypes tag, AuthDB tag m) => GroupDB tag m where
  -- | Get all groups.
  getGroups ::
    AuthInfo tag ->
    ScimHandler m (ListResponse (StoredGroup tag))

  -- | Get a single group by ID.
  --
  -- Should throw 'notFound' if the group does not.
  getGroup ::
    AuthInfo tag ->
    GroupId tag ->
    ScimHandler m (StoredGroup tag)

  -- | Create a new group.
  --
  -- Should throw 'conflict' if uniqueness constraints are violated.
  postGroup ::
    AuthInfo tag ->
    Group ->
    ScimHandler m (StoredGroup tag)

  -- | Overwrite an existing group.
  --
  -- Should throw 'notFound' if the group does not exist, and 'conflict' if uniqueness
  -- constraints are violated.
  putGroup ::
    AuthInfo tag ->
    GroupId tag ->
    Group ->
    ScimHandler m (StoredGroup tag)

  -- | Modify an existing group.
  --
  -- Should throw 'notFound' if the group doesn't exist, and 'conflict' if uniqueness
  -- constraints are violated.
  --
  -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value').
  -- See <https://tools.ietf.org/html/rfc7644#section-3.5.2>
  patchGroup ::
    AuthInfo tag ->
    GroupId tag ->
    -- | PATCH payload
    Aeson.Value ->
    ScimHandler m (StoredGroup tag)

  -- | Delete a group.
  --
  -- Should throw 'notFound' if the group does not exist.
  deleteGroup ::
    AuthInfo tag ->
    GroupId tag ->
    ScimHandler m ()

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

groupServer ::
  forall tag m.
  (Show (GroupId tag), GroupDB tag m) =>
  Maybe (AuthData tag) ->
  GroupSite tag (AsServerT (ScimHandler m))
groupServer :: Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m))
groupServer Maybe (AuthData tag)
authData =
  GroupSite :: forall tag route.
(route :- Get '[SCIM] (ListResponse (StoredGroup tag)))
-> (route
    :- (Capture "id" (GroupId tag) :> Get '[SCIM] (StoredGroup tag)))
-> (route
    :- (ReqBody '[SCIM] Group
        :> PostCreated '[SCIM] (StoredGroup tag)))
-> (route
    :- (Capture "id" (GroupId tag)
        :> (ReqBody '[SCIM] Group :> Put '[SCIM] (StoredGroup tag))))
-> (route
    :- (Capture "id" (GroupId tag)
        :> (ReqBody '[SCIM] Value :> Patch '[SCIM] (StoredGroup tag))))
-> (route :- (Capture "id" (GroupId tag) :> DeleteNoContent))
-> GroupSite tag route
GroupSite
    { gsGetGroups :: AsServerT (ScimHandler m)
:- Get '[SCIM] (ListResponse (StoredGroup tag))
gsGetGroups = 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
-> ExceptT ScimError m (ListResponse (StoredGroup tag))
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag -> ScimHandler m (ListResponse (StoredGroup tag))
getGroups @tag AuthInfo tag
auth,
      gsGetGroup :: AsServerT (ScimHandler m)
:- (Capture "id" (GroupId tag) :> Get '[SCIM] (StoredGroup tag))
gsGetGroup = \GroupId tag
gid -> 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
-> GroupId tag -> ExceptT ScimError m (StoredGroup tag)
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag -> GroupId tag -> ScimHandler m (StoredGroup tag)
getGroup @tag AuthInfo tag
auth GroupId tag
gid,
      gsPostGroup :: AsServerT (ScimHandler m)
:- (ReqBody '[SCIM] Group :> PostCreated '[SCIM] (StoredGroup tag))
gsPostGroup = \Group
gr -> 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 -> Group -> ExceptT ScimError m (StoredGroup tag)
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag -> Group -> ScimHandler m (StoredGroup tag)
postGroup @tag AuthInfo tag
auth Group
gr,
      gsPutGroup :: AsServerT (ScimHandler m)
:- (Capture "id" (GroupId tag)
    :> (ReqBody '[SCIM] Group :> Put '[SCIM] (StoredGroup tag)))
gsPutGroup = \GroupId tag
gid Group
gr -> 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
-> GroupId tag -> Group -> ExceptT ScimError m (StoredGroup tag)
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag
-> GroupId tag -> Group -> ScimHandler m (StoredGroup tag)
putGroup @tag AuthInfo tag
auth GroupId tag
gid Group
gr,
      gsPatchGroup :: AsServerT (ScimHandler m)
:- (Capture "id" (GroupId tag)
    :> (ReqBody '[SCIM] Value :> Patch '[SCIM] (StoredGroup tag)))
gsPatchGroup = \GroupId tag
gid Value
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
-> GroupId tag -> Value -> ExceptT ScimError m (StoredGroup tag)
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag
-> GroupId tag -> Value -> ScimHandler m (StoredGroup tag)
patchGroup @tag AuthInfo tag
auth GroupId tag
gid Value
patch,
      gsDeleteGroup :: AsServerT (ScimHandler m)
:- (Capture "id" (GroupId tag) :> DeleteNoContent)
gsDeleteGroup = \GroupId tag
gid -> 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 -> GroupId tag -> ScimHandler m ()
forall tag (m :: * -> *).
GroupDB tag m =>
AuthInfo tag -> GroupId tag -> ScimHandler m ()
deleteGroup @tag AuthInfo tag
auth GroupId tag
gid
        NoContent -> ExceptT ScimError m NoContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent
    }