diff --git a/CHANGELOG.md b/CHANGELOG.md index 35e8d149785..0351bf137d9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,6 +31,8 @@ ## Features +* Client functions for the hscim library (#1699) + ## Bug fixes and other updates ## Documentation 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/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index d7fa8b40d47..600a6d69c4b 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 @@ -39,7 +40,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) @@ -58,6 +59,18 @@ 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 + <$> 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 +80,9 @@ data BulkConfig = BulkConfig instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions +instance FromJSON BulkConfig where + parseJSON = genericParseJSON serializeOptions + data FilterConfig = FilterConfig { maxResults :: Int } @@ -75,6 +91,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], @@ -84,13 +103,16 @@ data Configuration = Configuration changePassword :: Supported (), sort :: Supported (), etag :: Supported (), - authenticationSchemes :: [AuthenticationSchemeEncoding] + authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding] } deriving (Show, Eq, Generic) instance ToJSON Configuration where toJSON = genericToJSON serializeOptions +instance FromJSON Configuration where + parseJSON = genericParseJSON serializeOptions + empty :: Configuration empty = Configuration @@ -108,7 +130,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/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!" diff --git a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs index b6baae5bc25..24ec013f207 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 @@ -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/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 diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs new file mode 100644 index 00000000000..4fb0e6414a0 --- /dev/null +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -0,0 +1,106 @@ +{-# 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 ()` 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 + 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 + 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 + BulkConfig + <$> Gen.int (Range.linear 0 100) + <*> Gen.int (Range.linear 0 100) + +genFilterConfig :: Gen FilterConfig +genFilterConfig = do + FilterConfig <$> Gen.int (Range.linear 0 100) + +genAuthenticationSchemeEncoding :: Gen AuthenticationSchemeEncoding +genAuthenticationSchemeEncoding = do + AuthenticationSchemeEncoding + <$> genSimpleText + <*> genSimpleText + <*> genSimpleText + <*> Gen.maybe genUri + <*> Gen.maybe genUri + +genSupported :: forall a. Gen a -> Gen (Supported a) +genSupported gen = do + 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|]] + +genSimpleText :: Gen Text +genSimpleText = Gen.element ["one", "green", "sharp"] 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