[WPB-27953] SCIM: advertise all schemas used in User (fixes RFC compliance issue).

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).

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

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": <urn>, "required": <bool>}@.
+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,13 +100,15 @@ usersResource =
   Resource
     { name = "User",
       endpoint = URI [relativeReference|/Users|],
-      schema = User20
+      schema = User20,
+      schemaExtensions = []
     }
 
 groupsResource :: Resource
 groupsResource =
   Resource
     { name = "Group",
       endpoint = URI [relativeReference|/Groups|],
-      schema = Group20
+      schema = Group20,
+      schemaExtensions = []
     }

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)
     }

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) =>

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 =

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
+  ]