Broken tests [WIP]

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

@@ -33,6 +33,7 @@ module Wire.API.User.RichInfo
     -- * RichInfoAssocList
     RichInfoAssocList (..),
     normalizeRichInfoAssocList,
+    richInfoAssocListFromObject,
     richInfoAssocListURN,
 
     -- * RichField

services/spar/test-integration/Test/Spar/Scim/UserSpec.hs

@@ -64,6 +64,7 @@ import Spar.Data (lookupScimExternalId)
 import qualified Spar.Data as Data
 import qualified Spar.Intra.Brig as Intra
 import Spar.Scim
+import Spar.Scim.Types (normalizeLikeStored)
 import qualified Spar.Scim.User as SU
 import qualified Text.XML.DSig as SAML
 import qualified URI.ByteString as URI
@@ -776,6 +777,7 @@ specListUsers :: SpecWith TestEnv
 specListUsers = describe "GET /Users" $ do
   it "lists all SCIM users in a team" $ testListProvisionedUsers
   context "1 SAML IdP" $ do
+    focus . it "BLA" $ testBla
     it "finds a SCIM-provisioned user by userName or externalId" $ testFindProvisionedUser
     it "finds a user autoprovisioned via saml by externalId via email" $ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO
     it "finds a user invited via team settings by externalId via email" $ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO
@@ -790,6 +792,24 @@ specListUsers = describe "GET /Users" $ do
   it "doesn't list users from other teams" $ testUserListFailsWithNotFoundIfOutsideTeam
   it "doesn't find users from other teams" $ testUserFindFailsWithNotFoundIfOutsideTeam
 
