hscim 0.3.5 → 0.3.6

raw patch · 14 files changed

+295/−54 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +3/−0
• hscim.cabal +7/−3
• src/Web/Scim/Capabilities/MetaSchema.hs +3/−3
• src/Web/Scim/Client.hs +3/−3
• src/Web/Scim/Schema/AuthenticationScheme.hs +2/−3
• src/Web/Scim/Schema/Common.hs +14/−15
• src/Web/Scim/Schema/ResourceType.hs +1/−1
• test/Test/Schema/AuthenticationSchemeSpec.hs +50/−0
• test/Test/Schema/GroupSpec.hs +61/−0
• test/Test/Schema/MetaSchemaSpec.hs +4/−9
• test/Test/Schema/PatchOpSpec.hs +6/−1
• test/Test/Schema/ResourceSpec.hs +65/−0
• test/Test/Schema/UserSpec.hs +22/−16
• test/Test/Schema/Util.hs +54/−0

@@ -1,2 +1,5 @@+0.3.6:+  - fix serialization: json attributes in scim are case-insensitive+ 0.3.4:   - initial version

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b8d0589f22bc168d16fa3a2b2800d9cc3b14b4d94bb911fe973ccf2a2025e5e5+-- hash: 8daa0bcbe43125e8d9749dd38e62f67cb01f62a1bcd57a0391e684860203e60c  name:           hscim-version:        0.3.5+version:        0.3.6 synopsis:       hscim json schema and server implementation description:    The README file will answer all the questions you might have category:       Web@@ -15,7 +15,7 @@ bug-reports:    https://github.com/wireapp/wire-server/issues author:         Wire Swiss GmbH maintainer:     Wire Swiss GmbH <backend@wire.com>-copyright:      (c) 2021 Wire Swiss GmbH+copyright:      (c) 2018 Wire Swiss GmbH license:        AGPL-3 license-file:   LICENSE build-type:     Simple@@ -173,9 +173,13 @@       Test.Class.UserSpec       Test.FilterSpec       Test.MiscSpec+      Test.Schema.AuthenticationSchemeSpec+      Test.Schema.GroupSpec       Test.Schema.MetaSchemaSpec       Test.Schema.PatchOpSpec+      Test.Schema.ResourceSpec       Test.Schema.UserSpec+      Test.Schema.Util       Paths_hscim   hs-source-dirs:       test

@@ -81,7 +81,7 @@   toJSON = genericToJSON serializeOptions  instance FromJSON BulkConfig where-  parseJSON = genericParseJSON serializeOptions+  parseJSON = genericParseJSON parseOptions . jsonLower  data FilterConfig = FilterConfig   { maxResults :: Int@@ -92,7 +92,7 @@   toJSON = genericToJSON serializeOptions  instance FromJSON FilterConfig where-  parseJSON = genericParseJSON serializeOptions+  parseJSON = genericParseJSON parseOptions . jsonLower  data Configuration = Configuration   { documentationUri :: Maybe URI,@@ -111,7 +111,7 @@   toJSON = genericToJSON serializeOptions  instance FromJSON Configuration where-  parseJSON = genericParseJSON serializeOptions+  parseJSON = genericParseJSON parseOptions . jsonLower  empty :: Configuration empty =

@@ -32,7 +32,7 @@     getUser,     postUser,     putUser,-    patchUserr,+    patchUser,     deleteUser,      -- * group@@ -143,14 +143,14 @@   IO (StoredUser tag) putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r -patchUserr ::+patchUser ::   HasScimClient tag =>   ClientEnv ->   Maybe (AuthData tag) ->   UserId tag ->   PatchOp tag ->   IO (StoredUser tag)-patchUserr env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (r :<|> _))) -> r+patchUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (r :<|> _))) -> r  deleteUser ::   forall tag.

@@ -66,9 +66,8 @@   toJSON = genericToJSON serializeOptions  instance FromJSON AuthenticationSchemeEncoding where-  parseJSON = genericParseJSON serializeOptions---- NB: "typ" will be converted to "type" thanks to 'serializeOptions'+  -- NB: "typ" will be converted to "type" thanks to 'serializeOptions'+  parseJSON = genericParseJSON parseOptions . jsonLower  ---------------------------------------------------------------------------- -- Scheme encodings

