-- 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.Capabilities.MetaSchema
  ( ConfigSite,
    configServer,
    Supported (..),
    BulkConfig (..),
    FilterConfig (..),
    Configuration (..),
    empty,
  )
where

import Data.Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Text (Text)
import Data.Typeable (Typeable, cast)
import Servant hiding (URI)
import Servant.API.Generic
import Servant.Server.Generic
import Web.Scim.Capabilities.MetaSchema.Group
import Web.Scim.Capabilities.MetaSchema.ResourceType
import Web.Scim.Capabilities.MetaSchema.SPConfig
import Web.Scim.Capabilities.MetaSchema.Schema
import Web.Scim.Capabilities.MetaSchema.User
import Web.Scim.ContentType
import Web.Scim.Handler
import qualified Web.Scim.Schema.AuthenticationScheme as AuthScheme
import Web.Scim.Schema.Common
import Web.Scim.Schema.Error hiding (schemas)
import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas)
import Web.Scim.Schema.ResourceType hiding (schema)
import Web.Scim.Schema.Schema
import Prelude hiding (filter)

data Supported a = Supported
  { forall a. Supported a -> ScimBool
supported :: ScimBool,
    forall a. Supported a -> a
subConfig :: a
  }
  deriving (Int -> Supported a -> ShowS
[Supported a] -> ShowS
Supported a -> String
(Int -> Supported a -> ShowS)
-> (Supported a -> String)
-> ([Supported a] -> ShowS)
-> Show (Supported a)
forall a. Show a => Int -> Supported a -> ShowS
forall a. Show a => [Supported a] -> ShowS
forall a. Show a => Supported a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Supported a -> ShowS
showsPrec :: Int -> Supported a -> ShowS
$cshow :: forall a. Show a => Supported a -> String
show :: Supported a -> String
$cshowList :: forall a. Show a => [Supported a] -> ShowS
showList :: [Supported a] -> ShowS
Show, Supported a -> Supported a -> Bool
(Supported a -> Supported a -> Bool)
-> (Supported a -> Supported a -> Bool) -> Eq (Supported a)
forall a. Eq a => Supported a -> Supported a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Supported a -> Supported a -> Bool
== :: Supported a -> Supported a -> Bool
$c/= :: forall a. Eq a => Supported a -> Supported a -> Bool
/= :: Supported a -> Supported a -> Bool
Eq, (forall x. Supported a -> Rep (Supported a) x)
-> (forall x. Rep (Supported a) x -> Supported a)
-> Generic (Supported a)
forall x. Rep (Supported a) x -> Supported a
forall x. Supported a -> Rep (Supported a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Supported a) x -> Supported a
forall a x. Supported a -> Rep (Supported a) x
$cfrom :: forall a x. Supported a -> Rep (Supported a) x
from :: forall x. Supported a -> Rep (Supported a) x
$cto :: forall a x. Rep (Supported a) x -> Supported a
to :: forall x. Rep (Supported a) x -> Supported a
Generic)

instance (ToJSON a) => ToJSON (Supported a) where
  toJSON :: Supported a -> Value
toJSON (Supported (ScimBool Bool
b) a
v) = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v of
    (Object Object
o) -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"supported" (Bool -> Value
Bool Bool
b) Object
o
    Value
_ -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key
"supported", Bool -> Value
Bool Bool
b)]

-- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance
-- better.
instance (Typeable a, FromJSON a) => FromJSON (Supported a) where
  parseJSON :: Value -> Parser (Supported a)
parseJSON Value
val = do
    ScimBool -> a -> Supported a
forall a. ScimBool -> a -> Supported a
Supported
      (ScimBool -> a -> Supported a)
