[WPB-20053] De-duplicate {brig,galley} api access effects from spar into wire-subsystems.

changelog.d/5-internal/scim-create-group

@@ -0,0 +1,4 @@
+Introducing user groups in SCIM involved a lot of refactorings:
+- some of Brig.CanonicalInterpreters has been moved (copied?) to wire-subsystems (notably stomp, aws, events)
+- Spar.CanonicalInterpreter has been extended to make use of the subsystems formerly only used by brig (somme of the interpreters are undefined because unused)
+- since that running brig code in spar wasn't always feasible: brig internal api has been extended to expose UserGroupSubsystem to spar

changelog.d/scim-create-group

@@ -0,0 +1 @@
+Create user groups with SCIM.

charts/spar/templates/configmap.yaml

@@ -29,6 +29,19 @@ data:
       tlsCa: /etc/wire/spar/cassandra/{{- (include "tlsSecretRef" . | fromYaml).key }}
       {{- end }}
 
+    elasticsearch:
+      url: {{ .elasticsearch.scheme }}://{{ .elasticsearch.host }}:{{ .elasticsearch.port }}
+      index: {{ .elasticsearch.index }}
+      insecureSkipVerifyTls: {{ .elasticsearch.insecureSkipVerifyTls }}
+      {{- if $.Values.secrets.elasticsearch }}
+      credentials: /etc/wire/spar/secrets/elasticsearch-credentials.yaml
+      {{- end }}
+      {{- if .elasticsearch.tlsCa }}
+      caCert: /etc/wire/spar/elasticsearch/ca.pem
+      {{- else if .elasticsearch.tlsCaSecretRef }}
+      caCert: /etc/wire/spar/elasticsearch/{{- .elasticsearch.tlsCaSecretRef.key }}
+      {{- end }}
+
     maxttlAuthreq: {{ .maxttlAuthreq }}
     maxttlAuthresp: {{ .maxttlAuthresp }}
 

charts/spar/values.yaml

@@ -24,6 +24,21 @@ config:
 #   tlsCaSecretRef:
 #     name: <secret-name>
 #     key: <ca-attribute>
+
+  elasticsearch:
+    scheme: http
+    host: elasticsearch-client
+    port: 9200
+    index: directory_spar
+    insecureSkipVerifyTls: false
+#   To configure custom TLS CA, please provide one of these:
+#   tlsCa: <CA in PEM format (can be self-signed)>
+#
+#   Or refer to an existing secret (containing the CA):
+#   tlsCaSecretRef:
+#     name: <secret-name>
+#     key: <ca-attribute>
+
   richInfoLimit: 5000
   maxScimTokens: 0
   logLevel: Info

integration/test/API/Spar.hs

@@ -91,6 +91,12 @@ 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)
+
 -- | 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,64 @@ testSparCreateScimTokenWithName = do
   assoc <- token %. "id"
   token %. "name" `shouldMatch` Just assoc
 
