Normalize scim data before responding to POST /scim/v2/Users.

libs/hscim/src/Web/Scim/Schema/Schema.hs

@@ -41,6 +41,23 @@ data Schema
   | CustomSchema Text
   deriving (Show, Eq)
 
+fakeEnumSchema :: [Schema]
+fakeEnumSchema =
+  [ User20,
+    ServiceProviderConfig20,
+    Group20,
+    Schema20,
+    ResourceType20,
+    ListResponse20,
+    Error20,
+    PatchOp20,
+    CustomSchema "",
+    CustomSchema "asdf",
+    CustomSchema "123",
+    CustomSchema "aos8wejv09837",
+    CustomSchema "aos8wejv09837wfeu09wuee0976t0213!!'#@"
+  ]
+
 instance FromJSON Schema where
   parseJSON = withText "schema" $ \t -> pure (fromSchemaUri t)
 

libs/wire-api/src/Wire/API/User/RichInfo.hs

@@ -37,6 +37,7 @@ module Wire.API.User.RichInfo
 
     -- * RichField
     RichField (..),
+    WithNormalizedRichFields (..),
 
     -- * Swagger
     modelRichInfo,
@@ -76,6 +77,9 @@ instance FromJSON RichInfo where
 instance Arbitrary RichInfo where
   arbitrary = RichInfo <$> arbitrary
 
+instance Arbitrary (WithNormalizedRichFields RichInfo) where
+  arbitrary = WithNormalizedRichFields . RichInfo . fromWithNormalizedRichFields <$> arbitrary
+
 instance Monoid RichInfo where
   mempty = RichInfo mempty
 
@@ -171,6 +175,12 @@ instance Arbitrary RichInfoMapAndList where
     richInfoMap <- arbitrary
     pure RichInfoMapAndList {..}
 
+instance Arbitrary (WithNormalizedRichFields RichInfoMapAndList) where
+  arbitrary = do
+    al <- unRichInfoAssocList . fromWithNormalizedRichFields <$> arbitrary
+    let mp = Map.fromList $ (\(RichField key val) -> (key, val)) <$> al
+    pure . WithNormalizedRichFields $ RichInfoMapAndList mp al
+
 -- | Lossy transformation of map-and-list representation into list-only representation.  The
 -- order of the list part of 'RichInfo' is not changed in the output; keys in the map that do
 -- not appear in the list are appended in alpha order.
@@ -238,6 +248,9 @@ richInfoAssocListFromObject richinfoObj = do
 instance Arbitrary RichInfoAssocList where
   arbitrary = RichInfoAssocList <$> nubOrdOn richFieldType <$> arbitrary
 
+instance Arbitrary (WithNormalizedRichFields RichInfoAssocList) where
+  arbitrary = WithNormalizedRichFields . normalizeRichInfoAssocList <$> arbitrary
+
 --------------------------------------------------------------------------------
 -- RichField
 
@@ -276,7 +289,13 @@ instance Arbitrary RichField where
   arbitrary =
     RichField
       <$> (CI.mk . cs . QC.getPrintableString <$> arbitrary)
-      <*> (cs . QC.getPrintableString <$> arbitrary `QC.suchThat` (/= QC.PrintableString "")) -- This is required because FromJSON calls @normalizeRichInfo*@ and roundtrip tests fail
+      <*> (cs . QC.getPrintableString <$> arbitrary)
+
+----------------------------------------------------------------------
+-- WithNormalizedRichFields
+
+newtype WithNormalizedRichFields a = WithNormalizedRichFields {fromWithNormalizedRichFields :: a}
+  deriving newtype (Eq, Ord, Show, Generic)
 
 --------------------------------------------------------------------------------
 -- convenience functions
@@ -297,7 +316,6 @@ normalizeRichInfoMapAndList (RichInfoMapAndList rifMap assocList) =
       richInfoMap = rifMap
     }
 
--- | Remove fields with @""@ values.
 normalizeRichInfoAssocList :: RichInfoAssocList -> RichInfoAssocList
 normalizeRichInfoAssocList (RichInfoAssocList l) =
   RichInfoAssocList $ filter (not . Text.null . richFieldValue) l

libs/wire-api/src/Wire/API/User/Scim.hs

@@ -68,17 +68,20 @@ import Imports
 import qualified SAML2.WebSSO as SAML
 import SAML2.WebSSO.Test.Arbitrary ()
 import Servant.API (FromHttpApiData (..), ToHttpApiData (..))
