hscim 0.4.0.2 → 0.4.0.3

raw patch · 23 files changed

+143/−93 lines, 23 filesdep ~basedep ~hspecdep ~mtl

Dependency ranges changed: base, hspec, mtl, servant, servant-client, servant-client-core, servant-server, template-haskell, warp

Files

• CHANGELOG +7/−0
• hscim.cabal +10/−11
• server/Main.hs +3/−2
• src/Web/Scim/Capabilities/MetaSchema.hs +2/−2
• src/Web/Scim/Class/Group.hs +1/−1
• src/Web/Scim/Client.hs +10/−20
• src/Web/Scim/ContentType.hs +2/−2
• src/Web/Scim/Handler.hs +3/−2
• src/Web/Scim/Schema/Common.hs +1/−1
• src/Web/Scim/Schema/ListResponse.hs +2/−2
• src/Web/Scim/Schema/Meta.hs +2/−0
• src/Web/Scim/Schema/PatchOp.hs +2/−1
• src/Web/Scim/Schema/User.hs +6/−5
• src/Web/Scim/Schema/User/Email.hs +25/−11
• src/Web/Scim/Server.hs +2/−2
• src/Web/Scim/Server/Mock.hs +3/−2
• src/Web/Scim/Test/Acceptance.hs +3/−2
• src/Web/Scim/Test/Util.hs +3/−3
• test/Test/Class/UserSpec.hs +5/−7
• test/Test/FilterSpec.hs +5/−5
• test/Test/Schema/PatchOpSpec.hs +6/−6
• test/Test/Schema/UserSpec.hs +39/−5
• test/Test/Schema/Util.hs +1/−1

@@ -1,3 +1,10 @@+0.4.0.3:+  - drop client function for putUser+  - bump ormulu+  - bump dependencies+  - make delete user idempotent (do not throw 404)+  - clean up email address type+ 0.4.0:   - update dependencies 

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               hscim-version:            0.4.0.2+version:            0.4.0.3 synopsis:           hscim json schema and server implementation description:   The README file will answer all the questions you might have@@ -86,12 +86,12 @@       aeson                >=2.1.2   && <2.2     , aeson-qq             >=0.8.4   && <0.9     , attoparsec           >=0.14.4  && <0.15-    , base                 >=4.17.2  && <4.18+    , base                 >=4.17.2  && <4.19     , bytestring           >=0.10.4  && <0.12     , case-insensitive     >=1.2.1   && <1.3     , email-validate       >=2.3.2   && <2.4     , hashable             >=1.4.3   && <1.5-    , hspec                >=2.10.10 && <2.11+    , hspec                >=2.10.10 && <2.12     , hspec-expectations   >=0.8.2   && <0.9     , hspec-wai            >=0.11.1  && <0.12     , http-api-data        >=0.5     && <0.6@@ -100,24 +100,23 @@     , list-t               >=1.0.5   && <1.1     , microlens            >=0.4.13  && <0.5     , mmorph               >=1.2.0   && <1.3-    , mtl                  >=2.2.2   && <2.3+    , mtl                  >=2.2.2   && <2.4     , network-uri          >=2.6.4   && <2.7     , retry                >=0.9.3   && <0.10     , scientific           >=0.3.7   && <0.4-    , servant              >=0.19.1  && <0.20-    , servant-client       >=0.19    && <0.20-    , servant-client-core  >=0.19    && <0.20-    , servant-server       >=0.19.2  && <0.20+    , servant              >=0.19.1  && <0.21+    , servant-client       >=0.19    && <0.21+    , servant-client-core  >=0.19    && <0.21+    , servant-server       >=0.19.2  && <0.21     , stm                  >=2.5.1   && <2.6     , stm-containers       >=1.2.0   && <1.3     , string-conversions   >=0.4.0   && <0.5-    , template-haskell     >=2.19.0  && <2.20+    , template-haskell     >=2.19.0  && <2.21     , text                 >=2.0.2   && <2.1     , time                 >=1.12.2  && <1.13     , uuid                 >=1.3.15  && <1.4     , wai                  >=3.2.3   && <3.3     , wai-extra            >=3.1.13  && <3.2-    , warp                 >=3.3.30  && <3.4    default-language:   Haskell2010 @@ -155,7 +154,7 @@     , stm     , stm-containers     , time-    , warp+    , warp <= 3.4.2    default-language:   Haskell2010 

