hscim client

CHANGELOG.md

@@ -31,6 +31,8 @@
 
 ## Features
 
+* Client functions for the hscim library (#1699)
+
 ## Bug fixes and other updates
 
 ## Documentation

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

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

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 ::

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 <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!"

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'
 
 ----------------------------------------------------------------------------

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