+import qualified Test.QuickCheck as QC
 import Web.HttpApiData (parseHeaderWithPrefix)
 import Web.Scim.AttrName (AttrName (..))
 import qualified Web.Scim.Class.Auth as Scim.Auth
 import qualified Web.Scim.Class.Group as Scim.Group
 import qualified Web.Scim.Class.User as Scim.User
 import Web.Scim.Filter (AttrPath (..))
+import qualified Web.Scim.Schema.Common as Scim
 import qualified Web.Scim.Schema.Error as Scim
 import Web.Scim.Schema.PatchOp (Operation (..), Path (NormalPath))
 import qualified Web.Scim.Schema.PatchOp as Scim
 import Web.Scim.Schema.Schema (Schema (CustomSchema))
 import qualified Web.Scim.Schema.Schema as Scim
+import qualified Web.Scim.Schema.User as Scim
 import qualified Web.Scim.Schema.User as Scim.User
 import Wire.API.User.Identity (Email)
 import Wire.API.User.Profile as BT
@@ -238,6 +241,41 @@ instance A.FromJSON ScimUserExtra where
 instance A.ToJSON ScimUserExtra where
   toJSON (ScimUserExtra rif) = A.toJSON rif
 
+instance QC.Arbitrary ScimUserExtra where
+  arbitrary = ScimUserExtra <$> QC.arbitrary
+
+instance QC.Arbitrary (RI.WithNormalizedRichFields ScimUserExtra) where
+  arbitrary = do
+    RI.WithNormalizedRichFields ri <- QC.arbitrary
+    pure . RI.WithNormalizedRichFields . ScimUserExtra $ ri
+
+instance QC.Arbitrary (RI.WithNormalizedRichFields (Scim.User SparTag)) where
+  arbitrary =
+    RI.WithNormalizedRichFields <$> (addFields =<< (Scim.empty <$> genSchemas <*> genUserName <*> genExtra))
+    where
+      addFields :: Scim.User.User tag -> QC.Gen (Scim.User.User tag)
+      addFields usr = do
+        gexternalId <- cs . QC.getPrintableString <$$> QC.arbitrary
+        gdisplayName <- cs . QC.getPrintableString <$$> QC.arbitrary
+        gactive <- Scim.ScimBool <$$> QC.arbitrary
+        gemails <- catMaybes <$> (A.decode <$$> QC.listOf (QC.elements ["[email protected]", "x@y,z", "[email protected]"]))
+        pure
+          usr
+            { Scim.User.externalId = gexternalId,
+              Scim.User.displayName = gdisplayName,
+              Scim.User.active = gactive,
+              Scim.User.emails = gemails
+            }
+
+      genSchemas :: QC.Gen [Scim.Schema]
+      genSchemas = QC.listOf1 $ QC.elements Scim.fakeEnumSchema
+
+      genUserName :: QC.Gen Text
+      genUserName = cs . QC.getPrintableString <$> QC.arbitrary
+
+      genExtra :: QC.Gen ScimUserExtra
+      genExtra = RI.fromWithNormalizedRichFields <$> QC.arbitrary
+
 instance Scim.Patchable ScimUserExtra where
   applyOperation (ScimUserExtra (RI.RichInfo rinfRaw)) (Operation o (Just (NormalPath (AttrPath (Just (CustomSchema sch)) (AttrName (CI.mk -> ciAttrName)) Nothing))) val)
     | sch == RI.richInfoMapURN =

services/spar/src/Spar/Scim/Types.hs

@@ -41,7 +41,14 @@
 module Spar.Scim.Types where
 
 import Brig.Types.Intra (AccountStatus (..))
+import Control.Lens (view)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
 import Imports
+import qualified Web.Scim.Schema.Common as Scim
+import qualified Web.Scim.Schema.User as Scim.User
+import Wire.API.User.RichInfo (RichInfo (..), normalizeRichInfoAssocList)
+import Wire.API.User.Scim (ScimUserExtra (..), SparTag, sueRichInfo)
 
 -- TODO: move these somewhere else?
 scimActiveFlagFromAccountStatus :: AccountStatus -> Bool