-> Parser ScimBool -> Parser (a -> Supported a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Object -> Parser ScimBool) -> Value -> Parser ScimBool
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Supported a" (Object -> Key -> Parser ScimBool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"supported") Value
val
      Parser (a -> Supported a) -> Parser a -> Parser (Supported a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> let -- allow special case for empty subConfig (`()` does not parse from json objects)
              val' :: Value
val' = case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast @() @a () of
                Just a
_ -> Array -> Value
Array Array
forall a. Monoid a => a
mempty
                Maybe a
Nothing -> Value
val
           in forall a. FromJSON a => Value -> Parser a
parseJSON @a Value
val'

data BulkConfig = BulkConfig
  { BulkConfig -> Int
maxOperations :: Int,
    BulkConfig -> Int
maxPayloadSize :: Int
  }
  deriving (Int -> BulkConfig -> ShowS
[BulkConfig] -> ShowS
BulkConfig -> String
(Int -> BulkConfig -> ShowS)
-> (BulkConfig -> String)
-> ([BulkConfig] -> ShowS)
-> Show BulkConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BulkConfig -> ShowS
showsPrec :: Int -> BulkConfig -> ShowS
$cshow :: BulkConfig -> String
show :: BulkConfig -> String
$cshowList :: [BulkConfig] -> ShowS
showList :: [BulkConfig] -> ShowS
Show, BulkConfig -> BulkConfig -> Bool
(BulkConfig -> BulkConfig -> Bool)
-> (BulkConfig -> BulkConfig -> Bool) -> Eq BulkConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BulkConfig -> BulkConfig -> Bool
== :: BulkConfig -> BulkConfig -> Bool
$c/= :: BulkConfig -> BulkConfig -> Bool
/= :: BulkConfig -> BulkConfig -> Bool
Eq, (forall x. BulkConfig -> Rep BulkConfig x)
-> (forall x. Rep BulkConfig x -> BulkConfig) -> Generic BulkConfig
forall x. Rep BulkConfig x -> BulkConfig
forall x. BulkConfig -> Rep BulkConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BulkConfig -> Rep BulkConfig x
from :: forall x. BulkConfig -> Rep BulkConfig x
$cto :: forall x. Rep BulkConfig x -> BulkConfig
to :: forall x. Rep BulkConfig x -> BulkConfig
Generic)

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

instance FromJSON BulkConfig where
  parseJSON :: Value -> Parser BulkConfig
parseJSON = ([Text] -> Parser BulkConfig)
-> (Value -> Parser BulkConfig)
-> Either [Text] Value
-> Parser BulkConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser BulkConfig
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser BulkConfig)
-> ([Text] -> String) -> [Text] -> Parser BulkConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> String
forall a. Show a => a -> String
show) (Options -> Value -> Parser BulkConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions) (Either [Text] Value -> Parser BulkConfig)
-> (Value -> Either [Text] Value) -> Value -> Parser BulkConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either [Text] Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower

data FilterConfig = FilterConfig
  { FilterConfig -> Int
maxResults :: Int
  }
  deriving (Int -> FilterConfig -> ShowS
[FilterConfig] -> ShowS
FilterConfig -> String
(Int -> FilterConfig -> ShowS)
-> (FilterConfig -> String)
-> ([FilterConfig] -> ShowS)
-> Show FilterConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilterConfig -> ShowS
showsPrec :: Int -> FilterConfig -> ShowS
$cshow :: FilterConfig -> String
show :: FilterConfig -> String
$cshowList :: [FilterConfig] -> ShowS
showList :: [FilterConfig] -> ShowS
Show, FilterConfig -> FilterConfig -> Bool
(FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool) -> Eq FilterConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilterConfig -> FilterConfig -> Bool
== :: FilterConfig -> FilterConfig -> Bool
$c/= :: FilterConfig -> FilterConfig -> Bool
/= :: FilterConfig -> FilterConfig -> Bool
Eq, (forall x. FilterConfig -> Rep FilterConfig x)
-> (forall x. Rep FilterConfig x -> FilterConfig)
-> Generic FilterConfig
forall x. Rep FilterConfig x -> FilterConfig
forall x. FilterConfig -> Rep FilterConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FilterConfig -> Rep FilterConfig x
from :: forall x. FilterConfig -> Rep FilterConfig x
$cto :: forall x. Rep FilterConfig x -> FilterConfig
to :: forall x. Rep FilterConfig x -> FilterConfig
Generic)

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

instance FromJSON FilterConfig where
  parseJSON :: Value -> Parser FilterConfig
