diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/hscim.cabal b/hscim.cabal --- a/hscim.cabal +++ b/hscim.cabal @@ -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 diff --git a/server/Main.hs b/server/Main.hs --- a/server/Main.hs +++ b/server/Main.hs @@ -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 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 @@ -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 = diff --git a/src/Web/Scim/Class/Group.hs b/src/Web/Scim/Class/Group.hs --- a/src/Web/Scim/Class/Group.hs +++ b/src/Web/Scim/Class/Group.hs @@ -171,7 +171,7 @@ groupServer :: forall tag m. - GroupDB tag m => + (GroupDB tag m) => Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m)) groupServer authData = 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 @@ -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 -> diff --git a/src/Web/Scim/ContentType.hs b/src/Web/Scim/ContentType.hs --- a/src/Web/Scim/ContentType.hs +++ b/src/Web/Scim/ContentType.hs @@ -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) diff --git a/src/Web/Scim/Handler.hs b/src/Web/Scim/Handler.hs --- a/src/Web/Scim/Handler.hs +++ b/src/Web/Scim/Handler.hs @@ -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 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 @@ -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 diff --git a/src/Web/Scim/Schema/ListResponse.hs b/src/Web/Scim/Schema/ListResponse.hs --- a/src/Web/Scim/Schema/ListResponse.hs +++ b/src/Web/Scim/Schema/ListResponse.hs @@ -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, diff --git a/src/Web/Scim/Schema/Meta.hs b/src/Web/Scim/Schema/Meta.hs --- a/src/Web/Scim/Schema/Meta.hs +++ b/src/Web/Scim/Schema/Meta.hs @@ -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 diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs --- a/src/Web/Scim/Schema/PatchOp.hs +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -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" diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -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 $ diff --git a/src/Web/Scim/Schema/User/Email.hs b/src/Web/Scim/Schema/User/Email.hs --- a/src/Web/Scim/Schema/User/Email.hs +++ b/src/Web/Scim/Schema/User/Email.hs @@ -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) diff --git a/src/Web/Scim/Server.hs b/src/Web/Scim/Server.hs --- a/src/Web/Scim/Server.hs +++ b/src/Web/Scim/Server.hs @@ -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 diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -23,6 +23,7 @@ -- ). 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) diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -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 diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -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 diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -17,10 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -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 = diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -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 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 @@ -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 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 @@ -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 } diff --git a/test/Test/Schema/Util.hs b/test/Test/Schema/Util.hs --- a/test/Test/Schema/Util.hs +++ b/test/Test/Schema/Util.hs @@ -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))