diff --git a/changelog.d/5-internal/pr-3216 b/changelog.d/5-internal/pr-3216 new file mode 100644 index 00000000000..9c6f738390d --- /dev/null +++ b/changelog.d/5-internal/pr-3216 @@ -0,0 +1 @@ +Integration tests for backoffice/stern diff --git a/charts/backoffice/templates/tests/configmap.yaml b/charts/backoffice/templates/tests/configmap.yaml new file mode 100644 index 00000000000..a20785b354e --- /dev/null +++ b/charts/backoffice/templates/tests/configmap.yaml @@ -0,0 +1,20 @@ +apiVersion: v1 +kind: ConfigMap +metadata: + name: "stern-integration" + annotations: + "helm.sh/hook": post-install + "helm.sh/hook-delete-policy": before-hook-creation +data: + integration.yaml: | + brig: + host: brig + port: 8080 + + galley: + host: galley + port: 8080 + + stern: + host: backoffice + port: 8080 diff --git a/charts/backoffice/templates/tests/stern-integration.yaml b/charts/backoffice/templates/tests/stern-integration.yaml new file mode 100644 index 00000000000..e8c968ee645 --- /dev/null +++ b/charts/backoffice/templates/tests/stern-integration.yaml @@ -0,0 +1,25 @@ +apiVersion: v1 +kind: Pod +metadata: + name: "{{ .Release.Name }}-stern-integration" + annotations: + "helm.sh/hook": test + labels: + app: stern-integration + release: {{ .Release.Name }} +spec: + volumes: + - name: "stern-integration" + configMap: + name: "stern-integration" + containers: + - name: integration + image: "{{ .Values.image.repository }}-integration:{{ .Values.image.tag }}" + volumeMounts: + - name: "stern-integration" + mountPath: "/etc/wire/integration" + resources: + requests: + memory: "128Mi" + cpu: "1" + restartPolicy: Never diff --git a/hack/bin/cabal-run-integration.sh b/hack/bin/cabal-run-integration.sh index 57cf9a28742..b1c0043aa50 100755 --- a/hack/bin/cabal-run-integration.sh +++ b/hack/bin/cabal-run-integration.sh @@ -61,6 +61,7 @@ run_all_integration_tests() { run_integration_tests "$package" fi done + run_integration_tests "stern" } if [ "$package" == "all" ]; then diff --git a/hack/bin/integration-test.sh b/hack/bin/integration-test.sh index 56848173e60..a354d636dc6 100755 --- a/hack/bin/integration-test.sh +++ b/hack/bin/integration-test.sh @@ -11,7 +11,7 @@ UPLOAD_LOGS=${UPLOAD_LOGS:-0} echo "Running integration tests on wire-server with parallelism=${HELM_PARALLELISM} ..." CHART=wire-server -tests=(galley cargohold gundeck federator spar brig) +tests=(stern galley cargohold gundeck federator spar brig) cleanup() { if (( CLEANUP_LOCAL_FILES > 0 )); then diff --git a/nix/wire-server.nix b/nix/wire-server.nix index c2faec00fde..686e3da7739 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -79,7 +79,7 @@ let gundeck = [ "gundeck" "gundeck-integration" "gundeck-schema" ]; proxy = [ "proxy" ]; spar = [ "spar" "spar-integration" "spar-schema" "spar-migrate-data" ]; - stern = [ "stern" ]; + stern = [ "stern" "stern-integration"]; billing-team-member-backfill = [ "billing-team-member-backfill" ]; inconsistencies = [ "inconsistencies" ]; diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 894be93283c..a48f9e4a26b 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -4,51 +4,116 @@ # dependencies are added or removed. { mkDerivation , aeson +, aeson-qq +, amazonka +, amazonka-sqs +, async , base +, base64-bytestring , bilge +, binary , brig-types , bytestring , bytestring-conversion +, call-stack +, case-insensitive +, cassandra-util +, cassava +, cereal +, comonad , containers +, cookie +, cryptonite +, currency-codes , data-default +, data-timeout +, directory , errors , exceptions , extended +, extra +, federator +, filepath +, galley , galley-types , gitignoreSource , gundeck-types +, hex +, HsOpenSSL +, HsOpenSSL-x509-system +, hspec , http-client +, http-client-openssl +, http-client-tls +, http-media , http-types , imports +, kan-extensions , lens +, lens-aeson , lib +, memory , metrics-wai , mtl +, network +, network-uri +, optparse-applicative +, pem +, process +, proto-lens +, protobuf +, QuickCheck +, quickcheck-instances +, random +, raw-strings-qq , retry +, safe +, saml2-web-sso , schema-profunctor , servant +, servant-client +, servant-client-core , servant-server , servant-swagger , servant-swagger-ui +, singletons +, singletons-th +, sop-core , split +, ssl-util +, streaming-commons , string-conversions , swagger2 +, tagged , tasty +, tasty-cannon , tasty-hunit +, temporary , text +, time , tinylog +, tls , transformers , types-common +, types-common-aws +, types-common-journal +, unix , unliftio , unordered-containers +, uri-bytestring , uuid +, uuid-types +, vector , wai , wai-extra , wai-predicates , wai-routing , wai-utilities , warp +, warp-tls , wire-api +, wire-api-federation +, wire-message-proto-lens , yaml }: mkDerivation { @@ -103,13 +168,112 @@ mkDerivation { yaml ]; executableHaskellDepends = [ + aeson + aeson-qq + amazonka + amazonka-sqs + async base + base64-bytestring + bilge + binary + brig-types + bytestring + bytestring-conversion + call-stack + case-insensitive + cassandra-util + cassava + cereal + comonad + containers + cookie + cryptonite + currency-codes + data-default + data-timeout + directory + errors + exceptions extended + extra + federator + filepath + galley + galley-types + gundeck-types + hex + HsOpenSSL + HsOpenSSL-x509-system + hspec + http-client + http-client-openssl + http-client-tls + http-media + http-types imports + kan-extensions + lens + lens-aeson + memory + metrics-wai + mtl + network + network-uri + optparse-applicative + pem + process + proto-lens + protobuf + QuickCheck + quickcheck-instances + random + raw-strings-qq + retry + safe + saml2-web-sso + schema-profunctor + servant + servant-client + servant-client-core + servant-server + servant-swagger + singletons + singletons-th + sop-core + ssl-util + streaming-commons + string-conversions + tagged + tasty + tasty-cannon + tasty-hunit + temporary + text + time + tinylog + tls + transformers types-common + types-common-aws + types-common-journal + unix unliftio + unordered-containers + uri-bytestring + uuid + uuid-types + vector + wai + wai-extra + wai-utilities + warp + warp-tls + wire-api + wire-api-federation + wire-message-proto-lens + yaml ]; testHaskellDepends = [ base tasty tasty-hunit wire-api ]; license = lib.licenses.agpl3Only; - mainProgram = "stern"; } diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 97be2937f23..d948877871c 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -215,8 +215,8 @@ searchOnBehalf revokeIdentity :: Maybe Email -> Maybe Phone -> Handler NoContent revokeIdentity mbe mbp = NoContent <$ (Intra.revokeIdentity =<< doubleMaybeToEither "email, phone" mbe mbp) -changeEmail :: UserId -> Maybe Bool -> EmailUpdate -> Handler NoContent -changeEmail = undefined -- uid validate upd = NoContent <$ Intra.changeEmail uid (fromMaybe False upd) validate +changeEmail :: UserId -> EmailUpdate -> Handler NoContent +changeEmail uid upd = NoContent <$ Intra.changeEmail uid upd changePhone :: UserId -> PhoneUpdate -> Handler NoContent changePhone uid upd = NoContent <$ Intra.changePhone uid upd diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 525df34f9d8..e0e6c3a4dfc 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -117,6 +117,7 @@ type SternAPI = :<|> Named "get-user-connections" ( Summary "Displays user's connections" + :> Description "[Deprecated] This is using API version V1 and will be removed in the future." :> "users" :> Capture "uid" UserId :> "connections" @@ -162,7 +163,6 @@ type SternAPI = :> "users" :> Capture "uid" UserId :> "email" - :> QueryParam' [Optional, Strict, Description "If set to true, a validation email will be sent to the new email address"] "validate" Bool :> Servant.ReqBody '[JSON] EmailUpdate :> Put '[JSON] NoContent ) diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 4481c96e731..bff40cb381d 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -164,6 +164,7 @@ putUserStatus status uid = do where payload = AccountStatusUpdate status +-- This won't work anymore once API version V1 is not supported anymore getUserConnections :: UserId -> Handler [UserConnection] getUserConnections uid = do info $ msg "Getting user connections" @@ -186,7 +187,7 @@ getUserConnections uid = do b ( method GET . header "Z-User" (toByteString' uid) - . versionedPath "/connections" + . Bilge.paths ["v1", "connections"] . queryItem "size" (toByteString' batchSize) . maybe id (queryItem "start" . toByteString') start . expect2xx @@ -284,7 +285,7 @@ getContacts u q s = do "brig" b ( method GET - . versionedPath "/search/contacts" + . versionedPath "search/contacts" . header "Z-User" (toByteString' u) . queryItem "q" (toByteString' q) . queryItem "size" (toByteString' s) @@ -361,8 +362,8 @@ deleteBindingTeamForce tid = do . expect2xx ) -changeEmail :: UserId -> EmailUpdate -> Bool -> Handler () -changeEmail u upd validate = do +changeEmail :: UserId -> EmailUpdate -> Handler () +changeEmail u upd = do info $ msg "Updating email address" b <- view brig void . catchRpcErrors $ @@ -371,7 +372,6 @@ changeEmail u upd validate = do b ( method PUT . Bilge.path "i/self/email" - . (if validate then queryItem "validate" "true" else id) . header "Z-User" (toByteString' u) . header "Z-Connection" (toByteString' "") . lbytes (encode upd) diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index de7813ce1d3..c12a3f0d638 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -196,3 +196,171 @@ test-suite stern-tests , tasty , tasty-hunit , wire-api + +executable stern-integration + main-is: Main.hs + + -- cabal-fmt: expand test/integration + other-modules: + API + Main + TestSetup + Util + + hs-source-dirs: test/integration + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -threaded -with-rtsopts=-N -Wredundant-constraints + + build-depends: + aeson + , aeson-qq + , amazonka + , amazonka-sqs + , async + , base + , base64-bytestring + , bilge + , binary + , brig-types + , bytestring + , bytestring-conversion + , call-stack + , case-insensitive + , cassandra-util + , cassava + , cereal + , comonad + , containers + , cookie + , cryptonite + , currency-codes + , data-default + , data-timeout + , directory + , errors + , exceptions + , extended + , extra >=1.3 + , federator + , filepath + , galley + , galley-types + , gundeck-types + , hex + , HsOpenSSL + , HsOpenSSL-x509-system + , hspec + , http-client + , http-client-openssl + , http-client-tls + , http-media + , http-types + , imports + , kan-extensions + , lens + , lens-aeson + , memory + , metrics-wai + , mtl + , network + , network-uri + , optparse-applicative + , pem + , process + , proto-lens + , protobuf + , QuickCheck + , quickcheck-instances + , random + , raw-strings-qq >=1.0 + , retry + , safe >=0.3 + , saml2-web-sso >=0.19 + , schema-profunctor + , servant + , servant-client + , servant-client-core + , servant-server + , servant-swagger + , singletons + , singletons-th + , sop-core + , ssl-util + , stern + , streaming-commons + , string-conversions + , tagged + , tasty >=0.8 + , tasty-cannon >=0.3.2 + , tasty-hunit >=0.9 + , temporary + , text + , time + , tinylog + , tls >=1.3.8 + , transformers + , types-common + , types-common-aws + , types-common-journal + , unix + , unliftio + , unordered-containers + , uri-bytestring + , uuid + , uuid-types + , vector + , wai + , wai-extra + , wai-utilities + , warp + , warp-tls >=3.2 + , wire-api + , wire-api-federation + , wire-message-proto-lens + , yaml + + default-language: Haskell2010 diff --git a/tools/stern/stern.example.yaml b/tools/stern/stern.example.yaml deleted file mode 100644 index f9f926e6a6d..00000000000 --- a/tools/stern/stern.example.yaml +++ /dev/null @@ -1,28 +0,0 @@ -stern: - host: 127.0.0.1 - port: 8091 - -brig: - host: 127.0.0.1 - port: 8082 - -galley: - host: 127.0.0.1 - port: 8085 - -gundeck: - host: 127.0.0.1 - port: 8086 - -# Both ibis and galeb should be made optional for -# installations where these services are not available -galeb: - host: 127.0.0.1 - port: 8089 - -ibis: - host: 127.0.0.1 - port: 8090 - -logLevel: Info -logNetStrings: false diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs new file mode 100644 index 00000000000..1390c208e9b --- /dev/null +++ b/tools/stern/test/integration/API.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 API where -- todo(leif): export only test + +import Bilge +import Brig.Types.Intra +import Control.Applicative +import Control.Lens hiding ((.=)) +import Data.ByteString.Conversion +import Data.Handle +import Data.Id +import Data.Schema +import qualified Data.Set as Set +import Data.String.Conversions +import GHC.TypeLits +import Imports +import Stern.API.Routes (UserConnectionGroups (..)) +import Stern.Types +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Util +import Wire.API.Routes.Internal.Brig.Connection +import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD +import Wire.API.Team.Feature +import qualified Wire.API.Team.Feature as Public +import Wire.API.Team.SearchVisibility +import Wire.API.User +import Wire.API.User.Search + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API tests" + [ test s "GET /i/status" testGetStatus, + test s "POST /users/:uid/suspend" testSuspendUser, + test s "POST /users/:uid/unsuspend" testUnsuspendUser, + test s "GET /users/by-email" testGetUsersByEmail, + test s "GET /users/by-phone" testGetUsersByPhone, + test s "GET /users/by-ids" testGetUsersByIds, + test s "GET /users/by-handles" testGetUsersByHandles, + test s "GET /users/:id/connections" testGetConnections, + test s "GET /users/connections?ids=..." testGetConnectionsByIds, + test s "GET /users/:uid/search" testSearchUsers, + test s "POST /users/revoke-identity?email=..." testRevokeIdentity, + test s "PUT /users/:uid/email" testPutEmail, + test s "PUT /users/:uid/phone" testPutPhone, + test s "DELETE /users/:uid" testDeleteUser, + test s "PUT /teams/:tid/suspend" testSuspendTeam, + test s "PUT /teams/:tid/unsuspend" testUnsuspendTeam, + test s "DELETE /teams/:tid" testDeleteTeam, + test s "GET /ejpd-info" testEjpdInfo, + test s "HEAD /users/blacklist" testUserBlacklistHead, + test s "POST /users/blacklist" testPostUserBlacklist, + test s "DELETE /users/blacklist" testDeleteUserBlacklist, + test s "GET /teams" testGetTeamInfoByMemberEmail, + test s "GET /teams/:tid/admins" testGetTeamAdminInfo, + test s "GET /teams/:tid/features/legalhold" testGetLegalholdConfig, + test s "PUT /teams/:tid/features/legalhold" testPutLegalholdConfig, + test s "GET /teams/:tid/features/sso" testGetSSOConfig, + test s "PUT /teams/:tid/features/sso" testPutSSOConfig, + test s "PUT /teams/:tid/features/search-visibility-available" testPutSearchVisibilityAvailableConfig, + test s "PUT /teams/:tid/features/validate-saml-emails" testPutValidateSAMLEmailsConfig, + test s "PUT /teams/:tid/features/digital-signatures" testPutDigitalSignaturesConfig, + test s "PUT /teams/:tid/features/file-sharing" testPutFileSharingConfig, + test s "PUT /teams/:tid/features/conference-calling" testPutConferenceCallingConfig, + test s "PUT /teams/:tid/features/:feature" testPutFeatureConfig, + test s "GET /teams/:tid/search-visibility" testGetSearchVisibility, + test s "PUT /teams/:tid/search-visibility" testPutSearchVisibility, + test s "GET /teams/:tid/invoice/:inr" testGetTeamInvoice, + test s "GET /teams/:tid/billing" testGetTeamBillingInfo, + test s "PUT /teams/:tid/billing" testPutTeamBillingInfo, + test s "POST /teams/:tid/billing" testPostTeamBillingInfo, + test s "GET /i/consent" testGetConsentLog, + test s "GET /teams/:id" testGetTeamInfo + ] + +testPutPhone :: TestM () +testPutPhone = pure () + +testDeleteUser :: TestM () +testDeleteUser = pure () + +testSuspendTeam :: TestM () +testSuspendTeam = pure () + +testUnsuspendTeam :: TestM () +testUnsuspendTeam = pure () + +testDeleteTeam :: TestM () +testDeleteTeam = pure () + +testEjpdInfo :: TestM () +testEjpdInfo = pure () + +testUserBlacklistHead :: TestM () +testUserBlacklistHead = pure () + +testPostUserBlacklist :: TestM () +testPostUserBlacklist = pure () + +testDeleteUserBlacklist :: TestM () +testDeleteUserBlacklist = pure () + +testGetTeamInfoByMemberEmail :: TestM () +testGetTeamInfoByMemberEmail = pure () + +testGetTeamAdminInfo :: TestM () +testGetTeamAdminInfo = pure () + +testGetLegalholdConfig :: TestM () +testGetLegalholdConfig = pure () + +testPutLegalholdConfig :: TestM () +testPutLegalholdConfig = pure () + +testGetSSOConfig :: TestM () +testGetSSOConfig = pure () + +testPutSSOConfig :: TestM () +testPutSSOConfig = pure () + +testPutSearchVisibilityAvailableConfig :: TestM () +testPutSearchVisibilityAvailableConfig = pure () + +testPutValidateSAMLEmailsConfig :: TestM () +testPutValidateSAMLEmailsConfig = pure () + +testPutDigitalSignaturesConfig :: TestM () +testPutDigitalSignaturesConfig = pure () + +testPutFileSharingConfig :: TestM () +testPutFileSharingConfig = pure () + +testPutConferenceCallingConfig :: TestM () +testPutConferenceCallingConfig = pure () + +testPutFeatureConfig :: TestM () +testPutFeatureConfig = pure () + +testGetSearchVisibility :: TestM () +testGetSearchVisibility = pure () + +testPutSearchVisibility :: TestM () +testPutSearchVisibility = pure () + +testGetTeamInvoice :: TestM () +testGetTeamInvoice = pure () + +testGetTeamBillingInfo :: TestM () +testGetTeamBillingInfo = pure () + +testPutTeamBillingInfo :: TestM () +testPutTeamBillingInfo = pure () + +testPostTeamBillingInfo :: TestM () +testPostTeamBillingInfo = pure () + +testGetConsentLog :: TestM () +testGetConsentLog = pure () + +testGetConnectionsByIds :: TestM () +testGetConnectionsByIds = do + uids <- sequence [randomUser, randomUser, randomUser] + connections <- getConnectionsByUserIds uids + liftIO $ connections @?= [] + +testGetConnections :: TestM () +testGetConnections = do + uid <- randomUser + connections <- getConnections uid + liftIO $ connections @?= UserConnectionGroups 0 0 0 0 0 0 0 + +testGetUsersByHandles :: TestM () +testGetUsersByHandles = do + uid <- randomUser + h <- randomHandle + void $ setHandle uid h + [ua] <- getUsersByHandles h + liftIO $ ua.accountUser.userId @?= uid + +testGetUsersByPhone :: TestM () +testGetUsersByPhone = do + (uid, phone) <- randomPhoneUser + [ua] <- getUsersByPhone phone + liftIO $ ua.accountUser.userId @?= uid + +testGetUsersByEmail :: TestM () +testGetUsersByEmail = do + (uid, email) <- randomEmailUser + [ua] <- getUsersByEmail email + liftIO $ ua.accountUser.userId @?= uid + +testUnsuspendUser :: TestM () +testUnsuspendUser = do + uid <- randomUser + void $ postSupendUser uid + do + [ua] <- getUsersByIds [uid] + liftIO $ ua.accountStatus @?= Suspended + void $ postUnsuspendUser uid + do + [ua] <- getUsersByIds [uid] + liftIO $ ua.accountStatus @?= Active + +testSuspendUser :: TestM () +testSuspendUser = do + uid <- randomUser + void $ postSupendUser uid + [ua] <- getUsersByIds [uid] + liftIO $ ua.accountStatus @?= Suspended + +testGetStatus :: TestM () +testGetStatus = do + r <- getStatus + liftIO $ do + statusCode r @?= 200 + +testGetUsersByIds :: TestM () +testGetUsersByIds = do + uid1 <- randomUser + uid2 <- randomUser + uas <- getUsersByIds [uid1, uid2] + liftIO $ do + length uas @?= 2 + Set.fromList ((.accountUser.userId) <$> uas) @?= Set.fromList [uid1, uid2] + +testGetTeamInfo :: TestM () +testGetTeamInfo = do + (_, tid, _) <- createBindingTeamWithNMembers 10 + info <- getTeamInfo tid + liftIO $ length info.tiMembers @?= 11 + +testSearchUsers :: TestM () +testSearchUsers = do + uid <- randomUser + result <- searchUsers uid + liftIO $ do + result.searchFound @?= 0 + +testRevokeIdentity :: TestM () +testRevokeIdentity = do + (_, (email, phone)) <- randomEmailPhoneUser + do + [ua] <- getUsersByEmail email + liftIO $ do + ua.accountStatus @?= Active + isJust ua.accountUser.userIdentity @?= True + void $ revokeIdentity (Left email) + void $ revokeIdentity (Right phone) + do + [ua] <- getUsersByEmail email + liftIO $ do + ua.accountStatus @?= Active + isJust ua.accountUser.userIdentity @?= False + +testPutEmail :: TestM () +testPutEmail = do + uid <- randomUser + email <- randomEmail + -- If the user has a pending email validation, the validation email will be resent. But we simply test that this call returns 200 + putEmail uid (EmailUpdate email) + +------------------------------------------------------------------------------- +-- API Calls + +instance (ToByteString a) => ToByteString [a] where + builder xs = builder $ cs @String @ByteString $ intercalate "," (cs . toByteString' <$> xs) + +getConnectionsByUserIds :: [UserId] -> TestM [ConnectionStatus] +getConnectionsByUserIds uids = do + s <- view tsStern + r <- get (s . paths ["users", "connections"] . queryItem "ids" (toByteString' uids) . expect2xx) + pure $ responseJsonUnsafe r + +getConnections :: UserId -> TestM UserConnectionGroups +getConnections uid = do + s <- view tsStern + r <- get (s . paths ["users", toByteString' uid, "connections"] . expect2xx) + pure $ responseJsonUnsafe r + +getUsersByHandles :: Text -> TestM [UserAccount] +getUsersByHandles h = do + stern <- view tsStern + r <- get (stern . paths ["users", "by-handles"] . queryItem "handles" (cs h) . expect2xx) + pure $ responseJsonUnsafe r + +getUsersByPhone :: Phone -> TestM [UserAccount] +getUsersByPhone phone = do + stern <- view tsStern + r <- get (stern . paths ["users", "by-phone"] . queryItem "phone" (toByteString' phone) . expect2xx) + pure $ responseJsonUnsafe r + +getUsersByEmail :: Email -> TestM [UserAccount] +getUsersByEmail email = do + stern <- view tsStern + r <- get (stern . paths ["users", "by-email"] . queryItem "email" (toByteString' email) . expect2xx) + pure $ responseJsonUnsafe r + +postUnsuspendUser :: UserId -> TestM ResponseLBS +postUnsuspendUser uid = do + stern <- view tsStern + post (stern . paths ["users", toByteString' uid, "unsuspend"] . expect2xx) + +postSupendUser :: UserId -> TestM ResponseLBS +postSupendUser uid = do + stern <- view tsStern + post (stern . paths ["users", toByteString' uid, "suspend"] . expect2xx) + +getStatus :: TestM ResponseLBS +getStatus = do + stern <- view tsStern + get (stern . paths ["i", "status"] . expect2xx) + +getUsersByIds :: [UserId] -> TestM [UserAccount] +getUsersByIds uids = do + stern <- view tsStern + r <- get (stern . paths ["users", "by-ids"] . queryItem "ids" (toByteString' uids) . expect2xx) + pure $ responseJsonUnsafe r + +getTeamInfo :: TeamId -> TestM TeamInfo +getTeamInfo tid = do + stern <- view tsStern + r <- get (stern . paths ["teams", toByteString' tid] . expect2xx) + pure $ responseJsonUnsafe r + +searchUsers :: UserId -> TestM (SearchResult Contact) +searchUsers uid = do + s <- view tsStern + r <- get (s . paths ["users", toByteString' uid, "search"] . expect2xx) + pure $ responseJsonUnsafe r + +revokeIdentity :: Either Email Phone -> TestM () +revokeIdentity emailOrPhone = do + s <- view tsStern + void $ post (s . paths ["users", "revoke-identity"] . mkQueryParam emailOrPhone . expect2xx) + +mkQueryParam :: Either Email Phone -> Request -> Request +mkQueryParam = \case + Left email -> queryItem "email" (toByteString' email) + Right phone -> queryItem "phone" (toByteString' phone) + +putEmail :: UserId -> EmailUpdate -> TestM () +putEmail uid emailUpdate = do + s <- view tsStern + void $ put (s . paths ["users", toByteString' uid, "email"] . json emailUpdate . expect2xx) + +putPhone :: UserId -> PhoneUpdate -> TestM () +putPhone uid phoneUpdate = do + s <- view tsStern + void $ put (s . paths ["users", toByteString' uid, "phone"] . json phoneUpdate . expect2xx) + +deleteUser :: UserId -> Either Email Phone -> TestM () +deleteUser uid emailOrPhone = do + s <- view tsStern + void $ delete (s . paths ["users", toByteString' uid] . mkQueryParam emailOrPhone . expect2xx) + +suspendTeam :: TeamId -> TestM () +suspendTeam tid = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "suspend"] . expect2xx) + +unsuspendTeam :: TeamId -> TestM () +unsuspendTeam tid = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "unsuspend"] . expect2xx) + +deleteTeam :: TeamId -> Bool -> Email -> TestM () +deleteTeam tid force email = do + s <- view tsStern + void $ delete (s . paths ["teams", toByteString' tid] . queryItem "force" (toByteString' force) . queryItem "email" (toByteString' email) . expect2xx) + +ejpdInfo :: Bool -> [Handle] -> TestM EJPD.EJPDResponseBody +ejpdInfo includeContacts handles = do + s <- view tsStern + r <- get (s . paths ["ejpd-info"] . queryItem "include_contacts" (toByteString' includeContacts) . queryItem "handles" (toByteString' handles) . expect2xx) + pure $ responseJsonUnsafe r + +userBlacklistHead :: Either Email Phone -> TestM () +userBlacklistHead emailOrPhone = do + s <- view tsStern + void $ Bilge.head (s . paths ["users", "blacklist"] . mkQueryParam emailOrPhone . expect2xx) + +postUserBlacklist :: Either Email Phone -> TestM () +postUserBlacklist emailOrPhone = do + s <- view tsStern + void $ post (s . paths ["users", "blacklist"] . mkQueryParam emailOrPhone . expect2xx) + +deleteUserBlacklist :: Either Email Phone -> TestM () +deleteUserBlacklist emailOrPhone = do + s <- view tsStern + void $ delete (s . paths ["users", "blacklist"] . mkQueryParam emailOrPhone . expect2xx) + +getTeamInfoByMemberEmail :: Email -> TestM TeamInfo +getTeamInfoByMemberEmail email = do + s <- view tsStern + r <- get (s . paths ["teams"] . queryItem "email" (toByteString' email) . expect2xx) + pure $ responseJsonUnsafe r + +getTeamAdminInfo :: TeamId -> TestM TeamAdminInfo +getTeamAdminInfo tid = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "admins"] . expect2xx) + pure $ responseJsonUnsafe r + +getFeatureConfig :: + forall cfg. + ( KnownSymbol (FeatureSymbol cfg), + ToSchema cfg, + Typeable cfg, + IsFeatureConfig cfg + ) => + TeamId -> + TestM (WithStatus cfg) +getFeatureConfig tid = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] . expect2xx) + pure $ responseJsonUnsafe r + +putLegalholdConfig :: TeamId -> FeatureStatus -> TestM () +putLegalholdConfig tid status = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "legalhold"] . queryItem "status" (toByteString' status) . expect2xx) + +getSSOConfig :: TeamId -> TestM (WithStatus SSOConfig) +getSSOConfig tid = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "features", "sso"] . expect2xx) + pure $ responseJsonUnsafe r + +putSSOConfig :: TeamId -> FeatureStatus -> TestM () +putSSOConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "sso"] . queryItem "status" (toByteString' cfg) . expect2xx) + +putSearchVisibilityAvailableConfig :: TeamId -> FeatureStatus -> TestM () +putSearchVisibilityAvailableConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "search-visibility-available"] . queryItem "status" (toByteString' cfg) . expect2xx) + +putValidateSAMLEmailsConfig :: TeamId -> FeatureStatus -> TestM () +putValidateSAMLEmailsConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "validate-saml-emails"] . queryItem "status" (toByteString' cfg) . expect2xx) + +putDigitalSignaturesConfig :: TeamId -> FeatureStatus -> TestM () +putDigitalSignaturesConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "digital-signatures"] . queryItem "status" (toByteString' cfg) . expect2xx) + +putFileSharingConfig :: TeamId -> FeatureStatus -> TestM () +putFileSharingConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "file-sharing"] . queryItem "status" (toByteString' cfg) . expect2xx) + +putConferenceCallingConfig :: TeamId -> FeatureStatus -> FeatureTTLDays -> TestM () +putConferenceCallingConfig tid cfg ttl = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", "conference-calling"] . queryItem "status" (toByteString' cfg) . queryItem "ttl" (toByteString' ttl) . expect2xx) + +putFeatureConfig :: + forall cfg. + ( KnownSymbol (FeatureSymbol cfg), + ToSchema cfg, + Typeable cfg, + IsFeatureConfig cfg + ) => + TeamId -> + WithStatusNoLock cfg -> + TestM () +putFeatureConfig tid cfg = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] . json cfg . expect2xx) + +getSearchVisibility :: TeamId -> TestM TeamSearchVisibilityView +getSearchVisibility tid = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "search-visibility"] . expect2xx) + pure $ responseJsonUnsafe r + +putSearchVisibility :: TeamId -> TeamSearchVisibility -> TestM () +putSearchVisibility tid vis = do + s <- view tsStern + void $ put (s . paths ["teams", toByteString' tid, "search-visibility"] . json vis . expect2xx) + +getTeamInvoice :: TeamId -> InvoiceId -> TestM Text +getTeamInvoice tid inr = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "invoice", toByteString' inr] . expect2xx) + pure $ responseJsonUnsafe r + +getTeamBillingInfo :: TeamId -> TestM TeamBillingInfo +getTeamBillingInfo tid = do + s <- view tsStern + r <- get (s . paths ["teams", toByteString' tid, "billing"] . expect2xx) + pure $ responseJsonUnsafe r + +putTeamBillingInfo :: TeamId -> TeamBillingInfoUpdate -> TestM TeamBillingInfo +putTeamBillingInfo tid upd = do + s <- view tsStern + r <- put (s . paths ["teams", toByteString' tid, "billing"] . json upd . expect2xx) + pure $ responseJsonUnsafe r + +postTeamBillingInfo :: TeamId -> TeamBillingInfo -> TestM TeamBillingInfo +postTeamBillingInfo tid upd = do + s <- view tsStern + r <- post (s . paths ["teams", toByteString' tid, "billing"] . json upd . expect2xx) + pure $ responseJsonUnsafe r + +getConsentLog :: Email -> TestM ConsentLogAndMarketo +getConsentLog email = do + s <- view tsStern + r <- get (s . paths ["i", "consent"] . queryItem "email" (toByteString' email) . expect2xx) + pure $ responseJsonUnsafe r + +getUserMetaInfo :: UserId -> TestM UserMetaInfo +getUserMetaInfo uid = do + s <- view tsStern + r <- post (s . paths ["i", "user", "meta-info"] . queryItem "id" (toByteString' uid) . expect2xx) + pure $ responseJsonUnsafe r diff --git a/tools/stern/test/integration/Main.hs b/tools/stern/test/integration/Main.hs new file mode 100644 index 00000000000..ebd27e8040a --- /dev/null +++ b/tools/stern/test/integration/Main.hs @@ -0,0 +1,101 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Main + ( main, + ) +where + +import qualified API +import Bilge hiding (body, header) +import Data.Aeson +import Data.Proxy +import Data.Tagged +import Data.Text.Encoding (encodeUtf8) +import Data.Yaml (decodeFileEither) +import Imports hiding (local) +import Network.HTTP.Client (responseTimeoutMicro) +import Network.HTTP.Client.TLS +import OpenSSL (withOpenSSL) +import Options.Applicative +import qualified System.Logger as Logger +import Test.Tasty +import Test.Tasty.Options +import TestSetup +import Util.Options +import Util.Test + +data IntegrationConfig = IntegrationConfig + { stern :: Endpoint, + brig :: Endpoint, + galley :: Endpoint + } + deriving (Show, Generic) + +instance FromJSON IntegrationConfig + +newtype ServiceConfigFile = ServiceConfigFile String + deriving (Eq, Ord, Typeable) + +instance IsOption ServiceConfigFile where + defaultValue = ServiceConfigFile "/etc/wire/integration/integration.yaml" + parseValue = fmap ServiceConfigFile . safeRead + optionName = pure "service-config" + optionHelp = pure "Service config file to read from" + optionCLParser = + ServiceConfigFile + <$> strOption + ( short (untag (pure 's' :: Tagged ServiceConfigFile Char)) + <> long (untag (optionName :: Tagged ServiceConfigFile String)) + <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) + ) + +runTests :: (String -> TestTree) -> IO () +runTests run = defaultMainWithIngredients ings $ + askOption $ + \(ServiceConfigFile c) -> run c + where + ings = + includingOptions + [ Option (Proxy :: Proxy ServiceConfigFile), + Option (Proxy :: Proxy IntegrationConfigFile) + ] + : defaultIngredients + +main :: IO () +main = withOpenSSL $ runTests go + where + go i = withResource (getOpts i) releaseOpts $ \opts -> + testGroup + "Stern" + [ API.tests opts + ] + getOpts :: FilePath -> IO TestSetup + getOpts iFile = do + m <- + newManager + tlsManagerSettings + { managerResponseTimeout = responseTimeoutMicro 300000000 + } + iConf <- handleParseError =<< decodeFileEither iFile + let s = mkRequest $ stern iConf + let b = mkRequest $ brig iConf + let g = mkRequest $ galley iConf + lg <- Logger.new Logger.defSettings + pure $ TestSetup m s b g lg + releaseOpts _ = pure () + mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/tools/stern/test/integration/TestSetup.hs b/tools/stern/test/integration/TestSetup.hs new file mode 100644 index 00000000000..1e099da4bfc --- /dev/null +++ b/tools/stern/test/integration/TestSetup.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fprint-potential-instances #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 TestSetup + ( test, + tsManager, + tsLogger, + tsStern, + tsBrig, + tsGalley, + TestM (..), + TestSetup (..), + Stern, + Galley, + Brig, + ) +where + +import Bilge (HttpT (..), Manager, MonadHttp, Request, runHttpT) +import Control.Lens (makeLenses, (^.)) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Imports +import qualified System.Logger as Log +import Test.Tasty (TestName, TestTree) +import Test.Tasty.HUnit (Assertion, testCase) + +newtype TestM a = TestM + { runTestM :: ReaderT TestSetup (HttpT IO) a + } + deriving + ( Functor, + Applicative, + Monad, + MonadReader TestSetup, + MonadIO, + MonadCatch, + MonadThrow, + MonadMask, + MonadHttp, + MonadUnliftIO, + MonadFail + ) + +type Stern = Request -> Request + +type Brig = Request -> Request + +type Galley = Request -> Request + +data TestSetup = TestSetup + { _tsManager :: Manager, + _tsStern :: Stern, + _tsBrig :: Brig, + _tsGalley :: Galley, + _tsLogger :: Log.Logger + } + +makeLenses ''TestSetup + +test :: IO TestSetup -> TestName -> TestM a -> TestTree +test mkSetup testName testAction = testCase testName runTest + where + runTest :: Assertion + runTest = do + setup <- mkSetup + void . runHttpT (setup ^. tsManager) . flip runReaderT setup . runTestM $ testAction diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs new file mode 100644 index 00000000000..102908030e7 --- /dev/null +++ b/tools/stern/test/integration/Util.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Util where + +import Bilge +import Bilge.Assert +import Control.Applicative +import Control.Lens hiding ((.=)) +import Control.Monad.Catch +import Control.Retry +import Data.Aeson +import Data.Aeson.Lens +import Data.ByteString.Conversion +import Data.Id +import Data.Misc +import Data.Qualified +import Data.Range +import Data.String.Conversions +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Tuple.Extra +import qualified Data.UUID as UUID +import Data.UUID.V4 +import Imports +import System.Random +import Test.Tasty.HUnit +import TestSetup +import Web.Cookie +import Wire.API.Team +import Wire.API.Team.Invitation +import Wire.API.Team.Member +import qualified Wire.API.Team.Member as Team +import Wire.API.Team.Role +import Wire.API.User + +createBindingTeamWithNMembers :: HasCallStack => Int -> TestM (UserId, TeamId, [UserId]) +createBindingTeamWithNMembers n = do + (owner, tid) <- createBindingTeam + mems <- replicateM n $ do + mem <- addUserToTeam owner tid + pure (mem ^. Team.userId) + pure (owner, tid, mems) + +createBindingTeam :: HasCallStack => TestM (UserId, TeamId) +createBindingTeam = do + first (.userId) <$> createBindingTeam' + +createBindingTeam' :: HasCallStack => TestM (User, TeamId) +createBindingTeam' = do + owner <- randomTeamCreator' + refreshIndex + pure (owner, fromMaybe (error "createBindingTeam: no team id") (owner.userTeam)) + +randomTeamCreator' :: HasCallStack => TestM User +randomTeamCreator' = randomUser'' True True True + +randomUser :: HasCallStack => TestM UserId +randomUser = qUnqualified <$> randomUser' False True True + +randomUser' :: HasCallStack => Bool -> Bool -> Bool -> TestM (Qualified UserId) +randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail + +randomUser'' :: HasCallStack => Bool -> Bool -> Bool -> TestM User +randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' isCreator hasPassword hasEmail + +randomUserProfile' :: HasCallStack => Bool -> Bool -> Bool -> TestM SelfProfile +randomUserProfile' isCreator hasPassword hasEmail = randomUserProfile'' isCreator hasPassword hasEmail <&> fst + +randomUserProfile'' :: HasCallStack => Bool -> Bool -> Bool -> TestM (SelfProfile, (Email, Phone)) +randomUserProfile'' isCreator hasPassword hasEmail = do + b <- view tsBrig + e <- liftIO randomEmail + p <- liftIO randomPhone + let pl = + object $ + ["name" .= fromEmail e] + <> ["password" .= defPassword | hasPassword] + <> ["email" .= fromEmail e | hasEmail] + <> ["phone" .= fromPhone p] + <> ["team" .= BindingNewTeam (newNewTeam (unsafeRange "teamName") DefaultIcon) | isCreator] + (,(e, p)) . responseJsonUnsafe <$> (post (b . path "/i/users" . Bilge.json pl) m Phone +randomPhone = liftIO $ do + nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) + let phone = parsePhone . Text.pack $ "+0" ++ concat nrs + pure $ fromMaybe (error "Invalid random phone#") phone + +randomEmailUser :: HasCallStack => TestM (UserId, Email) +randomEmailUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser) <&> second fst + +randomPhoneUser :: HasCallStack => TestM (UserId, Phone) +randomPhoneUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser) <&> second snd + +randomEmailPhoneUser :: HasCallStack => TestM (UserId, (Email, Phone)) +randomEmailPhoneUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser) + +defPassword :: PlainTextPassword8 +defPassword = plainTextPassword8Unsafe "topsecretdefaultpassword" + +randomEmail :: MonadIO m => m Email +randomEmail = do + uid <- liftIO nextRandom + pure $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" + +setHandle :: UserId -> Text -> TestM () +setHandle uid h = do + b <- view tsBrig + put + ( b + . paths ["/i/users", toByteString' uid, "handle"] + . Bilge.json (HandleUpdate h) + ) + !!! do + const 200 === statusCode + +randomHandle :: MonadIO m => m Text +randomHandle = liftIO $ do + nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z + pure (Text.pack (map chr nrs)) + +refreshIndex :: TestM () +refreshIndex = do + brig <- view tsBrig + post (brig . path "/i/index/refresh") !!! const 200 === statusCode + +addUserToTeam :: HasCallStack => UserId -> TeamId -> TestM TeamMember +addUserToTeam = addUserToTeamWithRole Nothing + +addUserToTeamWithRole :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM TeamMember +addUserToTeamWithRole role inviter tid = do + (inv, rsp2) <- addUserToTeamWithRole' role inviter tid + let invitee :: User = responseJsonUnsafe rsp2 + inviteeId = invitee.userId + let invmeta = Just (inviter, inCreatedAt inv) + mem <- getTeamMember inviter tid inviteeId + liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) + let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2 + liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid) + pure mem + +addUserToTeamWithRole' :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) +addUserToTeamWithRole' role inviter tid = do + brig <- view tsBrig + inviteeEmail <- randomEmail + let invite = InvitationRequest Nothing role Nothing inviteeEmail Nothing + invResponse <- postInvitation tid inviter invite + inv <- responseJsonError invResponse + inviteeCode <- getInvitationCode tid (inInvitation inv) + r <- + post + ( brig + . path "/register" + . contentJson + . body (acceptInviteBody inviteeEmail inviteeCode) + ) + pure (inv, r) + +acceptInviteBody :: Email -> InvitationCode -> RequestBody +acceptInviteBody email code = + RequestBodyLBS . encode $ + object + [ "name" .= Name "bob", + "email" .= fromEmail email, + "password" .= defPassword, + "team_code" .= code + ] + +getInvitationCode :: HasCallStack => TeamId -> InvitationId -> TestM InvitationCode +getInvitationCode t ref = do + brig <- view tsBrig + let getm :: TestM (Maybe InvitationCode) + getm = do + r <- + get + ( brig + . path "/i/teams/invitation-code" + . queryItem "team" (toByteString' t) + . queryItem "invitation_id" (toByteString' ref) + ) + let lbs = fromMaybe "" $ responseBody r + pure $ fromByteString . Text.encodeUtf8 =<< lbs ^? key "code" . _String + + fromMaybe (error "No code?") + <$> retrying + (constantDelay 800000 <> limitRetries 3) + (\_ -> pure . isNothing) + (const getm) + +postInvitation :: TeamId -> UserId -> InvitationRequest -> TestM ResponseLBS +postInvitation t u i = do + brig <- view tsBrig + post $ + brig + . paths ["teams", toByteString' t, "invitations"] + . contentJson + . body (RequestBodyLBS $ encode i) + . zAuthAccess u "conn" + +zAuthAccess :: UserId -> ByteString -> (Request -> Request) +zAuthAccess u conn = + zUser u + . zConn conn + . zType "access" + +zUser :: UserId -> Request -> Request +zUser = header "Z-User" . toByteString' + +zConn :: ByteString -> Request -> Request +zConn = header "Z-Connection" + +zType :: ByteString -> Request -> Request +zType = header "Z-Type" + +getTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestM TeamMember +getTeamMember getter tid gettee = do + g <- view tsGalley + getTeamMember' g getter tid gettee + +getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> UserId -> TeamId -> UserId -> m TeamMember +getTeamMember' g getter tid gettee = do + r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter)