WPB-20055 Endpoint for updating user group with SCIM

integration/test/API/Spar.hs

@@ -91,6 +91,18 @@ updateScimUser domain scimToken userId scimUser = do
     & addJSON body . addHeader "Authorization" ("Bearer " <> scimToken)
     & addHeader "Accept" "application/scim+json"
 
+createScimUserGroup :: (HasCallStack, MakesValue domain, MakesValue scimUserGroup) => domain -> String -> scimUserGroup -> App Response
+createScimUserGroup domain token scimUserGroup = do
+  req <- baseRequest domain Spar Versioned "/scim/v2/Groups"
+  body <- make scimUserGroup
+  submit "POST" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token)
+
+updateScimUserGroup :: (HasCallStack, MakesValue domain, MakesValue scimUserGroup) => domain -> String -> String -> scimUserGroup -> App Response
+updateScimUserGroup domain token groupId scimUserGroup = do
+  req <- baseRequest domain Spar Versioned $ joinHttpPath ["scim", "v2", "Groups", groupId]
+  body <- make scimUserGroup
+  submit "PUT" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token)
+
 -- | https://staging-nginz-https.zinfra.io/v12/api/swagger-ui/#/default/idp-create
 createIdp :: (HasCallStack, MakesValue user) => user -> SAML.IdPMetadata -> App Response
 createIdp user metadata = do

integration/test/Test/Spar.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-incomplete-patterns  -Wno-ambiguous-fields #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-ambiguous-fields #-}
 
 module Test.Spar where
 
@@ -362,6 +362,74 @@ testSparCreateScimTokenWithName = do
   assoc <- token %. "id"
   token %. "name" `shouldMatch` Just assoc
 
+----------------------------------------------------------------------
+-- scim group stuff
+
+testSparScimCreateUserGroup :: (HasCallStack) => App ()
+testSparScimCreateUserGroup = do
+  (owner, _, _) <- createTeam OwnDomain 1
+  tok <- createScimTokenV6 owner def >>= \resp -> resp.json %. "token" >>= asString
+  let scimUserGroup =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "ze groop",
+            "members"
+              .= [ object
+                     [ "typ" .= "User",
+                       "$ref" .= "https://...", -- TODO: we should probably validate these?  or just ignore them?
+                       "value" .= "ea2e4bf0-aa5e-11f0-96ad-e776a606779b"
+                     ]
+                 ]
+          ]
+  resp <- createScimUserGroup OwnDomain tok scimUserGroup
+  assertSuccess resp
+
+-- get group here via resp
+
+testSparScimUpdateUserGroup :: (HasCallStack) => App ()
+testSparScimUpdateUserGroup = do
+  (owner, _, u1 : u2 : u3 : _) <- createTeam OwnDomain 4
+  u1Id <- u1 %. "id" >>= asString
+  u2Id <- u2 %. "id" >>= asString
+  u3Id <- u3 %. "id" >>= asString
+  tok <- createScimToken owner def >>= getJSON 200 >>= (%. "token") >>= asString
+  let scimUserGroup =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "My funky group",
+            "members"
+              .= [ object
+                     [ "value" .= u1Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u1Id)
+                     ],
+                   object
+                     [ "value" .= u2Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u2Id)
+                     ]
+                 ]
+          ]
+  gid <- createScimUserGroup OwnDomain tok scimUserGroup >>= getJSON 200 >>= (%. "id") >>= asString
+  let scimUserGroupUpdated =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "My even funkier group",
+            "members"
+              .= [ object
+                     [ "value" .= u2Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u2Id)
+                     ],
+                   object
+                     [ "value" .= u3Id,
+                       "type" .= "User",
+                       "$ref" .= ("http://example.com:8088/scim/v2/Users/" <> u3Id)
+                     ]
+                 ]
+          ]
+  updateScimUserGroup OwnDomain tok gid scimUserGroupUpdated >>= assertSuccess
+
 ----------------------------------------------------------------------
 -- saml stuff
 

libs/hscim/hscim.cabal

@@ -6,7 +6,9 @@ description:
   The README file will answer all the questions you might have
 
 category:           Web
-homepage:           https://github.com/wireapp/wire-server/libs/hscim/README.md
+homepage:
+  https://github.com/wireapp/wire-server/blob/develop/libs/hscim/README.md
+
 bug-reports:        https://github.com/wireapp/wire-server/issues
 author:             Wire Swiss GmbH
 maintainer:         Wire Swiss GmbH <backend@wire.com>
@@ -21,7 +23,7 @@ extra-source-files:
 source-repository head
   type:     git
   location: https://github.com/wireapp/wire-server
