Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Scim users get distorted between construct, post, get. #1754

Merged
merged 20 commits into from
Sep 27, 2021
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions changelog.d/5-internal/various-fixes-3
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
Handle upper/lower case more consistently in scim and rich-info data.
9 changes: 5 additions & 4 deletions libs/hscim/src/Web/Scim/AttrName.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,9 +22,10 @@ module Web.Scim.AttrName where

import Data.Aeson.Types (FromJSONKey, ToJSONKey)
import Data.Attoparsec.ByteString.Char8
import qualified Data.CaseInsensitive as CI
import Data.Hashable
import Data.String (IsString, fromString)
import Data.Text (Text, cons, toCaseFold)
import Data.Text (Text, cons)
import Data.Text.Encoding (decodeUtf8)
import Prelude hiding (takeWhile)

Expand All @@ -38,13 +39,13 @@ newtype AttrName
deriving (Show, FromJSONKey, ToJSONKey)

instance Eq AttrName where
AttrName a == AttrName b = toCaseFold a == toCaseFold b
AttrName a == AttrName b = CI.foldCase a == CI.foldCase b

instance Ord AttrName where
compare (AttrName a) (AttrName b) = compare (toCaseFold a) (toCaseFold b)
compare (AttrName a) (AttrName b) = compare (CI.foldCase a) (CI.foldCase b)

instance Hashable AttrName where
hashWithSalt x (AttrName a) = hashWithSalt x (toCaseFold a)
hashWithSalt x (AttrName a) = hashWithSalt x (CI.foldCase a)

instance IsString AttrName where
fromString = AttrName . fromString
Expand Down
16 changes: 11 additions & 5 deletions libs/hscim/src/Web/Scim/Schema/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,11 +22,10 @@ module Web.Scim.Schema.Common where

import Data.Aeson
import qualified Data.CaseInsensitive as CI
import qualified Data.Char as Char
import qualified Data.HashMap.Lazy as HML
import qualified Data.HashMap.Strict as HM
import Data.String.Conversions (cs)
import Data.Text hiding (dropWhile)
import Data.Text (pack, unpack)
import qualified Network.URI as Network