@@ -25,7 +25,6 @@ import qualified Data.Char as Char import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HM-import Data.String (IsString) import Data.String.Conversions (cs) import Data.Text hiding (dropWhile) import qualified Network.URI as Network@@ -69,7 +68,7 @@       _ -> fail $ "Expected true, false, \"true\", or \"false\" (case insensitive), but got " <> cs str   parseJSON bad = fail $ "Expected true, false, \"true\", or \"false\" (case insensitive), but got " <> show bad -toKeyword :: (IsString p, Eq p) => p -> p+toKeyword :: String -> String toKeyword "typ" = "type" toKeyword "ref" = "$ref" toKeyword other = other@@ -81,20 +80,20 @@       fieldLabelModifier = toKeyword     } --- | Turn all keys in a JSON object to lowercase.-jsonLower :: Value -> Value-jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o-  where-    lowerPair (key, val) = (fromKeyword . toLower $ key, val)-jsonLower x = x--fromKeyword :: (IsString p, Eq p) => p -> p-fromKeyword "type" = "typ"-fromKeyword "$ref" = "ref"-fromKeyword other = other- parseOptions :: Options parseOptions =   defaultOptions-    { fieldLabelModifier = fmap Char.toLower+    { fieldLabelModifier = toKeyword . fmap Char.toLower     }++-- | Turn all keys in a JSON object to lowercase recursively.  This is applied to the aeson+-- 'Value' to be parsed; 'parseOptions' is applied to the keys passed to '(.:)' etc.+--+-- (FUTUREWORK: The "recursively" part is a bit of a waste and could be dropped, but we would+-- have to spend more effort in making sure it is always called manually in nested parsers.)+jsonLower :: Value -> Value+jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o+  where+    lowerPair (key, val) = (toLower key, jsonLower val)+jsonLower (Array x) = Array (jsonLower <$> x)+jsonLower x = x

@@ -32,7 +32,7 @@ data ResourceType   = UserResource   | GroupResource-  deriving (Show, Eq)+  deriving (Show, Eq, Enum, Bounded)  instance ToJSON ResourceType where   toJSON UserResource = "User"

@@ -0,0 +1,50 @@+-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- This program is free software: you can redistribute it and/or modify it under+-- the terms of the GNU Affero General Public License as published by the Free+-- Software Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- This program is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more+-- details.+--+-- You should have received a copy of the GNU Affero General Public License along+-- with this program. If not, see <https://www.gnu.org/licenses/>.++module Test.Schema.AuthenticationSchemeSpec+  ( spec,+  )+where++import Data.Aeson+import HaskellWorks.Hspec.Hedgehog (require)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import Test.Hspec+import Test.Schema.Util (genUri, mk_prop_caseInsensitive)+import qualified Web.Scim.Schema.AuthenticationScheme as AS++prop_roundtrip :: Property+prop_roundtrip = property $ do+  user <- forAll genAuthenticationSchemeEncoding+  tripping user toJSON fromJSON++spec :: Spec+spec = do+  it "roundtrip" $ do+    require prop_roundtrip+  it "case-insensitive" $ do+    require $ mk_prop_caseInsensitive genAuthenticationSchemeEncoding++genAuthenticationSchemeEncoding :: Gen AS.AuthenticationSchemeEncoding+genAuthenticationSchemeEncoding =+  AS.AuthenticationSchemeEncoding+    <$> Gen.element ["typ1", "typ2"]+    <*> Gen.element ["name1", "name2", "name3"]+    <*> Gen.element ["desc ription"]+    <*> Gen.maybe genUri+    <*> Gen.maybe genUri

@@ -0,0 +1,61 @@+-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- This program is free software: you can redistribute it and/or modify it under+-- the terms of the GNU Affero General Public License as published by the Free+-- Software Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- This program is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more+-- details.+--+-- You should have received a copy of the GNU Affero General Public License along+-- with this program. If not, see <https://www.gnu.org/licenses/>.++module Test.Schema.GroupSpec+  ( spec,+  )+where++import Data.Aeson+import Data.Text (Text)+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 (mk_prop_caseInsensitive)+import qualified Web.Scim.Class.Group as GroupClass++prop_roundtrip :: Property+prop_roundtrip = property $ do+  user <- forAll genGroup+  tripping user toJSON fromJSON++spec :: Spec+spec = do+  it "roundtrip" $ do+    require prop_roundtrip+  it "case-insensitive" $ do+    require $ mk_prop_caseInsensitive genGroup+    require $ mk_prop_caseInsensitive genMember++genMember :: Gen GroupClass.Member+genMember =+  GroupClass.Member+    <$> (Gen.text (Range.constant 0 20) Gen.unicode)+    <*> (Gen.text (Range.constant 0 20) Gen.unicode)+    <*> (Gen.text (Range.constant 0 20) Gen.unicode)++genGroup :: Gen GroupClass.Group+genGroup =+  GroupClass.Group+    <$> Gen.list (Range.linear 0 10) genSchema+    <*> (Gen.text (Range.constant 0 20) Gen.unicode)+    <*> Gen.list (Range.linear 0 10) genMember++genSchema :: Gen Text+genSchema = Gen.element ["schema1", "schema2", "schema3"]

@@ -26,16 +26,15 @@ where  import Data.Aeson-import Data.Text (Text) import HaskellWorks.Hspec.Hedgehog (require) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import Network.URI.Static (uri) import Test.Hspec+import Test.Schema.Util (genSimpleText, genUri, mk_prop_caseInsensitive) import Web.Scim.Capabilities.MetaSchema import Web.Scim.Schema.AuthenticationScheme-import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..))+import Web.Scim.Schema.Common (ScimBool (ScimBool)) import Web.Scim.Schema.Schema (Schema (..)) import Prelude hiding (filter) @@ -62,6 +61,8 @@       require (prop_roundtrip genAuthenticationSchemeEncoding)     it "`Configuration` roundtrips" $ do       require (prop_roundtrip genConfiguration)+    it "`Configuration` satisfies the insane json-case-insensitivity rule." $ do+      require $ mk_prop_caseInsensitive genConfiguration  genConfiguration :: Gen Configuration genConfiguration = do@@ -99,9 +100,3 @@ genSupported gen = do   Supported <$> (ScimBool <$> Gen.bool)     <*> gen--genUri :: Gen URI-genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]]--genSimpleText :: Gen Text-genSimpleText = Gen.element ["one", "green", "sharp"]