-  subdir:   hscim
+  subdir:   libs/hscim
 
 library
   exposed-modules:
@@ -115,9 +117,11 @@ library
     , template-haskell
     , text
     , time
+    , utf8-string
     , uuid
     , wai
     , wai-extra
+    , wai-utilities
 
   default-language:   Haskell2010
 

libs/hscim/src/Web/Scim/Schema/Common.hs

@@ -29,6 +29,7 @@ import qualified Data.CaseInsensitive as CI
 import Data.List (nub, (\\))
 import Data.String.Conversions (cs)
 import Data.Text (Text, pack, unpack)
+import qualified Data.Text as Text
 import qualified Network.URI as Network
 
 data WithId id a = WithId
@@ -49,6 +50,12 @@ instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where
 newtype URI = URI {unURI :: Network.URI}
   deriving (Show, Eq)
 
+uriToString :: URI -> String
+uriToString = (\uri -> Network.uriToString Prelude.id uri "") . unURI
+
+uriToText :: URI -> Text
+uriToText = Text.pack . uriToString
+
 instance FromJSON URI where
   parseJSON = withText "URI" $ \uri -> case Network.parseURI (unpack uri) of
     Nothing -> fail "Invalid URI"

libs/hscim/src/Web/Scim/Schema/Error.hs

@@ -30,15 +30,21 @@ module Web.Scim.Schema.Error
     forbidden,
     serverError,
 
-    -- * Servant interoperability
+    -- * Servant/Wai interoperability
     scimToServerError,
+    scimToWaiError,
   )
 where
 
 import Control.Exception
 import Data.Aeson hiding (Error)
+import Data.ByteString.UTF8 (fromString)
 import Data.Text (Text, pack)
+import qualified Data.Text.Lazy.Encoding as LText
 import GHC.Generics (Generic)
+import qualified Network.HTTP.Types.Header as HTTP
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Network.Wai.Utilities.Error as Wai
 import Servant (ServerError (..))
 import Web.Scim.Schema.Common
 import Web.Scim.Schema.Schema
@@ -175,6 +181,16 @@ serverError details =
 ----------------------------------------------------------------------------
 -- Servant
 
+-- | Convert a SCIM 'Error' to a Servant one by encoding it with the
+-- appropriate headers.
+-- We would like to use Wire.Error.HttpError from wire-subsystems,
+-- but hscim can't depend on that.
+scimToWaiError :: ScimError -> (Wai.Error, [HTTP.Header])
+scimToWaiError err = (Wai.mkError e "scim-error" (LText.decodeUtf8 $ encode err), hs)
+  where
+    e = HTTP.Status (unStatus (status err)) (fromString $ reasonPhrase (status err))
+    hs = [("Content-Type", "application/scim+json;charset=utf-8")]
+
 -- | Convert a SCIM 'Error' to a Servant one by encoding it with the
 -- appropriate headers.
 scimToServerError :: ScimError -> ServerError

libs/types-common/src/Data/Id.hs

@@ -39,6 +39,7 @@ module Data.Id
     ScimTokenId,
     parseIdFromText,
     idToText,
+    idToString,
     idObjectSchema,
     IdObject (..),
 
@@ -263,6 +264,9 @@ parseIdFromText = maybe (Left "UUID.fromText failed") (Right . Id) . UUID.fromTe
 idToText :: Id a -> Text
 idToText = UUID.toText . toUUID
 
+idToString :: Id a -> String
+idToString = UUID.toString . toUUID
+
 instance Cql (Id a) where
   ctype = retag (ctype :: Tagged UUID ColumnType)
   toCql = toCql . toUUID

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -318,7 +318,7 @@ type UserGroupAPI =
     )
     :<|> Named
            "get-user-group"
