...

wireapp · Sep 24, 2021 · 9eb2355 · 9eb2355
1 parent e32fb17
commit 9eb2355
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 33 deletions.
diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs
@@ -265,6 +265,7 @@ richInfoAssocListFromObject richinfoObj = do
 
 instance Arbitrary RichInfoAssocList where
   arbitrary = mkRichInfoAssocList <$> arbitrary
+  shrink (RichInfoAssocList things) = RichInfoAssocList <$> QC.shrink things
 
 --------------------------------------------------------------------------------
 -- RichField

diff --git a/libs/wire-api/test/unit/Test/Wire/API/User/RichInfo.hs b/libs/wire-api/test/unit/Test/Wire/API/User/RichInfo.hs
@@ -24,9 +24,11 @@ import Data.Aeson
 import Data.Aeson.QQ
 import Data.Aeson.Types as Aeson
 import Imports
+import Test.QuickCheck
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
+import qualified Web.Scim.Schema.Common as Scim
 import Wire.API.User.RichInfo
 
 tests :: TestTree
@@ -148,3 +150,35 @@ testRichInfo =
           assertEqual "RichInfoMapAndList" (Aeson.Success $ mkRichInfoMapAndList [RichField "foo" "bar"]) $ fromJSON inputJSON
       ]
   ]
+    <> moreRichInfoNormalizationTests
+
+moreRichInfoNormalizationTests :: [TestTree]
+moreRichInfoNormalizationTests =
+  [ testCase "'normalizeRichInfoAssocList'" $ do
+      let f = length . unRichInfoAssocList
+      assertEqual mempty (f (normalizeRichInfoAssocList assocs)) (f assocs)
+      assertEqual mempty (normalizeRichInfoAssocList assocs) assocs,
+    testGroup
+      "'toRichInfoAssocList', 'fromRichInfoAssocList'"
+      [ testCase "works (counter-example of earlier bug)" $ do
+          let x = mkRichInfoMapAndList [RichField "A" "b", RichField "a" "x"]
+              y = (fromRichInfoAssocList . toRichInfoAssocList) x
+          assertEqual mempty (toRichInfoAssocList x) (toRichInfoAssocList y),
+        testCase "works (counter-example of earlier bug)" $ do
+          assertEqual mempty (jsonroundtrip assocs) assocs
+          assertEqual mempty (toRichInfoAssocList . fromRichInfoAssocList $ assocs) assocs
+          assertEqual mempty (toRichInfoAssocList . jsonroundtrip . fromRichInfoAssocList $ assocs) assocs,
+        testProperty "works (property)" $ \(someAssocs :: RichInfoAssocList) ->
+          (jsonroundtrip someAssocs) === someAssocs
+            .&&. (toRichInfoAssocList . fromRichInfoAssocList $ someAssocs) === someAssocs
+            .&&. (toRichInfoAssocList . jsonroundtrip . fromRichInfoAssocList $ someAssocs) === someAssocs
+      ]
+  ]
+  where
+    jsonroundtrip :: forall a. (ToJSON a, FromJSON a) => a -> a
+    jsonroundtrip = unsafeParse . Scim.jsonLower . Aeson.toJSON
+      where
+        unsafeParse = either (error . show) id . Aeson.parseEither Aeson.parseJSON
+
+    assocs :: RichInfoAssocList
+    assocs = mkRichInfoAssocList [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"}]
diff --git a/services/spar/test/Test/Spar/ScimSpec.hs b/services/spar/test/Test/Spar/ScimSpec.hs
@@ -255,22 +255,12 @@ spec = describe "toScimStoredUser'" $ do
           `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList expectedAssocList))))
 
   describe "normalization" $ do
-    -- FUTUREWORK: all of this should probably go to
-    -- `/libs/wire-api/test/unit/Test/Wire/API/User/RichInfo.hs`, but you'd have to translate
-    -- everything to tasty first.
-
     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 = assocs}}}
 
         assocs :: RichInfoAssocList
         assocs = mkRichInfoAssocList [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"}]
 
-    describe "'normalizeRichInfoAssocList'" $ do
-      it "works (counter-example of earlier bug)" $ do
-        let f = length . unRichInfoAssocList
-        f (normalizeRichInfoAssocList assocs) `shouldBe` f assocs
-        normalizeRichInfoAssocList assocs `shouldBe` assocs
-
     describe "'normalizeLikeStored'" $ do
       it "works (counter-example of earlier bug)" $ do
         let f = length . unRichInfoAssocList . unRichInfo . view sueRichInfo . Scim.extra
@@ -280,26 +270,3 @@ spec = describe "toScimStoredUser'" $ do
       it "keeps user record intact (property)" . property $
         \(usr' :: (Scim.User SparTag)) -> counterexample (show usr') $ do
           normalizeLikeStored usr' `shouldBe` usr'
-
-    describe "'toRichInfoAssocList', 'fromRichInfoAssocList'" $ do
-      it "works (counter-example of earlier bug)" $ do
-        let x = mkRichInfoMapAndList [RichField "A" "b", RichField "a" "x"]
-            y = (fromRichInfoAssocList . toRichInfoAssocList) x
-        toRichInfoAssocList x `shouldBe` toRichInfoAssocList y
-
-      let testcase :: RichInfoAssocList -> Expectation
-          testcase someAssocs = do
-            let jsonroundtrip :: forall a. (ToJSON a, FromJSON a) => a -> a
-                jsonroundtrip = unsafeParse . Scim.jsonLower . Aeson.toJSON
-                  where
-                    unsafeParse = either (error . show) id . Aeson.parseEither Aeson.parseJSON
-
-            jsonroundtrip someAssocs `shouldBe` someAssocs
-            (toRichInfoAssocList . fromRichInfoAssocList) someAssocs `shouldBe` someAssocs
-            (toRichInfoAssocList . jsonroundtrip . fromRichInfoAssocList) someAssocs `shouldBe` someAssocs
-
-      it "works (counter-example of earlier bug)" $
-        testcase assocs
-
-      it "works (property)" . property $
-        testcase