data WithId id a = WithId
Expand Down Expand Up @@ -83,17 +82,24 @@ serializeOptions =
parseOptions :: Options
parseOptions =
defaultOptions
{ fieldLabelModifier = toKeyword . fmap Char.toLower
{ fieldLabelModifier = toKeyword . CI.foldCase
}

-- | 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.
--
-- NB: be careful to not mix 'Data.Text.{toLower,toCaseFold', 'Data.Char.toLower', and
-- 'Data.CaseInsensitive.foldCase'. They're not all the same thing!
-- https://github.com/basvandijk/case-insensitive/issues/31
--
-- (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)
lowerPair (key, val) = (CI.foldCase key, jsonLower val)
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's probably not ideal to use case-folded strings as JSON keys (Unicode recommends to use case-folding only for comparison). Why is this JSON normalisation still needed? I would guess that once all the case comparisons on the haskell side are done correctly, JSON could be generated just using the "original" strings. Am I thinking about this wrong?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The original idea of jsonLower was to run it in json parsers initially, so that the actual parser could rely on everything being lower-case. This was an easy way of working around the fact that json and therefore aeson is strictly case-sensitive.

So morally, this is just lower-casing Values that are about to be deconstructed. But I will double-check and add this to the haddocks.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I double-checked, and I was right:

git grep -Hn jsonLower
libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs:84:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs:95:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs:114:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Class/Group.hs:63:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Class/Group.hs:76:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs:70:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/Common.hs:97:jsonLower :: Value -> Value
libs/hscim/src/Web/Scim/Schema/Common.hs:98:jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o
libs/hscim/src/Web/Scim/Schema/Common.hs:100:    lowerPair (key, val) = (CI.foldCase key, jsonLower val)
libs/hscim/src/Web/Scim/Schema/Common.hs:101:jsonLower (Array x) = Array (jsonLower <$> x)
libs/hscim/src/Web/Scim/Schema/Common.hs:102:jsonLower same@(String _) = same -- (only object attributes, not all texts in the value side of objects!)
libs/hscim/src/Web/Scim/Schema/Common.hs:103:jsonLower same@(Number _) = same
libs/hscim/src/Web/Scim/Schema/Common.hs:104:jsonLower same@(Bool _) = same
libs/hscim/src/Web/Scim/Schema/Common.hs:105:jsonLower same@Null = same
libs/hscim/src/Web/Scim/Schema/ListResponse.hs:62:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/Meta.hs:70:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/ResourceType.hs:59:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Address.hs:39:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Certificate.hs:32:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Email.hs:47:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/IM.hs:32:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Name.hs:39:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Phone.hs:32:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/hscim/src/Web/Scim/Schema/User/Photo.hs:32:  parseJSON = genericParseJSON parseOptions . jsonLower
libs/wire-api/test/unit/Test/Wire/API/User/RichInfo.hs:171:    jsonroundtrip = unsafeParse . Scim.jsonLower . Aeson.toJSON

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

... aaand the haddocks already pretty much say this much. @pcapriotti if you can think of anything to add, please let me know (i can also do it in a separate PR).

jsonLower (Array x) = Array (jsonLower <$> x)
jsonLower x = x
jsonLower same@(String _) = same -- (only object attributes, not all texts in the value side of objects!)
jsonLower same@(Number _) = same
jsonLower same@(Bool _) = same
jsonLower same@Null = same
16 changes: 8 additions & 8 deletions libs/hscim/src/Web/Scim/Schema/PatchOp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,9 +23,9 @@ import Data.Aeson.Types (FromJSON (parseJSON), ToJSON (toJSON), Value (String),
import qualified Data.Aeson.Types as Aeson
import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly)
import Data.Bifunctor (first)
import qualified Data.HashMap.Strict as HM
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, toCaseFold, toLower)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Web.Scim.AttrName (AttrName (..))
import Web.Scim.Filter (AttrPath (..), SubAttr (..), ValuePath (..), pAttrPath, pSubAttr, pValuePath, rAttrPath, rSubAttr, rValuePath)
Expand Down Expand Up @@ -85,7 +85,7 @@ rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> maybe "" rSubA
-- can't control what errors FromJSON throws :/
instance UserTypes tag => FromJSON (PatchOp tag) where
parseJSON = withObject "PatchOp" $ \v -> do
let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v
let o = HashMap.fromList . map (first CI.foldCase) . HashMap.toList $ v
schemas' :: [Schema] <- o .: "schemas"
guard $ PatchOp20 `elem` schemas'
operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON (supportedSchemas @tag)) o "operations"
Expand All @@ -100,7 +100,7 @@ instance ToJSON (PatchOp tag) where
operationFromJSON :: [Schema] -> Value -> Aeson.Parser Operation
operationFromJSON schemas' =
withObject "Operation" $ \v -> do
let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v
let o = HashMap.fromList . map (first CI.foldCase) . HashMap.toList $ v
Operation
<$> (o .: "op")
<*> (Aeson.explicitParseFieldMaybe (pathFromJSON schemas') o "path")
Expand All @@ -120,7 +120,7 @@ instance ToJSON Operation where

instance FromJSON Op where
parseJSON = withText "Op" $ \op' ->
case toCaseFold op' of
case CI.foldCase op' of
"add" -> pure Add
"replace" -> pure Replace
"remove" -> pure Remove
Expand All @@ -139,9 +139,9 @@ instance ToJSON Path where
class Patchable a where
applyOperation :: (MonadError ScimError m) => a -> Operation -> m a

instance Patchable (HM.HashMap Text Text) where
instance Patchable (HashMap.HashMap Text Text) where
applyOperation theMap (Operation Remove (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) _) =
pure $ HM.delete attrName theMap
pure $ HashMap.delete attrName theMap
applyOperation theMap (Operation _AddOrReplace (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) (Just (String val))) =
pure $ HM.insert attrName val theMap
pure $ HashMap.insert attrName val theMap
applyOperation _ _ = throwError $ badRequest InvalidValue $ Just "Unsupported operation"
20 changes: 20 additions & 0 deletions libs/hscim/src/Web/Scim/Schema/Schema.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,26 @@ data Schema
| CustomSchema Text
deriving (Show, Eq)

-- | 'Schema' is *almost* a straight-forward enum type, except for 'CustomSchema'.
-- Enumerations are nice because they let you write quickcheck generators as @elements
-- [minBound..]@. 'fakeEnumSchema' is a work-around.
fakeEnumSchema :: [Schema]
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Maybe adding a comment that this is just for testing is a good idea.

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)

Expand Down
5 changes: 3 additions & 2 deletions libs/hscim/src/Web/Scim/Schema/User.hs
Original file line number Diff line number Diff line change
Expand Up @@ -74,9 +74,10 @@ where

import Control.Monad.Except
import Data.Aeson
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import Data.List ((\\))
import Data.Text (Text, pack, toLower)
import Data.Text (Text, pack)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import Lens.Micro
Expand Down Expand Up @@ -180,7 +181,7 @@ empty schemas userName extra =
instance FromJSON (UserExtra tag) => FromJSON (User tag) where
parseJSON = withObject "User" $ \obj -> do
-- Lowercase all fields
let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj
let o = HM.fromList . map (over _1 CI.foldCase) . HM.toList $ obj
schemas <-
o .:? "schemas" <&> \case
Nothing -> [User20]
Expand Down
5 changes: 3 additions & 2 deletions libs/hscim/src/Web/Scim/Server/Mock.hs
Original file line number Diff line number Diff line change
Expand Up @@ -27,8 +27,9 @@ import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.STM (STM, atomically)
import Data.Aeson
import qualified Data.CaseInsensitive as CI
import Data.Hashable
import Data.Text (Text, pack, toCaseFold)
import Data.Text (Text, pack)
import Data.Time.Calendar
import Data.Time.Clock
import GHC.Exts (sortWith)
Expand Down Expand Up @@ -244,7 +245,7 @@ filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user
case (subAttr, val) of
(Nothing, (ValString str))
| attrib == "userName" ->
Right (compareStr op (toCaseFold (userName user)) (toCaseFold str))
Right (compareStr op (CI.foldCase (userName user)) (CI.foldCase str))
(Nothing, _)
| attrib == "userName" ->
Left "usernames can only be compared with strings"
Expand Down
5 changes: 3 additions & 2 deletions libs/hscim/test/Test/Schema/UserSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,10 +25,11 @@ module Test.Schema.UserSpec
where

import Data.Aeson
import qualified Data.CaseInsensitive as CI
import Data.Either (isLeft, isRight)
import Data.Foldable (for_)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text, toLower)
import Data.Text (Text)
import HaskellWorks.Hspec.Hedgehog (require)
import Hedgehog
import qualified Hedgehog.Gen as Gen
Expand Down Expand Up @@ -443,7 +444,7 @@ instance FromJSON UserExtraTest where
Nothing -> pure UserExtraEmpty
Just (lowercase -> o2) -> UserExtraObject <$> o2 .: "test"
where
lowercase = HM.fromList . map (over _1 toLower) . HM.toList
lowercase = HM.fromList . map (over _1 CI.foldCase) . HM.toList

