hscim 0.3.4 → 0.3.5

raw patch · 7 files changed

+370/−11 lines, 7 filesdep +servant-clientdep +servant-client-corePVP ok

version bump matches the API change (PVP)

Dependencies added: servant-client, servant-client-core

API changes (from Hackage documentation)

Files

• hscim.cabal +15/−6
• src/Web/Scim/Capabilities/MetaSchema.hs +25/−3
• src/Web/Scim/Client.hs +217/−0
• src/Web/Scim/Schema/AuthenticationScheme.hs +4/−1
• src/Web/Scim/Server.hs +1/−0
• test/Test/Schema/MetaSchemaSpec.hs +107/−0
• test/Test/Schema/UserSpec.hs +1/−1

@@ -1,18 +1,18 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 83af2bccd0f2eb8ffc6a89254b3c8de7c938537ad70df57e11701e997242f1f7+-- hash: b8d0589f22bc168d16fa3a2b2800d9cc3b14b4d94bb911fe973ccf2a2025e5e5  name:           hscim-version:        0.3.4+version:        0.3.5 synopsis:       hscim json schema and server implementation description:    The README file will answer all the questions you might have category:       Web-homepage:       https://github.com/wireapp/hscim/README.md-bug-reports:    https://github.com/wireapp/hscim/issues+homepage:       https://github.com/wireapp/wire-server/libs/hscim/README.md+bug-reports:    https://github.com/wireapp/wire-server/issues author:         Wire Swiss GmbH maintainer:     Wire Swiss GmbH <backend@wire.com> copyright:      (c) 2021 Wire Swiss GmbH@@ -25,7 +25,8 @@  source-repository head   type: git-  location: https://github.com/wireapp/hscim+  location: https://github.com/wireapp/wire-server+  subdir: libs/hscim  library   exposed-modules:@@ -39,6 +40,7 @@       Web.Scim.Class.Auth       Web.Scim.Class.Group       Web.Scim.Class.User+      Web.Scim.Client       Web.Scim.ContentType       Web.Scim.Filter       Web.Scim.Handler@@ -94,6 +96,8 @@     , 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@@ -142,6 +146,8 @@     , 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@@ -167,6 +173,7 @@       Test.Class.UserSpec       Test.FilterSpec       Test.MiscSpec+      Test.Schema.MetaSchemaSpec       Test.Schema.PatchOpSpec       Test.Schema.UserSpec       Paths_hscim@@ -202,6 +209,8 @@     , 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

@@ -29,6 +29,7 @@ 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.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 @@     (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 @@ instance ToJSON BulkConfig where   toJSON = genericToJSON serializeOptions +instance FromJSON BulkConfig where+  parseJSON = genericParseJSON serializeOptions+ data FilterConfig = FilterConfig   { maxResults :: Int   }@@ -75,6 +91,9 @@ 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 @@     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 @@       changePassword = Supported (ScimBool False) (),       sort = Supported (ScimBool False) (),       etag = Supported (ScimBool False) (),-      authenticationSchemes = [authHttpBasicEncoding]+      authenticationSchemes = [AuthScheme.authHttpBasicEncoding]     }  configServer ::

@@ -0,0 +1,217 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- 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 <https://www.gnu.org/licenses/>.++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!"

@@ -19,7 +19,7 @@  module Web.Scim.Schema.AuthenticationScheme   ( AuthenticationScheme (..),-    AuthenticationSchemeEncoding,+    AuthenticationSchemeEncoding (..),     authHttpBasicEncoding,   ) where@@ -64,6 +64,9 @@  instance ToJSON AuthenticationSchemeEncoding where   toJSON = genericToJSON serializeOptions++instance FromJSON AuthenticationSchemeEncoding where+  parseJSON = genericParseJSON serializeOptions  -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' 

@@ -25,6 +25,7 @@      -- * API tree     SiteAPI,+    Site (..),     siteServer,      -- ** API subtrees, useful for tests

@@ -0,0 +1,107 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++-- This file is part of the Wire Server implementation.+--+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>+--+-- 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 <https://www.gnu.org/licenses/>.++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+    -- the extra 'decode' in the golden tests is to make attribute order not count for Eq.+    it "`Supported ()` golden test" $ do+      decode @Value (encode (Supported (ScimBool True) ())) `shouldBe` decode @Value ("{\"supported\":true}")+    it "`Supported a` golden test" $ do+      decode @Value (encode (Supported (ScimBool True) (FilterConfig 3))) `shouldBe` decode @Value "{\"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"]

@@ -160,7 +160,7 @@     <*> 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