@@ -36,6 +36,7 @@ import qualified Hedgehog.Range as Range import Test.FilterSpec (genAttrPath, genSubAttr, genValuePath) import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy, xit)+import Test.Schema.Util (mk_prop_caseInsensitive) import Web.Scim.AttrName (AttrName (..)) import Web.Scim.Filter (AttrPath (..), CompValue (ValNull), CompareOp (OpEq), Filter (..), ValuePath (..)) import Web.Scim.Schema.PatchOp@@ -51,6 +52,9 @@ genPatchOp :: forall tag. UserTypes tag => Gen Value -> Gen (PatchOp tag) genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) ((genOperation @tag) genValue) +genSimplePatchOp :: forall tag. UserTypes tag => Gen (PatchOp tag)+genSimplePatchOp = genPatchOp @tag (String <$> Gen.text (Range.constant 0 20) Gen.unicode)+ genOperation :: forall tag. UserTypes tag => Gen Value -> Gen Operation genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe (genPath @tag) <*> Gen.maybe genValue @@ -71,7 +75,7 @@   -- Just some strings for now. However, should be constrained to what the   -- PatchOp is operating on in the future... We need better typed PatchOp for   -- this. TODO(arianvp)-  x <- forAll (genPatchOp @tag (String <$> Gen.text (Range.constant 0 20) Gen.unicode))+  x <- forAll (genSimplePatchOp @tag)   tripping x toJSON fromJSON  type PatchTestTag = TestTag () () () ()@@ -115,6 +119,7 @@     --TODO(arianvp): We don't support arbitrary path names (yet)     it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag     it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag+    it "case-insensitive" $ require $ mk_prop_caseInsensitive (genSimplePatchOp @PatchTestTag)     it "rejects invalid operations" $ do       fromJSON @(PatchOp PatchTestTag)         [scim| {

@@ -0,0 +1,65 @@+-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- This program is free software: you can redistribute it and/or modify it under+-- the terms of the GNU Affero General Public License as published by the Free+-- Software Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- This program is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more+-- details.+--+-- You should have received a copy of the GNU Affero General Public License along+-- with this program. If not, see <https://www.gnu.org/licenses/>.++module Test.Schema.ResourceSpec+  ( spec,+  )+where++import Data.Aeson+import HaskellWorks.Hspec.Hedgehog (require)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import Test.Hspec+import Test.Schema.Util (genUri, mk_prop_caseInsensitive)+import Web.Scim.Schema.ResourceType+import qualified Web.Scim.Schema.Schema as Schema++prop_roundtrip :: Property+prop_roundtrip = property $ do+  user <- forAll genResource+  tripping user toJSON fromJSON++spec :: Spec+spec = do+  it "roundtrip" $ do+    require prop_roundtrip+  it "case-insensitive" $ do+    require $ mk_prop_caseInsensitive genResource++genResource :: Gen Resource+genResource =+  Resource+    <$> Gen.element ["name1", "name2", "name3"]+    <*> genUri+    <*> genSchema++genSchema :: Gen Schema.Schema+genSchema =+  Gen.element+    [ Schema.User20,+      Schema.ServiceProviderConfig20,+      Schema.Group20,+      Schema.Schema20,+      Schema.ResourceType20,+      Schema.ListResponse20,+      Schema.Error20,+      Schema.PatchOp20,+      Schema.CustomSchema "custom1",+      Schema.CustomSchema "custom2",+      Schema.CustomSchema "custom3"+    ]

