From 4a6517c2dce169140d7b365766ce8f07a7f37d5d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 9 Aug 2021 11:29:46 +0200 Subject: [PATCH 1/8] Improve roundtrip generator. --- libs/hscim/test/Test/Schema/UserSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 651f7ebeddd..0cefaa4fae5 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -160,7 +160,7 @@ genName = <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) genUri :: Gen URI -genUri = Gen.element [URI [uri|https://example.com|]] +genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]] -- TODO(arianvp) Generate the lists too, but first need better support for SCIM -- lists in the first place From 1a3f194abe5285ce090c3c1e2fceb2532f3af689 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 9 Aug 2021 11:30:42 +0200 Subject: [PATCH 2/8] Extend module exports. (there was no reason to keep those things local, but we're going to need them in a moment.) --- libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs | 6 +++--- libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs | 2 +- libs/hscim/src/Web/Scim/Server.hs | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index d7fa8b40d47..212b0cab4f3 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -39,7 +39,7 @@ import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.User import Web.Scim.ContentType import Web.Scim.Handler -import Web.Scim.Schema.AuthenticationScheme +import qualified Web.Scim.Schema.AuthenticationScheme as AuthScheme import Web.Scim.Schema.Common import Web.Scim.Schema.Error hiding (schemas) import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas) @@ -84,7 +84,7 @@ data Configuration = Configuration changePassword :: Supported (), sort :: Supported (), etag :: Supported (), - authenticationSchemes :: [AuthenticationSchemeEncoding] + authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding] } deriving (Show, Eq, Generic) @@ -108,7 +108,7 @@ empty = changePassword = Supported (ScimBool False) (), sort = Supported (ScimBool False) (), etag = Supported (ScimBool False) (), - authenticationSchemes = [authHttpBasicEncoding] + authenticationSchemes = [AuthScheme.authHttpBasicEncoding] } configServer :: diff --git a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs index b6baae5bc25..9717d635d19 100644 --- a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -19,7 +19,7 @@ module Web.Scim.Schema.AuthenticationScheme ( AuthenticationScheme (..), - AuthenticationSchemeEncoding, + AuthenticationSchemeEncoding (..), authHttpBasicEncoding, ) where diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index cc726506ca9..4ee886ffd5c 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -25,6 +25,7 @@ module Web.Scim.Server -- * API tree SiteAPI, + Site (..), siteServer, -- ** API subtrees, useful for tests From 6f6429eaf40dae490145d9c03f2e423f2b1c9265 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 9 Aug 2021 11:37:29 +0200 Subject: [PATCH 3/8] Missing FromJSON instances. --- .../src/Web/Scim/Capabilities/MetaSchema.hs | 21 ++++ .../Web/Scim/Schema/AuthenticationScheme.hs | 3 + libs/hscim/test/Test/Schema/MetaSchemaSpec.hs | 104 ++++++++++++++++++ 3 files changed, 128 insertions(+) create mode 100644 libs/hscim/test/Test/Schema/MetaSchemaSpec.hs diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 212b0cab4f3..52faab12b3c 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -29,6 +29,7 @@ where import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) +import Data.Typeable (Typeable, cast) import Servant hiding (URI) import Servant.API.Generic import Servant.Server.Generic @@ -58,6 +59,16 @@ instance ToJSON a => ToJSON (Supported a) where (Object o) -> Object $ HML.insert "supported" (Bool b) o _ -> Object $ HML.fromList [("supported", Bool b)] +instance (Typeable a, FromJSON a) => FromJSON (Supported a) where + parseJSON val = do + Supported + <$> withObject "Supported a" (.: "supported") val + <*> let -- allow special case for empty subConfig (`()` does not parse from json objects) + val' = case cast @() @a () of + Just _ -> Array mempty + Nothing -> val + in parseJSON @a val' + data BulkConfig = BulkConfig { maxOperations :: Int, maxPayloadSize :: Int @@ -67,6 +78,10 @@ data BulkConfig = BulkConfig instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions +instance FromJSON BulkConfig where + parseJSON = withObject "BulkConfig" $ \obj -> do + BulkConfig <$> obj .: "maxOperations" <*> obj .: "maxPayloadSize" + data FilterConfig = FilterConfig { maxResults :: Int } @@ -75,6 +90,9 @@ data FilterConfig = FilterConfig instance ToJSON FilterConfig where toJSON = genericToJSON serializeOptions +instance FromJSON FilterConfig where + parseJSON = genericParseJSON serializeOptions + data Configuration = Configuration { documentationUri :: Maybe URI, schemas :: [Schema], @@ -91,6 +109,9 @@ data Configuration = Configuration instance ToJSON Configuration where toJSON = genericToJSON serializeOptions +instance FromJSON Configuration where + parseJSON = genericParseJSON serializeOptions + empty :: Configuration empty = Configuration diff --git a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs index 9717d635d19..24ec013f207 100644 --- a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -65,6 +65,9 @@ data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding instance ToJSON AuthenticationSchemeEncoding where toJSON = genericToJSON serializeOptions +instance FromJSON AuthenticationSchemeEncoding where + parseJSON = genericParseJSON serializeOptions + -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' ---------------------------------------------------------------------------- diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs new file mode 100644 index 00000000000..eda95c0f395 --- /dev/null +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- 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.MetaSchemaSpec + ( 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 Network.URI.Static (uri) +import Test.Hspec +import Web.Scim.Capabilities.MetaSchema +import Web.Scim.Schema.AuthenticationScheme +import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..)) +import Web.Scim.Schema.Schema (Schema (..)) +import Prelude hiding (filter) + +prop_roundtrip :: (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property +prop_roundtrip gen = property $ do + config <- forAll gen + tripping config toJSON fromJSON + +spec :: Spec +spec = do + describe "MetaSchema" $ do + it "`Supported ()` roundtrips" $ do + require (prop_roundtrip (genSupported (pure ()))) + it "`BulkConfig` roundtrips" $ do + require (prop_roundtrip genBulkConfig) + it "`FilterConfig` roundtrips" $ do + require (prop_roundtrip genFilterConfig) + it "`AuthenticationSchemeEncoding` roundtrips" $ do + require (prop_roundtrip genAuthenticationSchemeEncoding) + it "`Configuration` roundtrips" $ do + require (prop_roundtrip genConfiguration) + +genConfiguration :: Gen Configuration +genConfiguration = do + documentationUri <- Gen.maybe genUri + schemas <- pure [User20] + patch <- genSupported (pure ()) + bulk <- genSupported genBulkConfig + filter <- genSupported genFilterConfig + changePassword <- genSupported (pure ()) + sort <- genSupported (pure ()) + etag <- genSupported (pure ()) + authenticationSchemes <- Gen.list (Range.linear 0 100) genAuthenticationSchemeEncoding + pure Configuration {..} + +genBulkConfig :: Gen BulkConfig +genBulkConfig = do + maxOperations <- Gen.int (Range.linear 0 100) + maxPayloadSize <- Gen.int (Range.linear 0 100) + pure BulkConfig {..} + +genFilterConfig :: Gen FilterConfig +genFilterConfig = do + maxResults <- Gen.int (Range.linear 0 100) + pure FilterConfig {..} + +genAuthenticationSchemeEncoding :: Gen AuthenticationSchemeEncoding +genAuthenticationSchemeEncoding = do + typ <- genSimpleText + name <- genSimpleText + description <- genSimpleText + specUri <- Gen.maybe genUri + documentationUri <- Gen.maybe genUri + pure AuthenticationSchemeEncoding {..} + +genSupported :: forall a. Gen a -> Gen (Supported a) +genSupported gen = do + supported :: ScimBool <- ScimBool <$> Gen.bool + subConfig :: a <- gen + pure Supported {..} + +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"] From 77d6538851173a61cebe2646b9baa8ee96a40ed3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 9 Aug 2021 11:38:58 +0200 Subject: [PATCH 4/8] Client routes. --- libs/hscim/hscim.cabal | 10 +- libs/hscim/package.yaml | 2 + libs/hscim/src/Web/Scim/Client.hs | 217 ++++++++++++++++++++++++++++++ 3 files changed, 228 insertions(+), 1 deletion(-) create mode 100644 libs/hscim/src/Web/Scim/Client.hs diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index 9add83d14a6..e5afdc50875 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 2e0b95d267e0d862fecf234432ad88860a642778490d46ce7ae8ab2b3e297e9a +-- hash: b8d0589f22bc168d16fa3a2b2800d9cc3b14b4d94bb911fe973ccf2a2025e5e5 name: hscim version: 0.3.4 @@ -40,6 +40,7 @@ library Web.Scim.Class.Auth Web.Scim.Class.Group Web.Scim.Class.User + Web.Scim.Client Web.Scim.ContentType Web.Scim.Filter Web.Scim.Handler @@ -95,6 +96,8 @@ library , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 @@ -143,6 +146,8 @@ executable hscim-server , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 @@ -168,6 +173,7 @@ test-suite spec Test.Class.UserSpec Test.FilterSpec Test.MiscSpec + Test.Schema.MetaSchemaSpec Test.Schema.PatchOpSpec Test.Schema.UserSpec Paths_hscim @@ -203,6 +209,8 @@ test-suite spec , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.19 + , servant-client >=0.16.2 && <0.19 + , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 diff --git a/libs/hscim/package.yaml b/libs/hscim/package.yaml index 46713ed39eb..7a6e3bc0d19 100644 --- a/libs/hscim/package.yaml +++ b/libs/hscim/package.yaml @@ -69,6 +69,8 @@ dependencies: - network-uri >= 2.6.2 && < 2.7 - servant >= 0.16.2 && < 0.19 - servant-server >= 0.16.2 && < 0.19 + - servant-client >= 0.16.2 && < 0.19 + - servant-client-core >= 0.16.2 && < 0.19 - warp >= 3.2.28 && < 3.4 - stm-containers >= 1.1.0 && < 1.2 - string-conversions >= 0.4.0 && < 0.5 diff --git a/libs/hscim/src/Web/Scim/Client.hs b/libs/hscim/src/Web/Scim/Client.hs new file mode 100644 index 00000000000..d27b83a12f3 --- /dev/null +++ b/libs/hscim/src/Web/Scim/Client.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- 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 Web.Scim.Client + ( HasScimClient, + + -- * config + spConfig, + getSchemas, + schema, + resourceTypes, + + -- * user + scimClients, + getUsers, + getUser, + postUser, + putUser, + patchUserr, + deleteUser, + + -- * group + getGroups, + getGroup, + postGroup, + putGroup, + patchGroup, + deleteGroup, + ) +where + +import Control.Exception +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Text +import Servant.API +import Servant.Client +import Servant.Client.Generic +import qualified Web.Scim.Capabilities.MetaSchema as MetaSchema +import Web.Scim.Class.Auth +import Web.Scim.Class.Group (Group, GroupId, StoredGroup) +import Web.Scim.Class.User (StoredUser) +import Web.Scim.Filter (Filter) +import Web.Scim.Schema.ListResponse (ListResponse) +import Web.Scim.Schema.PatchOp (PatchOp) +import qualified Web.Scim.Schema.ResourceType as ResourceType +import Web.Scim.Schema.User (User) +import Web.Scim.Schema.UserTypes (UserExtra, UserId) +import Web.Scim.Server + +type HasScimClient tag = + ( AuthTypes tag, + ToJSON (UserExtra tag), + FromJSON (UserExtra tag), + FromJSON (UserId tag), + FromJSON (GroupId tag), + ToHttpApiData (AuthData tag), + ToHttpApiData (UserId tag), + ToHttpApiData (GroupId tag) + ) + +scimClients :: HasScimClient tag => ClientEnv -> Site tag (AsClientT IO) +scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO return + +-- config + +spConfig :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO MetaSchema.Configuration +spConfig env = case config @tag (scimClients env) of ((r :<|> _) :<|> (_ :<|> _)) -> r + +getSchemas :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO (ListResponse Value) +getSchemas env = case config @tag (scimClients env) of ((_ :<|> r) :<|> (_ :<|> _)) -> r + +schema :: + forall tag. + HasScimClient tag => + ClientEnv -> + Text -> + IO Value +schema env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (r :<|> _)) -> r + +resourceTypes :: + forall tag. + HasScimClient tag => + ClientEnv -> + IO (ListResponse ResourceType.Resource) +resourceTypes env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (_ :<|> r)) -> r + +-- users + +getUsers :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + Maybe Filter -> + IO (ListResponse (StoredUser tag)) +getUsers env tok = case users (scimClients env) tok of ((r :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r + +getUser :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + IO (StoredUser tag) +getUser env tok = case users (scimClients env) tok of ((_ :<|> (r :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r + +postUser :: + 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 + +patchUserr :: + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + PatchOp tag -> + IO (StoredUser tag) +patchUserr env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (r :<|> _))) -> r + +deleteUser :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + UserId tag -> + IO NoContent +deleteUser env tok = case users @tag (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> r))) -> r + +-- groups + +getGroups :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + IO (ListResponse (StoredGroup tag)) +getGroups = error "groups are not authenticated at the moment; implement that first!" + +getGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +getGroup = error "groups are not authenticated at the moment; implement that first!" + +postGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + Group -> + IO (StoredGroup tag) +postGroup = error "groups are not authenticated at the moment; implement that first!" + +putGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +putGroup = error "groups are not authenticated at the moment; implement that first!" + +patchGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO (StoredGroup tag) +patchGroup = error "groups are not authenticated at the moment; implement that first!" + +deleteGroup :: + forall tag. + HasScimClient tag => + ClientEnv -> + Maybe (AuthData tag) -> + GroupId tag -> + IO DeleteNoContent +deleteGroup = error "groups are not authenticated at the moment; implement that first!" From 7f4cf2525c4c565013dc4f5b8d878cd8617b7f98 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 9 Aug 2021 11:45:19 +0200 Subject: [PATCH 5/8] CHANGELOG --- CHANGELOG.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 87fa908e882..9aa316c9b7a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,11 +31,13 @@ ## Features +* Client functions for the hscim library (#1699) + ## Bug fixes and other updates ## Documentation -* fix swagger: mark name in UserUpdate as optional (#1691) +* fix swagger: mark name in UserUpdate as optional (#1691) ## Internal changes From 892efabfa36073758cc72ceb19cea86b2663502a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 10 Aug 2021 11:36:46 +0200 Subject: [PATCH 6/8] golden tests. --- libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs | 2 ++ libs/hscim/test/Test/Schema/MetaSchemaSpec.hs | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 52faab12b3c..b451e6c11cf 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -59,6 +59,8 @@ instance ToJSON a => ToJSON (Supported a) where (Object o) -> Object $ HML.insert "supported" (Bool b) o _ -> Object $ HML.fromList [("supported", Bool b)] +-- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance +-- better. instance (Typeable a, FromJSON a) => FromJSON (Supported a) where parseJSON val = do Supported diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs index eda95c0f395..cad90b6d9f1 100644 --- a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -47,6 +47,10 @@ prop_roundtrip gen = property $ do spec :: Spec spec = do describe "MetaSchema" $ do + it "`Supported ()` golden test" $ do + encode (Supported (ScimBool True) ()) `shouldBe` "{\"supported\":true}" + it "`Supported a` golden test" $ do + encode (Supported (ScimBool True) (FilterConfig 3)) `shouldBe` "{\"supported\":true,\"maxResults\":3}" it "`Supported ()` roundtrips" $ do require (prop_roundtrip (genSupported (pure ()))) it "`BulkConfig` roundtrips" $ do From 5da66dc36935abed6e8888cf39d8c0082ab2e1b8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 10 Aug 2021 11:38:03 +0200 Subject: [PATCH 7/8] use generic where appropriate. --- libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index b451e6c11cf..600a6d69c4b 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -81,8 +81,7 @@ instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions instance FromJSON BulkConfig where - parseJSON = withObject "BulkConfig" $ \obj -> do - BulkConfig <$> obj .: "maxOperations" <*> obj .: "maxPayloadSize" + parseJSON = genericParseJSON serializeOptions data FilterConfig = FilterConfig { maxResults :: Int From e0b3c962a9ad46e52b18a20d678448d408206150 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 10 Aug 2021 11:41:19 +0200 Subject: [PATCH 8/8] applicative hedgehog generators. --- libs/hscim/test/Test/Schema/MetaSchemaSpec.hs | 46 +++++++++---------- 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs index cad90b6d9f1..4fb0e6414a0 100644 --- a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -64,42 +64,40 @@ spec = do genConfiguration :: Gen Configuration genConfiguration = do - documentationUri <- Gen.maybe genUri - schemas <- pure [User20] - patch <- genSupported (pure ()) - bulk <- genSupported genBulkConfig - filter <- genSupported genFilterConfig - changePassword <- genSupported (pure ()) - sort <- genSupported (pure ()) - etag <- genSupported (pure ()) - authenticationSchemes <- Gen.list (Range.linear 0 100) genAuthenticationSchemeEncoding - pure Configuration {..} + Configuration + <$> Gen.maybe genUri + <*> pure [User20] + <*> genSupported (pure ()) + <*> genSupported genBulkConfig + <*> genSupported genFilterConfig + <*> genSupported (pure ()) + <*> genSupported (pure ()) + <*> genSupported (pure ()) + <*> Gen.list (Range.linear 0 100) genAuthenticationSchemeEncoding genBulkConfig :: Gen BulkConfig genBulkConfig = do - maxOperations <- Gen.int (Range.linear 0 100) - maxPayloadSize <- Gen.int (Range.linear 0 100) - pure BulkConfig {..} + BulkConfig + <$> Gen.int (Range.linear 0 100) + <*> Gen.int (Range.linear 0 100) genFilterConfig :: Gen FilterConfig genFilterConfig = do - maxResults <- Gen.int (Range.linear 0 100) - pure FilterConfig {..} + FilterConfig <$> Gen.int (Range.linear 0 100) genAuthenticationSchemeEncoding :: Gen AuthenticationSchemeEncoding genAuthenticationSchemeEncoding = do - typ <- genSimpleText - name <- genSimpleText - description <- genSimpleText - specUri <- Gen.maybe genUri - documentationUri <- Gen.maybe genUri - pure AuthenticationSchemeEncoding {..} + AuthenticationSchemeEncoding + <$> genSimpleText + <*> genSimpleText + <*> genSimpleText + <*> Gen.maybe genUri + <*> Gen.maybe genUri genSupported :: forall a. Gen a -> Gen (Supported a) genSupported gen = do - supported :: ScimBool <- ScimBool <$> Gen.bool - subConfig :: a <- gen - pure Supported {..} + 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|]]