-           ( Summary "Fetch a group accessible from the logged-in user"
+           ( Summary "Fetch a group accessible to the logged-in user"
                :> From 'V10
                :> ZLocalUser
                :> CanThrow 'UserGroupNotFound
@@ -335,7 +335,7 @@ type UserGroupAPI =
            )
     :<|> Named
            "get-user-groups"
-           ( Summary "Fetch groups accessible from the logged-in user"
+           ( Summary "Fetch groups accessible to the logged-in user"
                :> From 'V10
                :> ZLocalUser
                :> "user-groups"

libs/wire-api/src/Wire/API/Routes/Public/Spar.hs

@@ -34,6 +34,7 @@ import Servant.Server.Experimental.Auth
 import URI.ByteString qualified as URI
 import Web.Scim.Capabilities.MetaSchema as Scim.Meta
 import Web.Scim.Class.Auth as Scim.Auth
+import Web.Scim.Class.Group as Scim.Group
 import Web.Scim.Class.User as Scim.User
 import Wire.API.Deprecated (Deprecated)
 import Wire.API.Error
@@ -260,7 +261,12 @@ data ScimSite tag route = ScimSite
       route
         :- Header "Authorization" (Scim.Auth.AuthData tag)
           :> "Users"
-          :> ToServantApi (Scim.User.UserSite tag)
+          :> ToServantApi (Scim.User.UserSite tag),
+    groups ::
+      route
+        :- Header "Authorization" (Scim.Auth.AuthData tag)
+          :> "Groups"
+          :> ToServantApi (Scim.Group.GroupSite tag)
   }
   deriving (Generic)
 

libs/wire-api/src/Wire/API/User/Scim.hs

@@ -220,7 +220,7 @@ instance Scim.User.UserTypes SparTag where
   supportedSchemas = userSchemas
 
 instance Scim.Group.GroupTypes SparTag where
-  type GroupId SparTag = ()
+  type GroupId SparTag = UserGroupId
 
 instance Scim.Auth.AuthTypes SparTag where
   type AuthData SparTag = ScimToken

libs/wire-subsystems/default.nix

@@ -45,6 +45,7 @@
 , hasql-th
 , hasql-transaction
 , hex
+, hscim
 , HsOpenSSL
 , hspec
 , hspec-discover
@@ -157,6 +158,7 @@ mkDerivation {
     hasql-th
     hasql-transaction
     hex
+    hscim
     HsOpenSSL
     hspec
     html-entities
@@ -257,6 +259,7 @@ mkDerivation {
     hasql-th
     hasql-transaction
     hex
+    hscim
     HsOpenSSL
     hspec
     html-entities

libs/wire-subsystems/src/Wire/Error.hs

@@ -11,12 +11,18 @@ import Imports
 import Network.HTTP.Types
 import Network.Wai.Utilities.Error qualified as Wai
 import Network.Wai.Utilities.JSONResponse
+import Servant (ServerError)
 
 -- | Error thrown to the user
 data HttpError where
   StdError :: !Wai.Error -> HttpError
   RichError :: (ToJSON a) => !Wai.Error -> !a -> [Header] -> HttpError
 
+instance Eq HttpError where
+  StdError e == StdError e' = e == e'
+  -- RichErrors are always different because we don't know the types a, a' here
+  _ == _ = False
+
 instance Show HttpError where
   show (StdError werr) = "StdError (" <> show werr <> ")"
   show e@(RichError _ _ headers) = "RichError (json = " <> Text.unpack (Text.decodeUtf8 $ BS.toStrict $ encode e) <> ", headers = " <> show headers <> ")"
@@ -52,3 +58,9 @@ postgresUsageErrorToHttpError err = case err of
     StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
   ConnectionUsageError _ -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
   AcquisitionTimeoutUsageError -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
+
+httpErrorToServerError :: HttpError -> ServerError
+httpErrorToServerError = undefined
+
+serverErrorToHttpError :: ServerError -> HttpError
+serverErrorToHttpError = undefined

libs/wire-subsystems/src/Wire/ParseException.hs

@@ -6,6 +6,7 @@ import Network.HTTP.Types
 import Network.Wai.Utilities
 import Network.Wai.Utilities.JSONResponse
 import Wire.API.Error
+import Wire.Error
 
 -- | Failed to parse a response from another service.
 data ParseException = ParseException
@@ -23,3 +24,6 @@ instance Exception ParseException where
 
 instance APIError ParseException where
   toResponse _ = waiErrorToJSONResponse $ mkError status500 "internal-error" "Internal server error"
+
+parseExceptionToHttpError :: ParseException -> HttpError
+parseExceptionToHttpError (ParseException _ _) = StdError (mkError status500 "internal-error" mempty)

libs/wire-subsystems/src/Wire/ScimSubsystem.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Wire.ScimSubsystem where
+
+import Data.Id
+import Polysemy
+import Web.Scim.Class.Group qualified as SCG
+import Wire.API.User.Scim (SparTag)
+
+data ScimSubsystem m a where
+  ScimCreateUserGroup :: TeamId -> SCG.Group -> ScimSubsystem m (SCG.StoredGroup SparTag)
+  ScimGetUserGroup :: TeamId -> UserGroupId -> ScimSubsystem m (SCG.StoredGroup SparTag)
+  ScimUpdateUserGroup :: TeamId -> UserGroupId -> SCG.Group -> ScimSubsystem m (SCG.StoredGroup SparTag)
+
+makeSem ''ScimSubsystem