parseJSON = ([Text] -> Parser FilterConfig)
-> (Value -> Parser FilterConfig)
-> Either [Text] Value
-> Parser FilterConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser FilterConfig
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser FilterConfig)
-> ([Text] -> String) -> [Text] -> Parser FilterConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> String
forall a. Show a => a -> String
show) (Options -> Value -> Parser FilterConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions) (Either [Text] Value -> Parser FilterConfig)
-> (Value -> Either [Text] Value) -> Value -> Parser FilterConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either [Text] Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower

data Configuration = Configuration
  { Configuration -> Maybe URI
documentationUri :: Maybe URI,
    Configuration -> [Schema]
schemas :: [Schema],
    Configuration -> Supported ()
patch :: Supported (),
    Configuration -> Supported BulkConfig
bulk :: Supported BulkConfig,
    Configuration -> Supported FilterConfig
filter :: Supported FilterConfig,
    Configuration -> Supported ()
changePassword :: Supported (),
    Configuration -> Supported ()
sort :: Supported (),
    Configuration -> Supported ()
etag :: Supported (),
    Configuration -> [AuthenticationSchemeEncoding]
authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding]
  }
  deriving (Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
(Int -> Configuration -> ShowS)
-> (Configuration -> String)
-> ([Configuration] -> ShowS)
-> Show Configuration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Configuration -> ShowS
showsPrec :: Int -> Configuration -> ShowS
$cshow :: Configuration -> String
show :: Configuration -> String
$cshowList :: [Configuration] -> ShowS
showList :: [Configuration] -> ShowS
Show, Configuration -> Configuration -> Bool
(Configuration -> Configuration -> Bool)
-> (Configuration -> Configuration -> Bool) -> Eq Configuration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Configuration -> Configuration -> Bool
== :: Configuration -> Configuration -> Bool
$c/= :: Configuration -> Configuration -> Bool
/= :: Configuration -> Configuration -> Bool
Eq, (forall x. Configuration -> Rep Configuration x)
-> (forall x. Rep Configuration x -> Configuration)
-> Generic Configuration
forall x. Rep Configuration x -> Configuration
forall x. Configuration -> Rep Configuration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Configuration -> Rep Configuration x
from :: forall x. Configuration -> Rep Configuration x
$cto :: forall x. Rep Configuration x -> Configuration
to :: forall x. Rep Configuration x -> Configuration
Generic)

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

instance FromJSON Configuration where
  parseJSON :: Value -> Parser Configuration
parseJSON = ([Text] -> Parser Configuration)
-> (Value -> Parser Configuration)
-> Either [Text] Value
-> Parser Configuration
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Configuration
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Configuration)
-> ([Text] -> String) -> [Text] -> Parser Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> String
forall a. Show a => a -> String
show) (Options -> Value -> Parser Configuration
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions) (Either [Text] Value -> Parser Configuration)
-> (Value -> Either [Text] Value) -> Value -> Parser Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either [Text] Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower

empty :: Configuration
empty :: Configuration
empty =
  Configuration
    { documentationUri :: Maybe URI
documentationUri = Maybe URI
forall a. Maybe a
Nothing,
      schemas :: [Schema]
schemas =
        [ Schema
User20,
          Schema
ServiceProviderConfig20,
          Schema
Group20,
          Schema
Schema20,
          Schema
ResourceType20
        ],
      patch :: Supported ()
patch = ScimBool -> () -> Supported ()
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
True) (),
      bulk :: Supported BulkConfig
bulk = ScimBool -> BulkConfig -> Supported BulkConfig
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
False) (BulkConfig -> Supported BulkConfig)
-> BulkConfig -> Supported BulkConfig
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BulkConfig
BulkConfig Int
0 Int
0,
      filter :: Supported FilterConfig
filter = ScimBool -> FilterConfig -> Supported FilterConfig
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
False) (FilterConfig -> Supported FilterConfig)
-> FilterConfig -> Supported FilterConfig
forall a b. (a -> b) -> a -> b
$ Int -> FilterConfig
FilterConfig Int
0,
      changePassword :: Supported ()
changePassword = ScimBool -> () -> Supported ()
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
False) (),
      sort :: Supported ()
sort = ScimBool -> () -> Supported ()
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
False) (),
      etag :: Supported ()