@@ -28,7 +28,7 @@ import Data.Either (isLeft, isRight) import Data.Foldable (for_) import qualified Data.HashMap.Strict as HM-import Data.Text (Text, toLower, toUpper)+import Data.Text (Text, toLower) import HaskellWorks.Hspec.Hedgehog (require) import Hedgehog import qualified Hedgehog.Gen as Gen@@ -36,9 +36,13 @@ import Lens.Micro import Network.URI.Static (uri) import Test.Hspec+import Test.Schema.Util (genUri, mk_prop_caseInsensitive) import Text.Email.Validate (emailAddress)+import qualified Web.Scim.Class.User as UserClass import Web.Scim.Filter (AttrPath (..))-import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..))+import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..))+import qualified Web.Scim.Schema.ListResponse as ListResponse+import Web.Scim.Schema.Meta (ETag (Strong, Weak), Meta (..), WithMeta (..)) import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..), Path (..)) import qualified Web.Scim.Schema.PatchOp as PatchOp import Web.Scim.Schema.Schema (Schema (..))@@ -58,17 +62,6 @@   user <- forAll genUser   tripping user toJSON fromJSON --- TODO(arianvp): Note that this only tests the top-level fields.--- extrac this to a generic test and also do this for sub-properties-prop_caseInsensitive :: Property-prop_caseInsensitive = property $ do-  user <- forAll genUser-  let (Object user') = toJSON user-  let user'' = HM.foldlWithKey' (\u k v -> HM.insert (toUpper k) v u) user' HM.empty-  let user''' = HM.foldlWithKey' (\u k v -> HM.insert (toLower k) v u) user' HM.empty-  fromJSON (Object user'') === Success user-  fromJSON (Object user''') === Success user- type PatchTag = TestTag Text () () UserExtraPatch  type UserExtraPatch = HM.HashMap Text Text@@ -136,7 +129,8 @@     it "treats 'null' and '[]' as absence of fields" $       eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser     it "allows casing variations in field names" $ do-      require prop_caseInsensitive+      require $ mk_prop_caseInsensitive (genUser)+      require $ mk_prop_caseInsensitive (ListResponse.fromList . (: []) <$> genStoredUser)       eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser     it "doesn't require the 'schemas' field" $       eitherDecode (encode minimalUserJsonNoSchemas) `shouldBe` Right minimalUser@@ -159,8 +153,20 @@     <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)     <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) -genUri :: Gen URI-genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]]+genStoredUser :: Gen (UserClass.StoredUser (TestTag Text () () NoUserExtra))+genStoredUser = do+  m <- genMeta+  i <- Gen.element @_ @Text ["wef", "asdf", "@", "#", "1"]+  u <- genUser+  pure $ WithMeta m (WithId i u)++genMeta :: Gen Meta+genMeta =+  Meta <$> Gen.enumBounded+    <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2019-01-01 09:55:59 UTC"]+    <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2022-01-01 09:55:59 UTC"]+    <*> (Gen.element [Weak, Strong] <*> Gen.text (Range.constant 0 20) Gen.unicode)+    <*> genUri  -- TODO(arianvp) Generate the lists too, but first need better support for SCIM -- lists in the first place

@@ -0,0 +1,54 @@+{-# LANGUAGE QuasiQuotes #-}++-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- This program is free software: you can redistribute it and/or modify it under+-- the terms of the GNU Affero General Public License as published by the Free+-- Software Foundation, either version 3 of the License, or (at your option) any+-- later version.+--+-- This program is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more+-- details.+--+-- You should have received a copy of the GNU Affero General Public License along+-- with this program. If not, see <https://www.gnu.org/licenses/>.++module Test.Schema.Util+  ( mk_prop_caseInsensitive,+    genUri,+    genSimpleText,+  )+where++import Data.Aeson+import qualified Data.HashMap.Strict as HM+import Data.Text (Text, toLower, toUpper)+import Hedgehog+import Hedgehog.Gen as Gen+import Network.URI.Static+import Web.Scim.Schema.Common (URI (..))++genUri :: Gen URI+genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]]++genSimpleText :: Gen Text+genSimpleText = Gen.element ["one", "green", "sharp"]++mk_prop_caseInsensitive :: forall a. (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property+mk_prop_caseInsensitive gen = property $ do+  val <- forAll gen+  fromJSON (withCasing toUpper $ toJSON val) === Success val+  fromJSON (withCasing toLower $ toJSON val) === Success val+  where+    withCasing :: (Text -> Text) -> Value -> Value+    withCasing toCasing = \case+      Object obj -> Object $ HM.foldlWithKey' (\u k v -> HM.insert (toCasing k) (withCasing toCasing v) u) HM.empty obj+      Array arr -> Array $ withCasing toCasing <$> arr+      same@(Number _) -> same+      same@(String _) -> same+      same@(Bool _) -> same+      same@Null -> same