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

import Data.Aeson
import qualified Data.HashMap.Lazy as HML
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
  { Supported a -> ScimBool
supported :: ScimBool,
    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
showList :: [Supported a] -> ShowS
$cshowList :: forall a. Show a => [Supported a] -> ShowS
show :: Supported a -> String
$cshow :: forall a. Show a => Supported a -> String
showsPrec :: Int -> Supported a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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
/= :: Supported a -> Supported a -> Bool
$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
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
$cto :: forall a x. Rep (Supported a) x -> Supported a
$cfrom :: forall a x. Supported a -> Rep (Supported a) x
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
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HML.insert Text
"supported" (Bool -> Value
Bool Bool
b) Object
o
    Value
_ -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HML.fromList [(Text
"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 -> Text -> Parser ScimBool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"supported") Value
val
      Parser (a -> Supported a) -> Parser a -> Parser (Supported a)
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 () -> Maybe a
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 Value -> Parser a
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
showList :: [BulkConfig] -> ShowS
$cshowList :: [BulkConfig] -> ShowS
show :: BulkConfig -> String
$cshow :: BulkConfig -> String
showsPrec :: Int -> BulkConfig -> ShowS
$cshowsPrec :: Int -> BulkConfig -> ShowS
Show, BulkConfig -> BulkConfig -> Bool
(BulkConfig -> BulkConfig -> Bool)
-> (BulkConfig -> BulkConfig -> Bool) -> Eq BulkConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BulkConfig -> BulkConfig -> Bool
$c/= :: BulkConfig -> BulkConfig -> Bool
== :: BulkConfig -> BulkConfig -> Bool
$c== :: 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
$cto :: forall x. Rep BulkConfig x -> BulkConfig
$cfrom :: forall x. BulkConfig -> Rep BulkConfig x
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 = Options -> Value -> Parser BulkConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions (Value -> Parser BulkConfig)
-> (Value -> Value) -> Value -> Parser BulkConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> 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
showList :: [FilterConfig] -> ShowS
$cshowList :: [FilterConfig] -> ShowS
show :: FilterConfig -> String
$cshow :: FilterConfig -> String
showsPrec :: Int -> FilterConfig -> ShowS
$cshowsPrec :: Int -> FilterConfig -> ShowS
Show, FilterConfig -> FilterConfig -> Bool
(FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool) -> Eq FilterConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FilterConfig -> FilterConfig -> Bool
$c/= :: FilterConfig -> FilterConfig -> Bool
== :: FilterConfig -> FilterConfig -> Bool
$c== :: 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
$cto :: forall x. Rep FilterConfig x -> FilterConfig
$cfrom :: forall x. FilterConfig -> Rep FilterConfig x
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 = Options -> Value -> Parser FilterConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions (Value -> Parser FilterConfig)
-> (Value -> Value) -> Value -> Parser FilterConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> 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
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show, Configuration -> Configuration -> Bool
(Configuration -> Configuration -> Bool)
-> (Configuration -> Configuration -> Bool) -> Eq Configuration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Configuration -> Configuration -> Bool
$c/= :: Configuration -> Configuration -> Bool
== :: Configuration -> Configuration -> Bool
$c== :: 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
$cto :: forall x. Rep Configuration x -> Configuration
$cfrom :: forall x. Configuration -> Rep Configuration x
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 = Options -> Value -> Parser Configuration
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions (Value -> Parser Configuration)
-> (Value -> Value) -> Value -> Parser Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
jsonLower

empty :: Configuration
empty :: Configuration
empty =
  Configuration :: Maybe URI
-> [Schema]
-> Supported ()
-> Supported BulkConfig
-> Supported FilterConfig
-> Supported ()
-> Supported ()
-> Supported ()
-> [AuthenticationSchemeEncoding]
-> Configuration
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 :: Configuration -> ConfigSite (AsServerT (ScimHandler m))
configServer Configuration
config =
  ConfigSite :: forall route.
(route :- ("ServiceProviderConfig" :> Get '[SCIM] Configuration))
-> (route :- ("Schemas" :> Get '[SCIM] (ListResponse Value)))
-> (route
    :- ("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value)))
-> (route
    :- ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource)))
-> ConfigSite route
ConfigSite
    { spConfig :: AsServerT (ScimHandler m)
:- ("ServiceProviderConfig" :> Get '[SCIM] Configuration)
spConfig = Configuration -> ExceptT ScimError m Configuration
forall (f :: * -> *) a. Applicative f => a -> f a
pure Configuration
config,
      getSchemas :: AsServerT (ScimHandler m)
:- ("Schemas" :> Get '[SCIM] (ListResponse Value))
getSchemas =
        ListResponse Value -> ExceptT ScimError m (ListResponse Value)
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 (ScimHandler 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 (f :: * -> *) a. Applicative f => a -> f a
pure Value
s,
      resourceTypes :: AsServerT (ScimHandler m)
:- ("ResourceTypes" :> Get '[SCIM] (ListResponse Resource))
resourceTypes =
        ListResponse Resource
-> ExceptT ScimError m (ListResponse Resource)
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
  { ConfigSite route
-> route :- ("ServiceProviderConfig" :> Get '[SCIM] Configuration)
spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration,
    ConfigSite route
-> route :- ("Schemas" :> Get '[SCIM] (ListResponse Value))
getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value),
    ConfigSite route
-> route :- ("Schemas" :> (Capture "id" Text :> Get '[SCIM] Value))
schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value,
    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
$cto :: forall route x. Rep (ConfigSite route) x -> ConfigSite route
$cfrom :: forall route x. ConfigSite route -> Rep (ConfigSite route) x
Generic)