+----------------------------------------------------------------------
+-- scim group stuff
+
+testSparScimCreateUserGroup :: (HasCallStack) => App ()
+testSparScimCreateUserGroup = do
+  (owner, tid, _) <- createTeam OwnDomain 1
+  tok <- createScimTokenV6 owner def >>= \resp -> resp.json %. "token" >>= asString
+
+  let -- this function looks messy and may be overdoing it in the head
+      -- of the debate with the compiler.  its only purpose is to make
+      -- a team member that satisfies all conditions for being added
+      -- to a scim group.
+      mkMemberCandidate :: App String
+      mkMemberCandidate = do
+        assertSuccess =<< setTeamFeatureStatus owner tid "validateSAMLemails" "disabled"
+        assertSuccess =<< setTeamFeatureStatus owner tid "sso" "enabled"
+        void $ registerTestIdPWithMetaWithPrivateCreds owner
+
+        scimUserEmail <- randomEmail
+        scimUser <- randomScimUserWith def {mkExternalId = pure scimUserEmail}
+        uid <- createScimUser owner tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString
+        quid <- do
+          dom <- make OwnDomain >>= asString
+          pure $ object ["domain" .= dom, "id" .= uid]
+
+        getScimUser OwnDomain tok uid `bindResponse` \res -> do
+          res.status `shouldMatchInt` 200
+          res.json %. "id" `shouldMatch` uid
+
+        registerInvitedUser OwnDomain tid scimUserEmail
+
+        getSelf quid `bindResponse` \res -> do
+          res.status `shouldMatchInt` 200
+          res.json %. "id" `shouldMatch` uid
+          res.json %. "team" `shouldMatch` tid
+          res.json %. "status" `shouldMatch` "active"
+          res.json %. "managed_by" `shouldMatch` "scim"
+
+        pure uid
+
+  scimUserId <- mkMemberCandidate
+  let scimUserGroup =
+        object
+          [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"],
+            "displayName" .= "ze groop",
+            "members"
+              .= [ object
+                     [ "type" .= "User",
+                       "$ref" .= "...", -- something like
+                       -- "https://example.org/v2/scim/User/ea2e4bf0-aa5e-11f0-96ad-e776a606779b"?
+                       -- but since we're just receiving this it's ok
+                       -- to ignore.
+                       "value" .= scimUserId
+                     ]
+                 ]
+          ]
+  createScimUserGroup OwnDomain tok scimUserGroup >>= assertSuccess
+
 ----------------------------------------------------------------------
 -- saml stuff
 

libs/hscim/default.nix

@@ -41,9 +41,11 @@
 , template-haskell
 , text
 , time
+, utf8-string
 , uuid
 , wai
 , wai-extra
