diff --git a/changelog.d/1-api-changes/WPB-27953-scim_-advertise-all-schemas-used-in-user-_fixes-rfc-compliance-issue_ b/changelog.d/1-api-changes/WPB-27953-scim_-advertise-all-schemas-used-in-user-_fixes-rfc-compliance-issue_ new file mode 100644 index 00000000000..0bf2f98a733 --- /dev/null +++ b/changelog.d/1-api-changes/WPB-27953-scim_-advertise-all-schemas-used-in-user-_fixes-rfc-compliance-issue_ @@ -0,0 +1 @@ +SCIM: advertise all schemas used in User (fixes RFC compliance issue). diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 4bdaf265af3..4d8e812f042 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -18,6 +18,7 @@ module Web.Scim.Capabilities.MetaSchema ( ConfigSite, configServer, + defaultResourceTypes, Supported (..), BulkConfig (..), FilterConfig (..), @@ -133,11 +134,19 @@ empty = authenticationSchemes = [AuthScheme.authHttpBasicEncoding] } +-- | The resource types advertised by a server that has not customised them: +-- the plain @User@ and @Group@ resources with no schema extensions. +defaultResourceTypes :: [Resource] +defaultResourceTypes = [usersResource, groupsResource] + configServer :: (Monad m) => Configuration -> + -- | The resource types to advertise at @/ResourceTypes@. Pass + -- 'defaultResourceTypes' unless the server supports schema extensions. + [Resource] -> ConfigSite (AsServerT (ScimHandler m)) -configServer config = +configServer config resourceTypes' = ConfigSite { spConfig = pure config, getSchemas = @@ -152,12 +161,7 @@ configServer config = schema = \uri -> case getSchema (fromSchemaUri uri) of Nothing -> throwScim (notFound "Schema" uri) Just s -> pure s, - resourceTypes = - pure $ - ListResponse.fromList - [ usersResource, - groupsResource - ] + resourceTypes = pure $ ListResponse.fromList resourceTypes' } data ConfigSite route = ConfigSite diff --git a/libs/hscim/src/Web/Scim/Schema/ResourceType.hs b/libs/hscim/src/Web/Scim/Schema/ResourceType.hs index 2020e3c50a3..37fa5e022c8 100644 --- a/libs/hscim/src/Web/Scim/Schema/ResourceType.hs +++ b/libs/hscim/src/Web/Scim/Schema/ResourceType.hs @@ -45,18 +45,52 @@ instance FromJSON ResourceType where other -> fail ("unknown ResourceType: " ++ show other) -- | Definitions of endpoints, returned by @/ResourceTypes@. +-- | A schema extension advertised by a 'Resource', as defined in RFC 7643 +-- section 6. Serialises to @{"schema": , "required": }@. +data SchemaExtension = SchemaExtension + { schemaExtensionSchema :: Schema, + schemaExtensionRequired :: Bool + } + deriving (Show, Eq, Generic) + +instance ToJSON SchemaExtension where + toJSON (SchemaExtension sch req) = + object ["schema" .= sch, "required" .= req] + +instance FromJSON SchemaExtension where + parseJSON = either (fail . show) go . jsonLower + where + go = withObject "SchemaExtension" $ \o -> + SchemaExtension <$> o .: "schema" <*> o .:? "required" .!= False + data Resource = Resource { name :: Text, endpoint :: URI, - schema :: Schema + schema :: Schema, + schemaExtensions :: [SchemaExtension] } deriving (Show, Eq, Generic) instance ToJSON Resource where - toJSON = genericToJSON serializeOptions + toJSON (Resource name' endpoint' schema' exts) = + object $ + [ "name" .= name', + "endpoint" .= endpoint', + "schema" .= schema' + ] + -- omit the field entirely when there are no extensions, so resources + -- without extensions keep their previous representation. + <> ["schemaExtensions" .= exts | not (null exts)] instance FromJSON Resource where - parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower + parseJSON = either (fail . show) go . jsonLower + where + go = withObject "Resource" $ \o -> + Resource + <$> o .: "name" + <*> o .: "endpoint" + <*> o .: "schema" + <*> o .:? "schemaextensions" .!= [] ---------------------------------------------------------------------------- -- Available resource endpoints @@ -66,7 +100,8 @@ usersResource = Resource { name = "User", endpoint = URI [relativeReference|/Users|], - schema = User20 + schema = User20, + schemaExtensions = [] } groupsResource :: Resource @@ -74,5 +109,6 @@ groupsResource = Resource { name = "Group", endpoint = URI [relativeReference|/Groups|], - schema = Group20 + schema = Group20, + schemaExtensions = [] } diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index 364f382b0fb..216dccb6594 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -42,7 +42,7 @@ import Network.Wai import Servant import Servant.API.Generic import Servant.Server.Generic -import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) +import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer, defaultResourceTypes) import Web.Scim.Class.Auth (AuthDB (..), AuthTypes (..)) import Web.Scim.Class.Group (GroupDB, GroupSite (..), GroupTypes (..), groupServer) import Web.Scim.Class.User (UserDB (..), UserSite (..), userServer) @@ -90,7 +90,7 @@ siteServer :: Site tag (AsServerT (ScimHandler m)) siteServer conf = Site - { config = toServant $ configServer conf, + { config = toServant $ configServer conf defaultResourceTypes, users = \authData -> toServant (userServer @tag authData), groups = \authData -> toServant (groupServer @tag authData) } diff --git a/libs/hscim/test/Test/Capabilities/MetaSchemaSpec.hs b/libs/hscim/test/Test/Capabilities/MetaSchemaSpec.hs index ec456f4d8e9..67577d4d84d 100644 --- a/libs/hscim/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/libs/hscim/test/Test/Capabilities/MetaSchemaSpec.hs @@ -39,7 +39,7 @@ import Web.Scim.Test.Util app :: IO Application app = do storage <- emptyTestStorage - pure $ mkapp @Mock (Proxy @ConfigAPI) (toServant (configServer empty)) (nt storage) + pure $ mkapp @Mock (Proxy @ConfigAPI) (toServant (configServer empty defaultResourceTypes)) (nt storage) shouldSatisfy :: (Show a, FromJSON a) => diff --git a/libs/hscim/test/Test/Schema/ResourceSpec.hs b/libs/hscim/test/Test/Schema/ResourceSpec.hs index d699201ff9c..365d9613107 100644 --- a/libs/hscim/test/Test/Schema/ResourceSpec.hs +++ b/libs/hscim/test/Test/Schema/ResourceSpec.hs @@ -24,6 +24,7 @@ import Data.Aeson import HaskellWorks.Hspec.Hedgehog (require) import Hedgehog import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Hspec import Test.Schema.Util (genUri, mk_prop_caseInsensitive) import Web.Scim.Schema.ResourceType @@ -38,15 +39,45 @@ spec :: Spec spec = do it "roundtrip" $ do require prop_roundtrip + it "case-insensitive" $ do require $ mk_prop_caseInsensitive genResource + it "omits schemaExtensions when there are none" $ do + toJSON usersResource + `shouldBe` object + [ "endpoint" .= String "/Users", + "name" .= String "User", + "schema" .= String "urn:ietf:params:scim:schemas:core:2.0:User" + ] + + it "serialises a schema extension in RFC 7643 shape" $ do + toJSON (SchemaExtension (Schema.CustomSchema "urn:example:X") True) + `shouldBe` object + [ "schema" .= String "urn:example:X", + "required" .= True + ] + + it "user schema with extension also works" $ do + toJSON (usersResource {schemaExtensions = [SchemaExtension (Schema.CustomSchema "urn:example:X") True]}) + `shouldBe` object + [ "endpoint" .= String "/Users", + "name" .= String "User", + "schema" .= String "urn:ietf:params:scim:schemas:core:2.0:User", + "schemaExtensions" .= [object ["schema" .= String "urn:example:X", "required" .= True]] + ] + genResource :: Gen Resource genResource = Resource <$> Gen.element ["name1", "name2", "name3"] <*> genUri <*> genSchema + <*> Gen.list (Range.linear 0 3) genSchemaExtension + +genSchemaExtension :: Gen SchemaExtension +genSchemaExtension = + SchemaExtension <$> genSchema <*> Gen.bool genSchema :: Gen Schema.Schema genSchema = diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 02e6b5a60c6..3638c6e9043 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -59,6 +59,7 @@ module Spar.Scim -- * API implementation apiScim, + sparResourceTypes, ) where @@ -91,6 +92,7 @@ import qualified Web.Scim.Class.Group as Scim.Group import qualified Web.Scim.Class.User as Scim.User import qualified Web.Scim.Handler as Scim import qualified Web.Scim.Schema.Error as Scim +import qualified Web.Scim.Schema.ResourceType as Scim.ResourceType import qualified Web.Scim.Schema.Schema as Scim.Schema import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar @@ -190,7 +192,23 @@ server :: ScimSite tag (AsServerT (Scim.ScimHandler m)) server conf = ScimSite - { config = toServant $ Scim.configServer conf, + { config = toServant $ Scim.configServer conf sparResourceTypes, users = \authData -> toServant (Scim.userServer @tag authData), groups = \authData -> toServant (Scim.groupServer @tag authData) } + +-- | The SCIM resource types advertised at @/ResourceTypes@. Unlike the hscim +-- default, the @User@ resource declares the Wire schema extensions that our user +-- responses actually contain (see 'userSchemas'), so that the advertised schemas +-- match the responses as required by RFC 7643 section 6 (issue #5436). +sparResourceTypes :: [Scim.ResourceType.Resource] +sparResourceTypes = + [ Scim.ResourceType.usersResource + { Scim.ResourceType.schemaExtensions = + [ Scim.ResourceType.SchemaExtension sch False + | sch <- userSchemas, + sch /= Scim.Schema.User20 + ] + }, + Scim.ResourceType.groupsResource + ]