etag = ScimBool -> () -> Supported ()
forall a. ScimBool -> a -> Supported a
Supported (Bool -> ScimBool
ScimBool Bool
False) (),
      authenticationSchemes :: [AuthenticationSchemeEncoding]
authenticationSchemes = [AuthenticationSchemeEncoding
AuthScheme.authHttpBasicEncoding]
    }

configServer ::
  (Monad m) =>
  Configuration ->
  ConfigSite (AsServerT (ScimHandler m))
configServer :: forall (m :: * -> *).
Monad m =>
Configuration -> ConfigSite (AsServerT (ScimHandler m))
configServer Configuration
config =
  ConfigSite
    { spConfig :: AsServerT (ExceptT ScimError m)
:- ("ServiceProviderConfig" :> Get '[SCIM] Configuration)
spConfig = Configuration -> ExceptT ScimError m Configuration
forall a. a -> ExceptT ScimError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Configuration
config,
      getSchemas :: AsServerT (ExceptT ScimError m)
:- ("Schemas" :> Get '[SCIM] (ListResponse Value))
getSchemas =
        ListResponse Value -> ExceptT ScimError m (ListResponse Value)
forall a. a -> ExceptT ScimError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListResponse Value -> ExceptT ScimError m (ListResponse Value))
-> ListResponse Value -> ExceptT ScimError m (ListResponse Value)
forall a b. (a -> b) -> a -> b
$
          [Value] -> ListResponse Value
forall a. [a] -> ListResponse a
ListResponse.fromList
            [ Value
userSchema,
              Value
spConfigSchema,
              Value
groupSchema,
              Value
metaSchema,
              Value
resourceSchema
            ],
      schema :: AsServerT (ExceptT ScimError m)
:- ("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value))
schema = \Text
uri -> case Schema -> Maybe Value
getSchema (Text -> Schema
fromSchemaUri Text
uri) of
        Maybe Value
Nothing -> ScimError -> ScimHandler m Value
forall (m :: * -> *) a. Monad m => ScimError -> ScimHandler m a
throwScim (Text -> Text -> ScimError
notFound Text
"Schema" Text
uri)
        Just Value
s -> Value -> ScimHandler m Value
forall a. a -> ExceptT ScimError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
s,
      resourceTypes :: AsServerT (ExceptT ScimError m)
:- ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource))
resourceTypes =
        ListResponse Resource
-> ExceptT ScimError m (ListResponse Resource)
forall a. a -> ExceptT ScimError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListResponse Resource
 -> ExceptT ScimError m (ListResponse Resource))
-> ListResponse Resource
-> ExceptT ScimError m (ListResponse Resource)
forall a b. (a -> b) -> a -> b
$
          [Resource] -> ListResponse Resource
forall a. [a] -> ListResponse a
ListResponse.fromList
            [ Resource
usersResource,
              Resource
groupsResource
            ]
    }

data ConfigSite route = ConfigSite
  { forall route.
ConfigSite route
-> route :- ("ServiceProviderConfig" :> Get '[SCIM] Configuration)
spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration,
    forall route.
ConfigSite route
-> route :- ("Schemas" :> Get '[SCIM] (ListResponse Value))
getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value),
    forall route.
ConfigSite route
-> route :- ("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value))
schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value,
    forall route.
ConfigSite route
-> route
   :- ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource))
resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource)
  }
  deriving ((forall x. ConfigSite route -> Rep (ConfigSite route) x)
-> (forall x. Rep (ConfigSite route) x -> ConfigSite route)
-> Generic (ConfigSite route)
forall x. Rep (ConfigSite route) x -> ConfigSite route
forall x. ConfigSite route -> Rep (ConfigSite route) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall route x. Rep (ConfigSite route) x -> ConfigSite route
forall route x. ConfigSite route -> Rep (ConfigSite route) x
$cfrom :: forall route x. ConfigSite route -> Rep (ConfigSite route) x
from :: forall x. ConfigSite route -> Rep (ConfigSite route) x
$cto :: forall route x. Rep (ConfigSite route) x -> ConfigSite route
to :: forall x. Rep (ConfigSite route) x -> ConfigSite route
Generic)