+, wai-utilities
 , warp
 }:
 mkDerivation {
@@ -85,9 +87,11 @@ mkDerivation {
     template-haskell
     text
     time
+    utf8-string
     uuid
     wai
     wai-extra
+    wai-utilities
   ];
   executableHaskellDepends = [
     base

libs/hscim/hscim.cabal

@@ -115,9 +115,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/HavePendingInvitations.hs

@@ -1,5 +1,8 @@
 module Data.HavePendingInvitations where
 
+import Data.Aeson (FromJSON, ToJSON)
+import Data.OpenApi qualified as S
+import Data.Schema
 import Imports
 import Wire.Arbitrary
 
@@ -8,6 +11,10 @@ data HavePendingInvitations
   | NoPendingInvitations
   deriving (Eq, Show, Ord, Generic)
   deriving (Arbitrary) via GenericUniform HavePendingInvitations
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema HavePendingInvitations
+
+instance ToSchema HavePendingInvitations where
+  schema = enum @Bool "HavePendingInvitations" $ mconcat [element True WithPendingInvitations, element False NoPendingInvitations]
 
 fromBool :: Bool -> HavePendingInvitations
 fromBool True = WithPendingInvitations

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/Internal/Brig.hs

@@ -35,6 +35,8 @@ module Wire.API.Routes.Internal.Brig
     PutAccountConferenceCallingConfig,
     DeleteAccountConferenceCallingConfig,
     GetRichInfoMultiResponse (..),
+    GetBy (..),
+    CreateGroupFullRequest (..),
     swaggerDoc,
     module Wire.API.Routes.Internal.Brig.EJPD,
     FoundInvitationCode (..),
@@ -43,16 +45,18 @@ module Wire.API.Routes.Internal.Brig
 where
 
 import Control.Lens ((.~), (?~))
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON, Value (Null))
 import Data.Code qualified as Code
 import Data.CommaSeparatedList
+import Data.Default (Default (..))
 import Data.Domain (Domain)
 import Data.Handle (Handle)
+import Data.HavePendingInvitations (HavePendingInvitations (..))
 import Data.Id as Id
 import Data.Misc (PlainTextPassword8)
 import Data.OpenApi (HasInfo (info), HasTitle (title), OpenApi)
 import Data.OpenApi qualified as S
-import Data.Qualified (Qualified)
+import Data.Qualified (Qualified, qualifiedSchema)
 import Data.Schema hiding (swaggerDoc)
 import Data.Text qualified as Text
 import GHC.TypeLits
@@ -91,6 +95,62 @@ import Wire.API.User.Auth.ReAuth
 import Wire.API.User.Auth.Sso
 import Wire.API.User.Client
 import Wire.API.User.RichInfo
+import Wire.API.UserGroup (NewUserGroup, UserGroup)
+import Wire.Arbitrary (Arbitrary, GenericUniform (..))
+
+-- | Parameters for getting user accounts by various criteria
+data GetBy = GetBy
+  { includePendingInvitations :: HavePendingInvitations,
+    getByUserId :: [UserId],
+    getByHandle :: [Handle]
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving (Arbitrary) via GenericUniform GetBy
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema GetBy
+
+instance Default GetBy where
+  def =
+    GetBy
+      { includePendingInvitations = NoPendingInvitations,
+        getByUserId = [],
+        getByHandle = []
+      }
+
+instance ToSchema GetBy where
+  schema =
+    object "GetBy" $
+      GetBy
+        <$> (.includePendingInvitations) .= field "include_pending_invitations" schema
+        <*> (.getByUserId) .= field "ids" (array schema)
+        <*> (.getByHandle) .= field "handles" (array schema)
+
+instance ToSchema (Qualified GetBy) where
+  schema = qualifiedSchema "GetBy" "get_by" schema
+
+deriving via (Schema (Qualified GetBy)) instance FromJSON (Qualified GetBy)
+
+deriving via (Schema (Qualified GetBy)) instance ToJSON (Qualified GetBy)
+
+deriving via (Schema (Qualified GetBy)) instance S.ToSchema (Qualified GetBy)
+
+-- | Request type for creating user groups with full control
+data CreateGroupFullRequest = CreateGroupFullRequest
+  { managedBy :: ManagedBy,
+    teamId :: TeamId,
+    creatorUserId :: Maybe UserId,
+    newGroup :: NewUserGroup
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema CreateGroupFullRequest
+
+instance ToSchema CreateGroupFullRequest where
+  schema =
+    object "CreateGroupFullRequest" $
+      CreateGroupFullRequest
+        <$> (.managedBy) .= field "managed_by" schema
+        <*> (.teamId) .= field "team_id" schema
+        <*> (.creatorUserId) .= optField "creator_user_id" (maybeWithDefault Null schema)
+        <*> (.newGroup) .= field "new_group" schema
 
 type EJPDRequest =
   Named
@@ -163,6 +223,26 @@ type GetAllConnections =
     :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2
     :> Post '[Servant.JSON] [ConnectionStatusV2]
 
+type GetAccountsByInternal =
+  Named
+    "i-get-accounts-by"
+    ( Summary "Get user accounts by various criteria (internal)"
+        :> "users"
+        :> "accounts-by"
+        :> ReqBody '[Servant.JSON] GetBy
+        :> Post '[Servant.JSON] [User]
+    )
+
+type CreateGroupFullInternal =
+  Named
+    "i-create-group-full"
+    ( Summary "Create user group with full control (internal)"
+        :> "user-groups"
+        :> "full"
+        :> ReqBody '[Servant.JSON] CreateGroupFullRequest
+        :> Post '[Servant.JSON] UserGroup
+    )
+
 type AccountAPI =
   Named "get-account-conference-calling-config" GetAccountConferenceCallingConfig
     :<|> Named "i-put-account-conference-calling-config" PutAccountConferenceCallingConfig
@@ -469,6 +549,8 @@ type AccountAPI =
                :> Capture "uid" UserId
                :> Delete '[Servant.JSON] NoContent
            )
+    :<|> GetAccountsByInternal
+    :<|> CreateGroupFullInternal
 
 -- | The missing ref is implicit by the capture
 data NewKeyPackageRef = NewKeyPackageRef