instance ToJSON UserExtraTest where
toJSON UserExtraEmpty = object []
Expand Down
3 changes: 2 additions & 1 deletion libs/hscim/test/Test/Schema/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@ where

import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.Text (Text, toLower, toUpper)
import Data.Text (Text, toCaseFold, toLower, toUpper)
import Hedgehog
import Hedgehog.Gen as Gen
import Network.URI.Static
Expand All @@ -43,6 +43,7 @@ mk_prop_caseInsensitive gen = property $ do
val <- forAll gen
fromJSON (withCasing toUpper $ toJSON val) === Success val
fromJSON (withCasing toLower $ toJSON val) === Success val
fromJSON (withCasing toCaseFold $ toJSON val) === Success val
where
withCasing :: (Text -> Text) -> Value -> Value
withCasing toCasing = \case
Expand Down
4 changes: 2 additions & 2 deletions libs/wire-api/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,8 @@ dependencies:
- containers >=0.5
- imports
- types-common >=0.16
- case-insensitive
- hscim
library:
source-dirs: src
dependencies:
Expand All @@ -22,7 +24,6 @@ library:
- binary
- bytestring >=0.9
- bytestring-conversion >=0.2
- case-insensitive
- cassandra-util
- cassava >= 0.5
- cereal
Expand All @@ -40,7 +41,6 @@ library:
- ghc-prim
- hashable
- hostname-validate
- hscim
- http-api-data
- http-media
- http-types
Expand Down
Loading