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

* More entropy in integration tests.

* Remove bogus name.

* Normalize scim data before responding to `POST /scim/v2/Users`.

* Unit tests.

* Smart constructors for RichInfoMapAndList, RichInfoAssocList.

also:
- no more Arbitrary instances for un-normalized types.
- more coherent normalization.
- fixes a couple of failing test cases.

* The FIX!!

* Not The REAL FIX!!! either

* The third fix at least makes one test pass...

* Don't brutally and point-lessly lower-case case-insensitive json.

I don't remember why I did this, but I think the reason has
evaporated.  Now it seems quite silly.

* Haddocks.

changelog.d/5-internal/various-fixes-3

@@ -0,0 +1 @@
+Handle upper/lower case more consistently in scim and rich-info data.

libs/hscim/src/Web/Scim/AttrName.hs

@@ -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)
 
@@ -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

libs/hscim/src/Web/Scim/Schema/Common.hs

@@ -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
@@ -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)
 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

libs/hscim/src/Web/Scim/Schema/PatchOp.hs

@@ -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)
@@ -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"
@@ -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")
@@ -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
@@ -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"

libs/hscim/src/Web/Scim/Schema/Schema.hs

@@ -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]
+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)
 

libs/hscim/src/Web/Scim/Schema/User.hs

@@ -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
@@ -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]

libs/hscim/src/Web/Scim/Server/Mock.hs

@@ -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)
@@ -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"

libs/hscim/test/Test/Schema/UserSpec.hs

@@ -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
@@ -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 []

libs/hscim/test/Test/Schema/Util.hs

@@ -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
@@ -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

libs/wire-api/package.yaml

@@ -13,6 +13,8 @@ dependencies:
 - containers >=0.5
 - imports
 - types-common >=0.16
+- case-insensitive
+- hscim
 library:
   source-dirs: src
   dependencies:
@@ -22,7 +24,6 @@ library:
   - binary
   - bytestring >=0.9
   - bytestring-conversion >=0.2
-  - case-insensitive
   - cassandra-util
   - cassava >= 0.5
   - cereal
@@ -40,7 +41,6 @@ library:
   - ghc-prim
   - hashable
   - hostname-validate
-  - hscim
   - http-api-data
   - http-media
   - http-types