diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,2 +1,5 @@ +0.3.6: + - fix serialization: json attributes in scim are case-insensitive + 0.3.4: - initial version diff --git a/hscim.cabal b/hscim.cabal --- a/hscim.cabal +++ b/hscim.cabal @@ -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 -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 diff --git a/src/Web/Scim/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs --- a/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -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 = diff --git a/src/Web/Scim/Client.hs b/src/Web/Scim/Client.hs --- a/src/Web/Scim/Client.hs +++ b/src/Web/Scim/Client.hs @@ -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. diff --git a/src/Web/Scim/Schema/AuthenticationScheme.hs b/src/Web/Scim/Schema/AuthenticationScheme.hs --- a/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -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 diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -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 diff --git a/src/Web/Scim/Schema/ResourceType.hs b/src/Web/Scim/Schema/ResourceType.hs --- a/src/Web/Scim/Schema/ResourceType.hs +++ b/src/Web/Scim/Schema/ResourceType.hs @@ -32,7 +32,7 @@ data ResourceType = UserResource | GroupResource - deriving (Show, Eq) + deriving (Show, Eq, Enum, Bounded) instance ToJSON ResourceType where toJSON UserResource = "User" diff --git a/test/Test/Schema/AuthenticationSchemeSpec.hs b/test/Test/Schema/AuthenticationSchemeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Schema/AuthenticationSchemeSpec.hs @@ -0,0 +1,50 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +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 diff --git a/test/Test/Schema/GroupSpec.hs b/test/Test/Schema/GroupSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Schema/GroupSpec.hs @@ -0,0 +1,61 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +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"] diff --git a/test/Test/Schema/MetaSchemaSpec.hs b/test/Test/Schema/MetaSchemaSpec.hs --- a/test/Test/Schema/MetaSchemaSpec.hs +++ b/test/Test/Schema/MetaSchemaSpec.hs @@ -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"] diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs --- a/test/Test/Schema/PatchOpSpec.hs +++ b/test/Test/Schema/PatchOpSpec.hs @@ -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| { diff --git a/test/Test/Schema/ResourceSpec.hs b/test/Test/Schema/ResourceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Schema/ResourceSpec.hs @@ -0,0 +1,65 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +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" + ] diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -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 diff --git a/test/Test/Schema/Util.hs b/test/Test/Schema/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Schema/Util.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +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