@@ -68,12 +68,13 @@             E.value =               maybe                 (error "couldn't parse email")-                EmailAddress2+                EmailAddress                 (emailAddress "elton@wire.com"),             E.primary = Nothing           }+   let user =-        (User.empty [User20] "elton" NoUserExtra)+        (User.empty [User20] "elton" NoUserExtra :: User Mock)           { name =               Just                 Name

@@ -54,7 +54,7 @@   }   deriving (Show, Eq, Generic) -instance ToJSON a => ToJSON (Supported a) where+instance (ToJSON a) => ToJSON (Supported a) where   toJSON (Supported (ScimBool b) v) = case toJSON v of     (Object o) -> Object $ KeyMap.insert "supported" (Bool b) o     _ -> Object $ KeyMap.fromList [("supported", Bool b)]@@ -134,7 +134,7 @@     }  configServer ::-  Monad m =>+  (Monad m) =>   Configuration ->   ConfigSite (AsServerT (ScimHandler m)) configServer config =

@@ -171,7 +171,7 @@  groupServer ::   forall tag m.-  GroupDB tag m =>+  (GroupDB tag m) =>   Maybe (AuthData tag) ->   GroupSite tag (AsServerT (ScimHandler m)) groupServer authData =

@@ -31,7 +31,6 @@     getUsers,     getUser,     postUser,-    putUser,     patchUser,     deleteUser, @@ -74,28 +73,28 @@     ToHttpApiData (GroupId tag)   ) -scimClients :: HasScimClient tag => ClientEnv -> Site tag (AsClientT IO)+scimClients :: (HasScimClient tag) => ClientEnv -> Site tag (AsClientT IO) scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO pure  -- config  spConfig ::   forall tag.-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   IO MetaSchema.Configuration spConfig env = case config @tag (scimClients env) of ((r :<|> _) :<|> (_ :<|> _)) -> r  getSchemas ::   forall tag.-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   IO (ListResponse Value) getSchemas env = case config @tag (scimClients env) of ((_ :<|> r) :<|> (_ :<|> _)) -> r  schema ::   forall tag.-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Text ->   IO Value@@ -103,7 +102,7 @@  resourceTypes ::   forall tag.-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   IO (ListResponse ResourceType.Resource) resourceTypes env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (_ :<|> r)) -> r@@ -111,7 +110,7 @@ -- users  getUsers ::-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Maybe (AuthData tag) ->   Maybe Filter ->@@ -119,7 +118,7 @@ getUsers env tok = case users (scimClients env) tok of ((r :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r  getUser ::-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Maybe (AuthData tag) ->   UserId tag ->@@ -127,24 +126,15 @@ getUser env tok = case users (scimClients env) tok of ((_ :<|> (r :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r  postUser ::-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Maybe (AuthData tag) ->   User tag ->   IO (StoredUser tag) postUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> r)) :<|> (_ :<|> (_ :<|> _))) -> r -putUser ::-  HasScimClient tag =>-  ClientEnv ->-  Maybe (AuthData tag) ->-  UserId tag ->-  User tag ->-  IO (StoredUser tag)-putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r- patchUser ::-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Maybe (AuthData tag) ->   UserId tag ->@@ -154,7 +144,7 @@  deleteUser ::   forall tag.-  HasScimClient tag =>+  (HasScimClient tag) =>   ClientEnv ->   Maybe (AuthData tag) ->   UserId tag ->

@@ -46,8 +46,8 @@            "application" // "json"          ] -instance ToJSON a => MimeRender SCIM a where+instance (ToJSON a) => MimeRender SCIM a where   mimeRender _ = mimeRender (Proxy @JSON) -instance FromJSON a => MimeUnrender SCIM a where+instance (FromJSON a) => MimeUnrender SCIM a where   mimeUnrender _ = mimeUnrender (Proxy @JSON)

@@ -22,6 +22,7 @@   ) where +import Control.Monad ((<=<)) import Control.Monad.Except import Web.Scim.Schema.Error @@ -29,7 +30,7 @@ type ScimHandler m = ExceptT ScimError m  -- | Throw a 'ScimError'.-throwScim :: Monad m => ScimError -> ScimHandler m a+throwScim :: (Monad m) => ScimError -> ScimHandler m a throwScim = throwError  -- | A natural transformation for Servant handlers. To use it, you need to@@ -42,7 +43,7 @@ -- You can either do something custom for 'ScimError', or use -- 'scimToServantErr'. fromScimHandler ::-  Monad m =>+  (Monad m) =>   (forall a. ScimError -> m a) ->   (forall a. ScimHandler m a -> m a) fromScimHandler fromError = either fromError pure <=< runExceptT

@@ -99,7 +99,7 @@ -- -- (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 :: forall m. m ~ Either [Text] => Value -> m Value+jsonLower :: forall m. (m ~ Either [Text]) => Value -> m Value jsonLower (Object (KeyMap.toList -> olist)) =   Object . KeyMap.fromList <$> (nubCI >> mapM lowerPair olist)   where

@@ -58,10 +58,10 @@   where     len = length list -instance FromJSON a => FromJSON (ListResponse a) where+instance (FromJSON a) => FromJSON (ListResponse a) where   parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower -instance ToJSON a => ToJSON (ListResponse a) where+instance (ToJSON a) => ToJSON (ListResponse a) where   toJSON ListResponse {..} =     object       [ "Resources" .= resources,

@@ -33,6 +33,8 @@  instance ToJSON ETag where   toJSON (Weak tag) = String $ "W/" <> pack (show tag)+  -- (if a strong tag contains a "W/" prefix by accident, it will be parsed as weak tag.  this+  -- is mildly confusing, but should do no harm.)   toJSON (Strong tag) = String $ pack (show tag)  instance FromJSON ETag where

@@ -18,6 +18,7 @@ module Web.Scim.Schema.PatchOp where  import Control.Applicative+import Control.Monad (guard) import Control.Monad.Except import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap@@ -85,7 +86,7 @@ -- TODO(arianvp): According to the SCIM spec we should throw an InvalidPath -- error when the path is invalid syntax. this is a bit hard to do though as we -- can't control what errors FromJSON throws :/-instance UserTypes tag => FromJSON (PatchOp tag) where+instance (UserTypes tag) => FromJSON (PatchOp tag) where   parseJSON = withObject "PatchOp" $ \v -> do     let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v     schemas' :: [Schema] <- o .: "schemas"

@@ -71,6 +71,7 @@   ) where +import Control.Monad import Control.Monad.Except import Data.Aeson import qualified Data.Aeson.Key as Key@@ -95,7 +96,7 @@ import Web.Scim.Schema.User.Photo (Photo) import Web.Scim.Schema.UserTypes --- | SCIM user record, parametrized with type-level tag @t@ (see 'UserTypes').+-- | SCIM user record, parametrized with type-level @tag@ (see 'UserTypes'). data User tag = User   { schemas :: [Schema],     -- Mandatory fields@@ -139,9 +140,9 @@   }   deriving (Generic) -deriving instance Show (UserExtra tag) => Show (User tag)+deriving instance (Show (UserExtra tag)) => Show (User tag) -deriving instance Eq (UserExtra tag) => Eq (User tag)+deriving instance (Eq (UserExtra tag)) => Eq (User tag)  empty ::   -- | Schemas@@ -177,7 +178,7 @@       extra = extra     } -instance FromJSON (UserExtra tag) => FromJSON (User tag) where+instance (FromJSON (UserExtra tag)) => FromJSON (User tag) where   parseJSON = withObject "User" $ \obj -> do     -- Lowercase all fields     let o = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList $ obj@@ -208,7 +209,7 @@     extra <- parseJSON (Object obj)     pure User {..} -instance ToJSON (UserExtra tag) => ToJSON (User tag) where+instance (ToJSON (UserExtra tag)) => ToJSON (User tag) where   toJSON User {..} =     let mainObject =           KeyMap.fromList $

@@ -17,28 +17,29 @@  module Web.Scim.Schema.User.Email where +import Control.Applicative ((<|>)) import Data.Aeson import Data.Text hiding (dropWhile) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic)-import Text.Email.Validate-import Web.Scim.Schema.Common+import qualified Text.Email.Validate as Email+import Web.Scim.Schema.Common hiding (value) -newtype EmailAddress2 = EmailAddress2-  {unEmailAddress :: EmailAddress}+newtype EmailAddress = EmailAddress+  {unEmailAddress :: Email.EmailAddress}   deriving (Show, Eq) -instance FromJSON EmailAddress2 where-  parseJSON = withText "Email" $ \e -> case emailAddress (encodeUtf8 e) of+instance FromJSON EmailAddress where+  parseJSON = withText "Email" $ \e -> case Email.emailAddress (encodeUtf8 e) of     Nothing -> fail "Invalid email"-    Just some -> pure $ EmailAddress2 some+    Just some -> pure $ EmailAddress some -instance ToJSON EmailAddress2 where-  toJSON (EmailAddress2 e) = String $ decodeUtf8 . toByteString $ e+instance ToJSON EmailAddress where+  toJSON (EmailAddress e) = String $ decodeUtf8 . Email.toByteString $ e  data Email = Email-  { typ :: Maybe Text,-    value :: EmailAddress2,+  { typ :: Maybe Text, -- Work, private, and so on+    value :: EmailAddress,     primary :: Maybe ScimBool   }   deriving (Show, Eq, Generic)@@ -48,3 +49,16 @@  instance ToJSON Email where   toJSON = genericToJSON serializeOptions++emailToEmailAddress :: Email -> Email.EmailAddress+emailToEmailAddress = unEmailAddress . value++scimEmailsToEmailAddress :: [Email] -> Maybe Email.EmailAddress+scimEmailsToEmailAddress es = pickPrimary es <|> pickFirst es+  where+    pickFirst [] = Nothing+    pickFirst (e : _) = Just (unEmailAddress (value e))++    pickPrimary = pickFirst . Prelude.filter isPrimary++    isPrimary e = primary e == Just (ScimBool True)

@@ -85,7 +85,7 @@  siteServer ::   forall tag m.-  DB tag m =>+  (DB tag m) =>   Configuration ->   Site tag (AsServerT (ScimHandler m)) siteServer conf =@@ -117,7 +117,7 @@  app ::   forall tag m.-  App tag m (SiteAPI tag) =>+  (App tag m (SiteAPI tag)) =>   Configuration ->   (forall a. ScimHandler m a -> Handler a) ->   Application

@@ -23,6 +23,7 @@ -- <https://developer.okta.com/standards/SCIM/#step-2-test-your-scim-server>). module Web.Scim.Server.Mock where +import Control.Monad import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.STM (STM, atomically)@@ -88,7 +89,7 @@ -- in-memory implementation of the API for tests type TestServer = ReaderT TestStorage Handler -liftSTM :: MonadIO m => STM a -> m a+liftSTM :: (MonadIO m) => STM a -> m a liftSTM = liftIO . atomically  hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a@@ -140,7 +141,7 @@   deleteUser () uid = do     m <- asks userDB     liftSTM (STMMap.lookup uid m) >>= \case-      Nothing -> throwScim (notFound "User" (pack (show uid)))+      Nothing -> pure ()       Just _ -> liftSTM $ STMMap.delete uid m  -- (there seems to be no readOnly fields in User)

@@ -46,7 +46,7 @@ import Web.Scim.Schema.UserTypes import Web.Scim.Test.Util -ignore :: Monad m => m a -> m ()+ignore :: (Monad m) => m a -> m () ignore _ = pure ()  -- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation@@ -263,7 +263,8 @@       patch' queryConfig ("/Users/" <> testuid) op3 `shouldRespondWith` result3       -- Delete User       delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204-      delete' queryConfig ("/Users/" <> testuid) "" `shouldEventuallyRespondWith` 404+      -- (... idempotently)+      delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204     it "Group operations" $ const pending  sampleUser1 :: Text -> L.ByteString

@@ -83,17 +83,17 @@ -- FUTUREWORK: make this a PR upstream.  (while we're at it, we can also patch 'WaiSession' -- and 'request' to keep track of the 'SRequest', and add that to the error message here with -- the response.)-shouldRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st+shouldRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldRespondWith action matcher =   either (liftIO . expectationFailure) pure =<< doesRespondWith action matcher -doesRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ())+doesRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ()) doesRespondWith action matcher = do   r <- action   let extmsg = "  details:  " <> show r <> "\n"   pure $ maybe (Right ()) (Left . (<> extmsg)) (match r matcher) -shouldEventuallyRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st+shouldEventuallyRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldEventuallyRespondWith action matcher =   either (liftIO . expectationFailure) pure     =<< Retry.retrying

@@ -17,10 +17,7 @@ -- 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.Class.UserSpec-  ( spec,-  )-where+module Test.Class.UserSpec (spec) where  import Data.ByteString.Lazy (ByteString) import Network.Wai (Application)@@ -386,14 +383,15 @@             { matchStatus = 200             }   describe "DELETE /Users/:id" $ do-    it "responds with 404 for unknown user" $ do-      delete "/9999" `shouldRespondWith` 404+    it "responds with 204 for unknown user" $ do+      delete "/9999" `shouldRespondWith` 204     it "deletes a stored user" $ do       post "/" newBarbara `shouldRespondWith` 201       delete "/0" `shouldRespondWith` 204       -- user should be gone       get "/0" `shouldRespondWith` 404-      delete "/0" `shouldRespondWith` 404+      -- delete is idempotent+      delete "/0" `shouldRespondWith` 204  smallUser :: ByteString smallUser =

@@ -32,7 +32,7 @@ import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) import Web.Scim.Test.Util (TestTag) -prop_roundtrip :: forall tag. UserTypes tag => Property+prop_roundtrip :: forall tag. (UserTypes tag) => Property prop_roundtrip = property $ do   x <- forAll $ genFilter @tag   tripping x renderFilter $ parseFilter (supportedSchemas @tag)@@ -45,7 +45,7 @@ ---------------------------------------------------------------------------- -- Generators -genValuePath :: forall tag. UserTypes tag => Gen ValuePath+genValuePath :: forall tag. (UserTypes tag) => Gen ValuePath genValuePath = ValuePath <$> genAttrPath @tag <*> genFilter @tag  genCompValue :: Gen CompValue@@ -72,16 +72,16 @@ -- FUTUREWORK: we also may want to factor a bounded enum type out of the 'Schema' type for -- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving -- (Bounded, Enum, ...)@-genSchema :: forall tag. UserTypes tag => Gen Schema+genSchema :: forall tag. (UserTypes tag) => Gen Schema genSchema = Gen.element (supportedSchemas @tag) -genAttrPath :: forall tag. UserTypes tag => Gen AttrPath+genAttrPath :: forall tag. (UserTypes tag) => Gen AttrPath genAttrPath = AttrPath <$> Gen.maybe (genSchema @tag) <*> genAttrName <*> Gen.maybe genSubAttr  genAttrName :: Gen AttrName genAttrName = AttrName <$> (cons <$> Gen.alpha <*> Gen.text (Range.constant 0 50) (Gen.choice [Gen.alphaNum, Gen.constant '-', Gen.constant '_'])) -genFilter :: forall tag. UserTypes tag => Gen Filter+genFilter :: forall tag. (UserTypes tag) => Gen Filter genFilter =   Gen.choice     [ FilterAttrCompare <$> (genAttrPath @tag) <*> genCompareOp <*> genCompValue

@@ -48,28 +48,28 @@ isSuccess (Success _) = True isSuccess (Error _) = False -genPatchOp :: forall tag. UserTypes tag => Gen Value -> Gen (PatchOp tag)+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 :: 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 :: forall tag. (UserTypes tag) => Gen Value -> Gen Operation genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe (genPath @tag) <*> Gen.maybe genValue -genPath :: forall tag. UserTypes tag => Gen Path+genPath :: forall tag. (UserTypes tag) => Gen Path genPath =   Gen.choice     [ IntoValuePath <$> (genValuePath @tag) <*> Gen.maybe genSubAttr,       NormalPath <$> (genAttrPath @tag)     ] -prop_roundtrip :: forall tag. UserTypes tag => Property+prop_roundtrip :: forall tag. (UserTypes tag) => Property prop_roundtrip = property $ do   x <- forAll $ genPath @tag   tripping x (encodeUtf8 . rPath) (parseOnly $ pPath (supportedSchemas @tag)) -prop_roundtrip_PatchOp :: forall tag. UserTypes tag => Property+prop_roundtrip_PatchOp :: forall tag. (UserTypes tag) => Property prop_roundtrip_PatchOp = property $ do   -- 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

@@ -38,7 +38,7 @@ import Network.URI.Static (uri) import Test.Hspec import Test.Schema.Util (genUri, mk_prop_caseInsensitive)-import Text.Email.Validate (emailAddress)+import Text.Email.Validate (emailAddress, validate) import qualified Web.Scim.Class.User as UserClass import Web.Scim.Filter (AttrPath (..)) import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..), lowerKey)@@ -69,6 +69,38 @@  spec :: Spec spec = do+  describe "scimEmailsToEmailAddress" $ do+    let Right adr1 = validate "one@example.com"+        Right adr2 = validate "two@example.com"+        Right adr3 = validate "three@example.com"++        false1 = Nothing+        false2 = Just (ScimBool False)+        true = Just (ScimBool True)++    it "returns Nothing if empty" $ do+      scimEmailsToEmailAddress [] `shouldBe` Nothing++    it "returns first primary if it exists" $ do+      scimEmailsToEmailAddress+        [ Email Nothing (EmailAddress adr1) false1,+          Email Nothing (EmailAddress adr2) false2,+          Email (Just "this is ignored") (EmailAddress adr3) true+        ]+        `shouldBe` Just adr3++    it "returns first entry if no primary exists" $ do+      scimEmailsToEmailAddress+        [ Email Nothing (EmailAddress adr1) false1,+          Email Nothing (EmailAddress adr2) false2+        ]+        `shouldBe` Just adr1+      scimEmailsToEmailAddress+        [ Email Nothing (EmailAddress adr1) false2,+          Email Nothing (EmailAddress adr2) false1+        ]+        `shouldBe` Just adr1+   describe "applyPatch" $ do     it "only applies patch for supported fields" $ do       let schemas' = []@@ -127,13 +159,15 @@       toJSON minimalUser `shouldBe` minimalUserJson       eitherDecode (encode minimalUserJson) `shouldBe` Right minimalUser     it "treats 'null' and '[]' as absence of fields" $-      eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser+      eitherDecode (encode minimalUserJsonRedundant)+        `shouldBe` Right minimalUser     it "allows casing variations in field names" $ do       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+      eitherDecode (encode minimalUserJsonNoSchemas)+        `shouldBe` Right minimalUser     it "doesn't add 'extra' if it's an empty object" $ do       toJSON (extendedUser UserExtraEmpty) `shouldBe` extendedUserEmptyJson       eitherDecode (encode extendedUserEmptyJson)@@ -156,7 +190,7 @@ genStoredUser :: Gen (UserClass.StoredUser (TestTag Text () () NoUserExtra)) genStoredUser = do   m <- genMeta-  i <- Gen.element @_ @Text ["wef", "asdf", "@", "#", "1"]+  i <- Gen.element ["wef", "asdf", "@", "#", "1"]   WithMeta m . WithId i <$> genUser  genMeta :: Gen Meta@@ -251,7 +285,7 @@               Email.value =                 maybe                   (error "couldn't parse email")-                  EmailAddress2+                  EmailAddress                   (emailAddress "user@example.com"),               Email.primary = Nothing             }

@@ -60,5 +60,5 @@       same@(Bool _) -> same       same@Null -> same -keyTextL :: Functor f => (Text -> f Text) -> Key -> f Key+keyTextL :: (Functor f) => (Text -> f Text) -> Key -> f Key keyTextL f key = fmap Key.fromText (f (Key.toText key))