@@ -78,3 +85,25 @@ scimActiveFlagToAccountStatus oldstatus = \case
       Deleted -> Deleted -- this shouldn't happen, but it's harmless if it does.
       Ephemeral -> Ephemeral
       PendingInvitation -> PendingInvitation -- (do not activate: see 'scimActiveFlagFromAccountStatus')
+
+normalizeLikeStored :: Scim.User.User SparTag -> Scim.User.User SparTag
+normalizeLikeStored usr =
+  lowerSerialized
+    usr
+      { Scim.User.extra = tweakExtra $ Scim.User.extra usr,
+        Scim.User.active = tweakActive $ Scim.User.active usr,
+        Scim.User.phoneNumbers = []
+      }
+  where
+    lowerSerialized :: Scim.User.User SparTag -> Scim.User.User SparTag
+    lowerSerialized =
+      either (error . show {- impossible; evidence: roundtrip tests -}) id
+        . Aeson.parseEither Aeson.parseJSON
+        . Scim.jsonLower
+        . Aeson.toJSON
+
+    tweakExtra :: ScimUserExtra -> ScimUserExtra
+    tweakExtra = ScimUserExtra . RichInfo . normalizeRichInfoAssocList . unRichInfo . view sueRichInfo
+
+    tweakActive :: Maybe Scim.ScimBool -> Maybe Scim.ScimBool
+    tweakActive = fmap Scim.ScimBool . maybe (Just True) Just . fmap Scim.unScimBool

services/spar/src/Spar/Scim/User.hs

@@ -69,6 +69,7 @@ import Spar.App (GetUserResult (..), Spar, getUserIdByScimExternalId, getUserIdB
 import qualified Spar.Data as Data
 import qualified Spar.Intra.Brig as Brig
 import Spar.Scim.Auth ()
+import Spar.Scim.Types (normalizeLikeStored)
 import qualified Spar.Scim.Types as ST
 import Spar.Sem.SAMLUser (SAMLUser)
 import qualified System.Logger.Class as Log
@@ -767,7 +768,7 @@ synthesizeStoredUser' uid veid dname handle richInfo accStatus createdAt lastUpd
               ST._vsuActive = ST.scimActiveFlagFromAccountStatus accStatus
             }
 
-  pure $ toScimStoredUser' createdAt lastUpdatedAt baseuri uid scimUser
+  pure $ toScimStoredUser' createdAt lastUpdatedAt baseuri uid (normalizeLikeStored scimUser)
 
 synthesizeScimUser :: ST.ValidScimUser -> Scim.User ST.SparTag
 synthesizeScimUser info =

services/spar/test/Test/Spar/ScimSpec.hs

@@ -30,7 +30,7 @@
 
 module Test.Spar.ScimSpec where
 
-import Brig.Types.Test.Arbitrary
+import Control.Lens (view)
 import Data.Aeson (eitherDecode', encode, parseJSON)
 import Data.Aeson.QQ (aesonQQ)
 import qualified Data.Aeson.Types as Aeson
@@ -41,6 +41,7 @@ import Imports
 import Network.URI (parseURI)
 import qualified SAML2.WebSSO as SAML
 import Spar.Scim
+import Spar.Scim.Types (normalizeLikeStored)
 import Test.Hspec
 import Test.QuickCheck
 import URI.ByteString
@@ -123,6 +124,7 @@ spec = describe "toScimStoredUser'" $ do
   it "roundtrips" . property $ do
     \(sue :: ScimUserExtra) ->
       eitherDecode' (encode sue) `shouldBe` Right sue
+
   describe "ScimUserExtra" $ do
     describe "Patchable" $ do
       it "can add to rich info map" $ do
@@ -254,5 +256,8 @@ spec = describe "toScimStoredUser'" $ do
         applyOperation (ScimUserExtra (RichInfo (RichInfoAssocList origAssocList))) operation
           `shouldBe` (Right (ScimUserExtra (RichInfo (RichInfoAssocList expectedAssocList))))
 
-instance Arbitrary ScimUserExtra where
-  arbitrary = ScimUserExtra <$> arbitrary
+  describe "normalizeLikeStored" $ do
+    focus . it "keeps user record intact" . property $
+      \(WithNormalizedRichFields (usr :: (Scim.User SparTag))) -> counterexample (show usr) $ do
+        let f = length . unRichInfoAssocList . unRichInfo . view sueRichInfo . Scim.extra
+        f (normalizeLikeStored usr) `shouldBe` f usr