+testBla :: TestSpar ()
+testBla = do
+  let job i = do
+        print i
+        user <- randomScimUser
+        (tok, (_, _, _)) <- registerIdPAndScimToken
+        storedUser <- createUser tok user
+        [storedUser'] <- listUsers tok (Just (filterBy "userName" (Scim.User.userName user)))
+        -- the following two lines break after a while, and have been doing so on develop
+        -- since at least 1a30f5ff9a2d767fa75b35cb20c89091eea50a4b.
+        liftIO $ storedUser' `shouldBe` storedUser
+        liftIO $ Scim.value (Scim.thing storedUser') `shouldBe` normalizeLikeStored user {Scim.User.emails = [] {- only after validation -}}
+        let Just externalId = Scim.User.externalId user
+        users' <- listUsers tok (Just (filterBy "externalId" externalId))
+        liftIO $ users' `shouldBe` [storedUser]
+        job (i + 1)
+  job (1 :: Int)
+
 -- | Test that SCIM-provisioned team members are listed, and users that were not provisioned
 -- via SCIM are not listed.
 testListProvisionedUsers :: TestSpar ()
@@ -805,8 +825,9 @@ testFindProvisionedUser = do
   user <- randomScimUser
   (tok, (_, _, _)) <- registerIdPAndScimToken
   storedUser <- createUser tok user
-  users <- listUsers tok (Just (filterBy "userName" (Scim.User.userName user)))
-  liftIO $ users `shouldBe` [storedUser]
+  [storedUser'] <- listUsers tok (Just (filterBy "userName" (Scim.User.userName user)))
+  liftIO $ storedUser' `shouldBe` storedUser
+  liftIO $ Scim.value (Scim.thing storedUser') `shouldBe` normalizeLikeStored user {Scim.User.emails = [] {- only after validation -}}
   let Just externalId = Scim.User.externalId user
   users' <- listUsers tok (Just (filterBy "externalId" externalId))
   liftIO $ users' `shouldBe` [storedUser]

services/spar/test-integration/Util/Scim.hs

@@ -37,6 +37,7 @@ import qualified SAML2.WebSSO as SAML
 import SAML2.WebSSO.Types (IdPId, idpId)
 import Spar.Data as Data
 import qualified Spar.Intra.Brig as Intra
+import Spar.Scim.Types (normalizeLikeStored)
 import Spar.Scim.User (synthesizeScimUser, validateScimUser')
 import Test.QuickCheck (arbitrary, generate)
 import qualified Text.Email.Parser as Email
@@ -100,7 +101,7 @@ registerScimToken teamid midpid = do
 -- FUTUREWORK: make this more exhaustive.  change everything that can be changed!  move this to the
 -- hspec package when done.
 randomScimUser :: (HasCallStack, MonadRandom m, MonadIO m) => m (Scim.User.User SparTag)
-randomScimUser = fst <$> randomScimUserWithSubject
+randomScimUser = normalizeLikeStored . fst <$> randomScimUserWithSubject
 
 -- | Like 'randomScimUser', but also returns the intended subject ID that the user should
 -- have. It's already available as 'Scim.User.externalId' but it's not structured.

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

@@ -9,7 +9,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}
 
 -- This file is part of the Wire Server implementation.
 --
@@ -30,18 +30,25 @@
 
 module Test.Spar.ScimSpec where
 
-import Control.Lens (view)
-import Data.Aeson (eitherDecode', encode, parseJSON)
+import Control.Exception (assert)
+import Control.Lens (preview, view)
+import Data.Aeson
+import qualified Data.Aeson.Lens as AL
 import Data.Aeson.QQ (aesonQQ)
 import qualified Data.Aeson.Types as Aeson
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as HM
 import Data.Id
 import Data.Json.Util (fromUTCTimeMillis, toUTCTimeMillis)
+import Data.String.Conversions (cs)
+import qualified Data.Text
 import qualified Data.UUID as UUID
 import Imports
 import Network.URI (parseURI)
 import qualified SAML2.WebSSO as SAML
 import Spar.Scim
 import Spar.Scim.Types (normalizeLikeStored)
+import System.IO.Unsafe (unsafePerformIO)
 import Test.Hspec
 import Test.QuickCheck
 import URI.ByteString
@@ -51,9 +58,8 @@ import qualified Web.Scim.Schema.Common as Scim
 import qualified Web.Scim.Schema.Meta as Scim
 import Web.Scim.Schema.PatchOp (Op (Remove), Operation (..), PatchOp (..), Path (NormalPath), applyOperation)
 import qualified Web.Scim.Schema.ResourceType as ScimR
-import Web.Scim.Schema.Schema (Schema (CustomSchema))
-import qualified Web.Scim.Schema.Schema as Scim
-import qualified Web.Scim.Schema.User as Scim
+import Web.Scim.Schema.Schema as Scim
+import Web.Scim.Schema.User as Scim
 import qualified Web.Scim.Schema.User.Name as ScimN
 import Wire.API.User.RichInfo
 
@@ -261,3 +267,77 @@ spec = describe "toScimStoredUser'" $ do
       \(WithNormalizedRichFields (usr :: (Scim.User SparTag))) -> counterexample (show usr) $ do
         let f = length . unRichInfoAssocList . unRichInfo . view sueRichInfo . Scim.extra
         f (normalizeLikeStored usr) `shouldBe` f usr
+
+test1 :: Spec
+test1 = do
+  it "works" $ do
+    let x = RichInfoAssocList {unRichInfoAssocList = [RichField {richFieldType = "0-plIe\176041Sdu]\129492ouXy*]j\49123`jDNJ:N%\32939\&6\183443\\>HSi\6502q,\28951wZ].\11331w`", richFieldValue = "C ny6Nx0f&b\121034\29092r"}, RichField {richFieldType = "[&c;VP9\42304Q.I\43963OS\83057}G ]\175364xYLqO\156677q*ZBtZ`vKc", richFieldValue = "+FEv\28180"}, RichField {richFieldType = "}121@^z{", richFieldValue = "{KZQqjqs Py%ETB>;y1}\142167\181794\164475p"}, RichField {richFieldType = "\48098\&2#-p\68080\&9\37971|\190007K|m(", richFieldValue = ":j7\83424lQ\19571\188281*[)D8\50056\9019n\189416\100233]*!={FX|/!!&my]+8\175071\135759\&0\13316K'(\14120\172092w,2"}, RichField {richFieldType = "\50520MX>\\kQcBz\169538\147873\\\177286FqS!GW]#\20027_n", richFieldValue = "53\190108.?%t[ &9=hd9t:}Q@yj#w~B\164946B# fs!\39091}eEP"}, RichField {richFieldType = "sE7hmj\164437:", richFieldValue = "ns\"EJftf6~g5U\"&tt\20456@]M"}, RichField {richFieldType = "\172698p\41097sHk \37897X0Io\8286OU\173780\18370h\46873&GAOpuQU+T)]rC\5068WCA\68875(-\175596'", richFieldValue = "lRiP"}]}
+
+        y = normalizeRichInfoAssocList x
+        f = length . unRichInfoAssocList
+    f x `shouldBe` f y
+
+    let q :: [Text]
+        q = CI.original . richFieldType <$> unRichInfoAssocList x
+
+    (length . sort . nub $ Data.Text.toLower <$> q) `shouldBe` (length . sort . nub $ q)
+
+  it "works" $ do
+    let usr :: User SparTag
+        usr = User {schemas = [PatchOp20, CustomSchema "asdf", ResourceType20, CustomSchema "", CustomSchema "", Group20, ServiceProviderConfig20], userName = ">/nP6S3|)RBmeJ/'PqYzRr\96446F\42072HS_izq", externalId = Just "nZ\179219)DZ\13375\\v", name = Nothing, displayName = Just "`b++0RD Ty~ z/S`Z\\\"bDE-\13666\&32>%<\189311", nickName = Nothing, profileUrl = Nothing, title = Nothing, userType = Nothing, preferredLanguage = Nothing, locale = Nothing, active = Nothing, password = Nothing, emails = [], phoneNumbers = [], ims = [], photos = [], addresses = [], entitlements = [], roles = [], x509Certificates = [], extra = ScimUserExtra {_sueRichInfo = RichInfo {unRichInfo = RichInfoAssocList {unRichInfoAssocList = [RichField {richFieldType = "0-plIe\176041Sdu]\129492ouXy*]j\49123`jDNJ:N%\32939\&6\183443\\>HSi\6502q,\28951wZ].\11331w`", richFieldValue = "C ny6Nx0f&b\121034\29092r"}, RichField {richFieldType = "[&c;VP9\42304Q.I\43963OS\83057}G ]\175364xYLqO\156677q*ZBtZ`vKc", richFieldValue = "+FEv\28180"}, RichField {richFieldType = "}121@^z{", richFieldValue = "{KZQqjqs Py%ETB>;y1}\142167\181794\164475p"}, RichField {richFieldType = "\48098\&2#-p\68080\&9\37971|\190007K|m(", richFieldValue = ":j7\83424lQ\19571\188281*[)D8\50056\9019n\189416\100233]*!={FX|/!!&my]+8\175071\135759\&0\13316K'(\14120\172092w,2"}, RichField {richFieldType = "\50520MX>\\kQcBz\169538\147873\\\177286FqS!GW]#\20027_n", richFieldValue = "53\190108.?%t[ &9=hd9t:}Q@yj#w~B\164946B# fs!\39091}eEP"}, RichField {richFieldType = "sE7hmj\164437:", richFieldValue = "ns\"EJftf6~g5U\"&tt\20456@]M"}, RichField {richFieldType = "\172698p\41097sHk \37897X0Io\8286OU\173780\18370h\46873&GAOpuQU+T)]rC\5068WCA\68875(-\175596'", richFieldValue = "lRiP"}]}}}}
+
+    -- writeFile "/tmp/x" $ cs $ encode usr
+
+    let f = length . unRichInfoAssocList . unRichInfo . view sueRichInfo . Scim.extra
+    f (normalizeLikeStored' True usr) `shouldBe` f usr
+    f (normalizeLikeStored' False {- TODO this should also pass! -} usr) `shouldBe` f usr
+
+  it "works" $ do
+    pendingWith
+      ( "next steps: print usr above in line 287; test whether things break in 'richInfoAssocListFromObject'"
+      -- ...  but i really can't see how?  my money right now is on a unicode bug
+      )
+
+-- | cloned from 'normalizeLikeStored'
+normalizeLikeStored' :: Bool -> User SparTag -> User SparTag
+normalizeLikeStored' working usr =
+  lowerSerialized
+    usr
+      { extra = tweakExtra $ extra usr
+      }
+  where
+    lowerSerialized :: User SparTag -> User SparTag
+    lowerSerialized =
+      either (error . show {- impossible; evidence: roundtrip tests -}) id
+        . Aeson.parseEither Aeson.parseJSON
+        . jsonLower' working
+        . Aeson.toJSON
+
+    tweakExtra :: ScimUserExtra -> ScimUserExtra
+    tweakExtra = ScimUserExtra . RichInfo . normalizeRichInfoAssocList . unRichInfo . view sueRichInfo
+
+-- | cloned from 'jsonLower'
+jsonLower' :: Bool -> Value -> Value
+jsonLower' working (Object o) = checkgood $ Object o'
+  where
+    o' :: HM.HashMap Text Value
+    o' = HM.fromList . lowerPairs . HM.toList $ o
+
+    lowerPair (key, val) = ((if working then id else Data.Text.toLower) key, jsonLower' working val)
+
+    checkgood a =
+      if length (HM.keys o) /= length (HM.keys o')
+        then error $ show (o, o')
+        else a
+
+    lowerPairs xs =
+      assert good $
+        assert better $
+          xs'
+      where
+        xs' = lowerPair <$> xs
+        good = f xs == f xs'
+        better = (length . HM.keys . HM.fromList $ xs') == f xs'
+        f = length . nub . sort . fmap fst
+jsonLower' working (Array x) = Array (jsonLower' working <$> x)
+jsonLower' _ x = x