From 121f1340b11d047345c7eb9df4c26cd2c04598cc Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 20 Sep 2022 13:30:35 +0200 Subject: [PATCH 01/18] Avoid qualified Util import --- .../test/integration/API/Teams/Feature.hs | 181 +++++++++--------- 1 file changed, 90 insertions(+), 91 deletions(-) diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 701aad80902..b2324c7c3e6 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -19,9 +19,8 @@ module API.Teams.Feature (tests) where import API.SQS (assertQueue, tActivate) -import API.Util (HasGalley, getFeatureStatusMulti, withSettingsOverrides) -import qualified API.Util as Util -import API.Util.TeamFeature (patchFeatureStatusInternal, putTeamFeatureFlagWithGalley) +import API.Util +import API.Util.TeamFeature hiding (getFeatureConfig, setLockStatusInternal) import qualified API.Util.TeamFeature as Util import Bilge import Bilge.Assert @@ -225,10 +224,10 @@ testPatch' :: cfg -> TestM () testPatch' testLockStatusChange rndFeatureConfig defStatus defConfig = do - (_, tid) <- Util.createBindingTeam - Just original <- responseJsonMaybe <$> Util.getFeatureStatusInternal @cfg tid + (_, tid) <- createBindingTeam + Just original <- responseJsonMaybe <$> getFeatureStatusInternal @cfg tid patchFeatureStatusInternal tid rndFeatureConfig !!! statusCode === const 200 - Just actual <- responseJsonMaybe <$> Util.getFeatureStatusInternal @cfg tid + Just actual <- responseJsonMaybe <$> getFeatureStatusInternal @cfg tid liftIO $ if Public.wsLockStatus actual == Public.LockStatusLocked then do @@ -242,19 +241,19 @@ testPatch' testLockStatusChange rndFeatureConfig defStatus defConfig = do testSSO :: (TeamId -> Public.FeatureStatus -> TestM ()) -> TestM () testSSO setSSOFeature = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser let getSSO :: HasCallStack => Public.FeatureStatus -> TestM () - getSSO = assertFlagNoConfig @Public.SSOConfig $ Util.getTeamFeatureFlag @Public.SSOConfig member tid + getSSO = assertFlagNoConfig @Public.SSOConfig $ getTeamFeatureFlag @Public.SSOConfig member tid getSSOFeatureConfig :: HasCallStack => Public.FeatureStatus -> TestM () getSSOFeatureConfig expectedStatus = do actual <- Util.getFeatureConfig @Public.SSOConfig member liftIO $ Public.wsStatus actual @?= expectedStatus getSSOInternal :: HasCallStack => Public.FeatureStatus -> TestM () - getSSOInternal = assertFlagNoConfig @Public.SSOConfig $ Util.getTeamFeatureFlagInternal @Public.SSOConfig tid + getSSOInternal = assertFlagNoConfig @Public.SSOConfig $ getTeamFeatureFlagInternal @Public.SSOConfig tid - assertFlagForbidden $ Util.getTeamFeatureFlag @Public.SSOConfig nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @Public.SSOConfig nonMember tid featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) case featureSSO of @@ -278,20 +277,20 @@ testSSO setSSOFeature = do putSSOInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () putSSOInternal tid = - void . Util.putTeamFeatureFlagInternal @Public.SSOConfig expect2xx tid + void . putTeamFeatureFlagInternal @Public.SSOConfig expect2xx tid . (\st -> Public.WithStatusNoLock st Public.SSOConfig Public.FeatureTTLUnlimited) patchSSOInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () -patchSSOInternal tid status = void $ Util.patchFeatureStatusInternalWithMod @Public.SSOConfig expect2xx tid (Public.withStatus' (Just status) Nothing Nothing (Just Public.FeatureTTLUnlimited)) +patchSSOInternal tid status = void $ patchFeatureStatusInternalWithMod @Public.SSOConfig expect2xx tid (Public.withStatus' (Just status) Nothing Nothing (Just Public.FeatureTTLUnlimited)) testLegalHold :: ((Request -> Request) -> TeamId -> Public.FeatureStatus -> TestM ()) -> TestM () testLegalHold setLegalHoldInternal = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser let getLegalHold :: HasCallStack => Public.FeatureStatus -> TestM () - getLegalHold = assertFlagNoConfig @Public.LegalholdConfig $ Util.getTeamFeatureFlag @Public.LegalholdConfig member tid + getLegalHold = assertFlagNoConfig @Public.LegalholdConfig $ getTeamFeatureFlag @Public.LegalholdConfig member tid getLegalHoldInternal :: HasCallStack => Public.FeatureStatus -> TestM () - getLegalHoldInternal = assertFlagNoConfig @Public.LegalholdConfig $ Util.getTeamFeatureFlagInternal @Public.LegalholdConfig tid + getLegalHoldInternal = assertFlagNoConfig @Public.LegalholdConfig $ getTeamFeatureFlagInternal @Public.LegalholdConfig tid getLegalHoldFeatureConfig expectedStatus = do actual <- Util.getFeatureConfig @Public.LegalholdConfig member liftIO $ Public.wsStatus actual @?= expectedStatus @@ -299,7 +298,7 @@ testLegalHold setLegalHoldInternal = do getLegalHold Public.FeatureStatusDisabled getLegalHoldInternal Public.FeatureStatusDisabled - assertFlagForbidden $ Util.getTeamFeatureFlag @Public.LegalholdConfig nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @Public.LegalholdConfig nonMember tid -- FUTUREWORK: run two galleys, like below for custom search visibility. featureLegalHold <- view (tsGConf . optSettings . setFeatureFlags . flagLegalHold) @@ -326,25 +325,25 @@ testLegalHold setLegalHoldInternal = do putLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.FeatureStatus -> TestM () putLegalHoldInternal expectation tid = - void . Util.putTeamFeatureFlagInternal @Public.LegalholdConfig expectation tid + void . putTeamFeatureFlagInternal @Public.LegalholdConfig expectation tid . (\st -> Public.WithStatusNoLock st Public.LegalholdConfig Public.FeatureTTLUnlimited) patchLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.FeatureStatus -> TestM () -patchLegalHoldInternal expectation tid status = void $ Util.patchFeatureStatusInternalWithMod @Public.LegalholdConfig expectation tid (Public.withStatus' (Just status) Nothing Nothing (Just Public.FeatureTTLUnlimited)) +patchLegalHoldInternal expectation tid status = void $ patchFeatureStatusInternalWithMod @Public.LegalholdConfig expectation tid (Public.withStatus' (Just status) Nothing Nothing (Just Public.FeatureTTLUnlimited)) testSearchVisibility :: TestM () testSearchVisibility = do let getTeamSearchVisibility :: TeamId -> UserId -> Public.FeatureStatus -> TestM () getTeamSearchVisibility teamid uid expected = do g <- view tsGalley - Util.getTeamSearchVisibilityAvailable g uid teamid !!! do + getTeamSearchVisibilityAvailable g uid teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.WithStatusNoLock expected Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited)) let getTeamSearchVisibilityInternal :: TeamId -> Public.FeatureStatus -> TestM () getTeamSearchVisibilityInternal teamid expected = do g <- view tsGalley - Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do + getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.WithStatusNoLock expected Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited)) @@ -356,14 +355,14 @@ testSearchVisibility = do let setTeamSearchVisibilityInternal :: TeamId -> Public.FeatureStatus -> TestM () setTeamSearchVisibilityInternal teamid val = do g <- view tsGalley - Util.putTeamSearchVisibilityAvailableInternal g teamid val + putTeamSearchVisibilityAvailableInternal g teamid val - (owner, tid, [member]) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (owner, tid, [member]) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser - assertFlagForbidden $ Util.getTeamFeatureFlag @Public.SearchVisibilityAvailableConfig nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @Public.SearchVisibilityAvailableConfig nonMember tid - Util.withCustomSearchFeature FeatureTeamSearchVisibilityUnavailableByDefault $ do + withCustomSearchFeature FeatureTeamSearchVisibilityUnavailableByDefault $ do getTeamSearchVisibility tid owner Public.FeatureStatusDisabled getTeamSearchVisibilityInternal tid Public.FeatureStatusDisabled getTeamSearchVisibilityFeatureConfig member Public.FeatureStatusDisabled @@ -378,9 +377,9 @@ testSearchVisibility = do getTeamSearchVisibilityInternal tid Public.FeatureStatusDisabled getTeamSearchVisibilityFeatureConfig member Public.FeatureStatusDisabled - (owner2, tid2, team2member : _) <- Util.createBindingTeamWithNMembers 1 + (owner2, tid2, team2member : _) <- createBindingTeamWithNMembers 1 - Util.withCustomSearchFeature FeatureTeamSearchVisibilityAvailableByDefault $ do + withCustomSearchFeature FeatureTeamSearchVisibilityAvailableByDefault $ do getTeamSearchVisibility tid2 owner2 Public.FeatureStatusEnabled getTeamSearchVisibilityInternal tid2 Public.FeatureStatusEnabled getTeamSearchVisibilityFeatureConfig team2member Public.FeatureStatusEnabled @@ -403,7 +402,7 @@ getClassifiedDomains :: m () getClassifiedDomains member tid = assertFlagWithConfig @Public.ClassifiedDomainsConfig $ - Util.getTeamFeatureFlag @Public.ClassifiedDomainsConfig member tid + getTeamFeatureFlag @Public.ClassifiedDomainsConfig member tid getClassifiedDomainsInternal :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => @@ -412,11 +411,11 @@ getClassifiedDomainsInternal :: m () getClassifiedDomainsInternal tid = assertFlagWithConfig @Public.ClassifiedDomainsConfig $ - Util.getTeamFeatureFlagInternal @Public.ClassifiedDomainsConfig tid + getTeamFeatureFlagInternal @Public.ClassifiedDomainsConfig tid testClassifiedDomainsEnabled :: TestM () testClassifiedDomainsEnabled = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 let expected = Public.WithStatusNoLock Public.FeatureStatusEnabled (Public.ClassifiedDomainsConfig [Domain "example.com"]) Public.FeatureTTLUnlimited @@ -436,7 +435,7 @@ testClassifiedDomainsEnabled = do testClassifiedDomainsDisabled :: TestM () testClassifiedDomainsDisabled = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 let expected = Public.WithStatusNoLock Public.FeatureStatusDisabled (Public.ClassifiedDomainsConfig []) Public.FeatureTTLUnlimited @@ -491,12 +490,12 @@ testSimpleFlagTTLOverride :: FeatureTTL -> TestM () testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser let getFlag :: HasCallStack => Public.FeatureStatus -> TestM () getFlag expected = eventually $ do - flip (assertFlagNoConfig @cfg) expected $ Util.getTeamFeatureFlag @cfg member tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlag @cfg member tid getFeatureConfig :: HasCallStack => Public.FeatureStatus -> FeatureTTL -> TestM () getFeatureConfig expectedStatus expectedTtl = eventually $ do @@ -506,11 +505,11 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do getFlagInternal :: HasCallStack => Public.FeatureStatus -> TestM () getFlagInternal expected = eventually $ do - flip (assertFlagNoConfig @cfg) expected $ Util.getTeamFeatureFlagInternal @cfg tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlagInternal @cfg tid setFlagInternal :: Public.FeatureStatus -> FeatureTTL -> TestM () setFlagInternal statusValue ttl' = - void $ Util.putTeamFeatureFlagInternalTTL @cfg expect2xx tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) ttl') + void $ putTeamFeatureFlagInternalTTL @cfg expect2xx tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) ttl') select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) select = fromString "select ttl(conference_calling) from team_features where team_id = ?" @@ -537,7 +536,7 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do toMicros secs = fromIntegral secs * 1000000 - assertFlagForbidden $ Util.getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid let otherValue = case defaultValue of Public.FeatureStatusDisabled -> Public.FeatureStatusEnabled @@ -618,12 +617,12 @@ testSimpleFlagTTL :: FeatureTTL -> TestM () testSimpleFlagTTL defaultValue ttl = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser let getFlag :: HasCallStack => Public.FeatureStatus -> TestM () getFlag expected = - flip (assertFlagNoConfig @cfg) expected $ Util.getTeamFeatureFlag @cfg member tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlag @cfg member tid getFeatureConfig :: HasCallStack => Public.FeatureStatus -> TestM () getFeatureConfig expected = do @@ -632,11 +631,11 @@ testSimpleFlagTTL defaultValue ttl = do getFlagInternal :: HasCallStack => Public.FeatureStatus -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @cfg) expected $ Util.getTeamFeatureFlagInternal @cfg tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlagInternal @cfg tid setFlagInternal :: Public.FeatureStatus -> FeatureTTL -> TestM () setFlagInternal statusValue ttl' = - void $ Util.putTeamFeatureFlagInternalTTL @cfg expect2xx tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) ttl') + void $ putTeamFeatureFlagInternalTTL @cfg expect2xx tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) ttl') select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) select = fromString "select ttl(conference_calling) from team_features where team_id = ?" @@ -661,7 +660,7 @@ testSimpleFlagTTL defaultValue ttl = do Just (FeatureTTLSeconds i) -> i <= upper unless check $ error ("expected ttl <= " <> show upper <> ", got " <> show storedTTL) - assertFlagForbidden $ Util.getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid let otherValue = case defaultValue of Public.FeatureStatusDisabled -> Public.FeatureStatusEnabled @@ -717,12 +716,12 @@ testSimpleFlagWithLockStatus :: TestM () testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do galley <- view tsGalley - (owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - nonMember <- Util.randomUser + (owner, tid, member : _) <- createBindingTeamWithNMembers 1 + nonMember <- randomUser let getFlag :: HasCallStack => Public.FeatureStatus -> Public.LockStatus -> TestM () getFlag expectedStatus expectedLockStatus = do - let flag = Util.getTeamFeatureFlag @cfg member tid + let flag = getTeamFeatureFlag @cfg member tid assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus getFeatureConfig :: HasCallStack => Public.FeatureStatus -> Public.LockStatus -> TestM () @@ -733,7 +732,7 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do getFlagInternal :: HasCallStack => Public.FeatureStatus -> Public.LockStatus -> TestM () getFlagInternal expectedStatus expectedLockStatus = do - let flag = Util.getTeamFeatureFlagInternal @cfg tid + let flag = getTeamFeatureFlagInternal @cfg tid assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus getFlags expectedStatus expectedLockStatus = do @@ -743,12 +742,12 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do setFlagWithGalley :: Public.FeatureStatus -> TestM () setFlagWithGalley statusValue = - Util.putTeamFeatureFlagWithGalley @cfg galley owner tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) Public.FeatureTTLUnlimited) + putTeamFeatureFlagWithGalley @cfg galley owner tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) Public.FeatureTTLUnlimited) !!! statusCode === const 200 assertSetStatusForbidden :: Public.FeatureStatus -> TestM () assertSetStatusForbidden statusValue = - Util.putTeamFeatureFlagWithGalley @cfg galley owner tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) Public.FeatureTTLUnlimited) + putTeamFeatureFlagWithGalley @cfg galley owner tid (Public.WithStatusNoLock statusValue (Public.trivialConfig @cfg) Public.FeatureTTLUnlimited) !!! statusCode === const 409 setLockStatus :: Public.LockStatus -> TestM () @@ -756,7 +755,7 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do Util.setLockStatusInternal @cfg galley tid lockStatus !!! statusCode === const 200 - assertFlagForbidden $ Util.getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid let otherStatus = case defaultStatus of Public.FeatureStatusDisabled -> Public.FeatureStatusEnabled @@ -821,19 +820,19 @@ testSelfDeletingMessages = do (Public.SelfDeletingMessagesConfig tout) Public.FeatureTTLUnlimited - personalUser <- Util.randomUser + personalUser <- randomUser do result <- Util.getFeatureConfig @Public.SelfDeletingMessagesConfig personalUser liftIO $ result @?= settingWithLockStatus FeatureStatusEnabled 0 defLockStatus -- team users galley <- view tsGalley - (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 + (owner, tid, []) <- createBindingTeamWithNMembers 0 let checkSet :: FeatureStatus -> Int32 -> Int -> TestM () checkSet stat tout expectedStatusCode = do - Util.putTeamFeatureFlagInternal @Public.SelfDeletingMessagesConfig + putTeamFeatureFlagInternal @Public.SelfDeletingMessagesConfig galley tid (settingWithoutLockStatus stat tout) @@ -844,8 +843,8 @@ testSelfDeletingMessages = do checkGet stat tout lockStatus = do let expected = settingWithLockStatus stat tout lockStatus forM_ - [ Util.getTeamFeatureFlagInternal @Public.SelfDeletingMessagesConfig tid, - Util.getTeamFeatureFlagWithGalley @Public.SelfDeletingMessagesConfig galley owner tid + [ getTeamFeatureFlagInternal @Public.SelfDeletingMessagesConfig tid, + getTeamFeatureFlagWithGalley @Public.SelfDeletingMessagesConfig galley owner tid ] (!!! responseJsonEither === const (Right expected)) result <- Util.getFeatureConfig @Public.SelfDeletingMessagesConfig owner @@ -896,16 +895,16 @@ testGuestLinksInternal :: TestM () testGuestLinksInternal = do galley <- view tsGalley testGuestLinks - (const $ Util.getTeamFeatureFlagInternal @Public.GuestLinksConfig) - (const $ Util.putTeamFeatureFlagInternal @Public.GuestLinksConfig galley) + (const $ getTeamFeatureFlagInternal @Public.GuestLinksConfig) + (const $ putTeamFeatureFlagInternal @Public.GuestLinksConfig galley) (Util.setLockStatusInternal @Public.GuestLinksConfig galley) testGuestLinksPublic :: TestM () testGuestLinksPublic = do galley <- view tsGalley testGuestLinks - (Util.getTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) - (Util.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) + (getTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) + (putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) (Util.setLockStatusInternal @Public.GuestLinksConfig galley) testGuestLinks :: @@ -914,7 +913,7 @@ testGuestLinks :: (TeamId -> Public.LockStatus -> TestM ResponseLBS) -> TestM () testGuestLinks getStatus putStatus setLockStatusInternal = do - (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 + (owner, tid, []) <- createBindingTeamWithNMembers 0 let checkGet :: HasCallStack => Public.FeatureStatus -> Public.LockStatus -> TestM () checkGet status lock = getStatus owner tid !!! do @@ -959,8 +958,8 @@ testAllFeatures = do . to Public.wsLockStatus ) - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 - Util.getAllTeamFeatures member tid !!! do + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + getAllTeamFeatures member tid !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) @@ -969,18 +968,18 @@ testAllFeatures = do -- 2. there is a row for team_id in galley.team_features but the feature has a no entry (null value) galley <- view tsGalley -- this sets the guest links config to its default value thereby creating a row for the team in galley.team_features - Util.putTeamFeatureFlagInternal @Public.GuestLinksConfig galley tid (Public.WithStatusNoLock FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited) + putTeamFeatureFlagInternal @Public.GuestLinksConfig galley tid (Public.WithStatusNoLock FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! statusCode === const 200 - Util.getAllTeamFeatures member tid !!! do + getAllTeamFeatures member tid !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - Util.getAllTeamFeaturesPersonal member !!! do + getAllTeamFeaturesPersonal member !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - randomPersonalUser <- Util.randomUser - Util.getAllTeamFeaturesPersonal randomPersonalUser !!! do + randomPersonalUser <- randomUser + getAllTeamFeaturesPersonal randomPersonalUser !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) where @@ -1005,11 +1004,11 @@ testAllFeatures = do testFeatureConfigConsistency :: TestM () testFeatureConfigConsistency = do - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 + (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - allFeaturesRes <- Util.getAllFeatureConfigs member >>= parseObjectKeys + allFeaturesRes <- getAllFeatureConfigs member >>= parseObjectKeys - allTeamFeaturesRes <- Util.getAllTeamFeatures member tid >>= parseObjectKeys + allTeamFeaturesRes <- getAllTeamFeatures member tid >>= parseObjectKeys unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ liftIO $ expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) @@ -1026,15 +1025,15 @@ testFeatureConfigConsistency = do testSearchVisibilityInbound :: TestM () testSearchVisibilityInbound = do let defaultValue = FeatureStatusDisabled - (_owner, tid, _) <- Util.createBindingTeamWithNMembers 1 + (_owner, tid, _) <- createBindingTeamWithNMembers 1 let getFlagInternal :: HasCallStack => Public.FeatureStatus -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @Public.SearchVisibilityInboundConfig) expected $ Util.getTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig tid + flip (assertFlagNoConfig @Public.SearchVisibilityInboundConfig) expected $ getTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig tid setFlagInternal :: Public.FeatureStatus -> TestM () setFlagInternal statusValue = - void $ Util.putTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) + void $ putTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) let otherValue = case defaultValue of Public.FeatureStatusDisabled -> Public.FeatureStatusEnabled @@ -1047,12 +1046,12 @@ testSearchVisibilityInbound = do testFeatureNoConfigMultiSearchVisibilityInbound :: TestM () testFeatureNoConfigMultiSearchVisibilityInbound = do - (_owner1, team1, _) <- Util.createBindingTeamWithNMembers 0 - (_owner2, team2, _) <- Util.createBindingTeamWithNMembers 0 + (_owner1, team1, _) <- createBindingTeamWithNMembers 0 + (_owner2, team2, _) <- createBindingTeamWithNMembers 0 let setFlagInternal :: TeamId -> Public.FeatureStatus -> TestM () setFlagInternal tid statusValue = - void $ Util.putTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) + void $ putTeamFeatureFlagInternal @Public.SearchVisibilityInboundConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) setFlagInternal team2 Public.FeatureStatusEnabled @@ -1065,26 +1064,26 @@ testFeatureNoConfigMultiSearchVisibilityInbound = do liftIO $ do length teamsStatuses @?= 2 - Multi.TeamStatus _ team1Status <- Util.assertOne (filter ((== team1) . Multi.team) teamsStatuses) + Multi.TeamStatus _ team1Status <- assertOne (filter ((== team1) . Multi.team) teamsStatuses) team1Status @?= Public.FeatureStatusDisabled - Multi.TeamStatus _ team2Status <- Util.assertOne (filter ((== team2) . Multi.team) teamsStatuses) + Multi.TeamStatus _ team2Status <- assertOne (filter ((== team2) . Multi.team) teamsStatuses) team2Status @?= Public.FeatureStatusEnabled testMLS :: TestM () testMLS = do - (owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 + (owner, tid, member : _) <- createBindingTeamWithNMembers 1 galley <- view tsGalley cannon <- view tsCannon let getForTeam :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () getForTeam expected = - flip assertFlagWithConfig expected $ Util.getTeamFeatureFlag @MLSConfig member tid + flip assertFlagWithConfig expected $ getTeamFeatureFlag @MLSConfig member tid getForTeamInternal :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () getForTeamInternal expected = - flip assertFlagWithConfig expected $ Util.getTeamFeatureFlagInternal @Public.MLSConfig tid + flip assertFlagWithConfig expected $ getTeamFeatureFlagInternal @Public.MLSConfig tid getForUser :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () getForUser expected = do @@ -1100,12 +1099,12 @@ testMLS = do setForTeam :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () setForTeam wsnl = - Util.putTeamFeatureFlagWithGalley @MLSConfig galley owner tid wsnl + putTeamFeatureFlagWithGalley @MLSConfig galley owner tid wsnl !!! statusCode === const 200 setForTeamInternal :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () setForTeamInternal wsnl = - void $ Util.putTeamFeatureFlagInternal @Public.MLSConfig expect2xx tid wsnl + void $ putTeamFeatureFlagInternal @Public.MLSConfig expect2xx tid wsnl let cipherSuite = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 let defaultConfig = @@ -1142,8 +1141,8 @@ testMLS = do testExposeInvitationURLsToTeamAdminTeamIdInAllowList :: TestM () testExposeInvitationURLsToTeamAdminTeamIdInAllowList = do - owner <- Util.randomUser - tid <- Util.createBindingTeamInternal "foo" owner + owner <- randomUser + tid <- createBindingTeamInternal "foo" owner assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist ?~ [tid]) $ do @@ -1157,8 +1156,8 @@ testExposeInvitationURLsToTeamAdminTeamIdInAllowList = do testExposeInvitationURLsToTeamAdminEmptyAllowList :: TestM () testExposeInvitationURLsToTeamAdminEmptyAllowList = do - owner <- Util.randomUser - tid <- Util.createBindingTeamInternal "foo" owner + owner <- randomUser + tid <- createBindingTeamInternal "foo" owner assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist .~ Nothing) $ do @@ -1178,8 +1177,8 @@ testExposeInvitationURLsToTeamAdminEmptyAllowList = do -- might have been enabled before). testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence :: TestM () testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do - owner <- Util.randomUser - tid <- Util.createBindingTeamInternal "foo" owner + owner <- randomUser + tid <- createBindingTeamInternal "foo" owner assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist ?~ [tid]) $ do From cc725b7880a87532a3038a50ebf638f98176d0ca Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Sep 2022 11:07:42 +0200 Subject: [PATCH 02/18] Use viewGalley everywhere --- services/galley/test/integration/API.hs | 28 ++--- .../test/integration/API/CustomBackend.hs | 12 +- services/galley/test/integration/API/Roles.hs | 2 +- services/galley/test/integration/API/Teams.hs | 60 ++++----- .../test/integration/API/Teams/Feature.hs | 28 ++--- .../test/integration/API/Teams/LegalHold.hs | 40 +++--- .../API/Teams/LegalHold/DisabledByDefault.hs | 22 ++-- services/galley/test/integration/API/Util.hs | 114 +++++++++--------- .../test/integration/API/Util/TeamFeature.hs | 16 +-- services/galley/test/integration/TestSetup.hs | 4 +- 10 files changed, 163 insertions(+), 163 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 19c775fc400..bad7f34aeb5 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -247,7 +247,7 @@ tests s = status :: TestM () status = do - g <- view tsGalley + g <- viewGalley get (g . path "/i/status") !!! const 200 === statusCode Bilge.head (g . path "/i/status") @@ -255,7 +255,7 @@ status = do metrics :: TestM () metrics = do - g <- view tsGalley + g <- viewGalley get (g . path "/i/metrics") !!! do const 200 === statusCode -- Should contain the request duration metric in its output @@ -1216,7 +1216,7 @@ testJoinCodeConv = do testGetCodeRejectedIfGuestLinksDisabled :: TestM () testGetCodeRejectedIfGuestLinksDisabled = do - galley <- view tsGalley + galley <- viewGalley (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, GuestAccessRole] [] let createConvWithGuestLink = do @@ -1237,7 +1237,7 @@ testGetCodeRejectedIfGuestLinksDisabled = do testPostCodeRejectedIfGuestLinksDisabled :: TestM () testPostCodeRejectedIfGuestLinksDisabled = do - galley <- view tsGalley + galley <- viewGalley (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 Right noGuestsAccess <- liftIO $ genAccessRolesV2 [NonTeamMemberAccessRole] [GuestAccessRole] convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just noGuestsAccess) Nothing @@ -1256,7 +1256,7 @@ testPostCodeRejectedIfGuestLinksDisabled = do -- Check if guests cannot join anymore if guest invite feature was disabled on team level testJoinTeamConvGuestLinksDisabled :: TestM () testJoinTeamConvGuestLinksDisabled = do - galley <- view tsGalley + galley <- viewGalley let convName = "testConversation" (owner, teamId, [alice]) <- Util.createBindingTeamWithNMembers 1 eve <- ephemeralUser @@ -1315,7 +1315,7 @@ testJoinTeamConvGuestLinksDisabled = do testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do - galley <- view tsGalley + galley <- viewGalley let convName = "testConversation" (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 userNotInTeam <- randomUser @@ -1606,7 +1606,7 @@ testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved = do getGuestLinksStatusFromForeignTeamConv :: TestM () getGuestLinksStatusFromForeignTeamConv = do localDomain <- viewFederationDomain - galley <- view tsGalley + galley <- viewGalley let setTeamStatus u tid tfStatus = TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley u tid (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode @@ -2064,7 +2064,7 @@ postConvQualifiedFederationNotEnabled = do connectWithRemoteUser alice bob let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ do - g <- view tsGalley + g <- viewGalley postConvHelper g alice [bob] !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe @@ -2100,7 +2100,7 @@ postO2OConvOk = do postConvO2OFailWithSelf :: TestM () postConvO2OFailWithSelf = do - g <- view tsGalley + g <- viewGalley alice <- randomUser let inv = NewConv [alice] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing post (g . path "/conversations/one2one" . zUser alice . zConn "conn" . zType "access" . json inv) !!! do @@ -2221,7 +2221,7 @@ postRepeatConnectConvCancel = do privateAccess @=? cnvAccess cnv4 where cancel u c = do - g <- view tsGalley + g <- viewGalley let cnvId = qUnqualified . cnvQualifiedId put (g . paths ["/i/conversations", toByteString' (cnvId c), "block"] . zUser u) !!! const 200 === statusCode @@ -2229,7 +2229,7 @@ postRepeatConnectConvCancel = do putBlockConvOk :: TestM () putBlockConvOk = do - g <- view tsGalley + g <- viewGalley alice <- randomUser bob <- randomUser conv <- responseJsonUnsafeWithMsg "conversation" <$> postConnectConv alice bob "Alice" "connect with me!" (Just "me@me.com") @@ -2289,7 +2289,7 @@ getConvQualifiedOk = do accessConvMeta :: TestM () accessConvMeta = do - g <- view tsGalley + g <- viewGalley alice <- randomUser bob <- randomUser chuck <- randomUser @@ -3114,7 +3114,7 @@ putQualifiedConvRenameWithRemotesOk = do putConvDeprecatedRenameOk :: TestM () putConvDeprecatedRenameOk = do c <- view tsCannon - g <- view tsGalley + g <- viewGalley alice <- randomUser qbob <- randomQualifiedUser let bob = qUnqualified qbob @@ -3600,7 +3600,7 @@ putReceiptModeWithRemotesOk = do postTypingIndicators :: TestM () postTypingIndicators = do - g <- view tsGalley + g <- viewGalley alice <- randomUser bob <- randomUser connectUsers alice (singleton bob) diff --git a/services/galley/test/integration/API/CustomBackend.hs b/services/galley/test/integration/API/CustomBackend.hs index 4f427c2f7d3..3da26252beb 100644 --- a/services/galley/test/integration/API/CustomBackend.hs +++ b/services/galley/test/integration/API/CustomBackend.hs @@ -20,9 +20,9 @@ module API.CustomBackend ) where +import API.Util import Bilge hiding (timeout) import Bilge.Assert -import Control.Lens (view) import Data.Aeson hiding (json) import Data.Aeson.QQ (aesonQQ) import Imports @@ -43,13 +43,13 @@ tests s = getByDomainNotFound :: TestM () getByDomainNotFound = do - galley <- view tsGalley + galley <- viewGalley get (galley . path "/custom-backend/by-domain/domain.no1") !!! do const 404 === statusCode getByDomainInvalidDomain :: TestM () getByDomainInvalidDomain = do - galley <- view tsGalley + galley <- viewGalley -- contains invalid character '+' -- this used to respond with '400 bad request' -- but after servantification it returns '404 not found' @@ -59,7 +59,7 @@ getByDomainInvalidDomain = do getByDomainFound :: TestM () getByDomainFound = do - galley <- view tsGalley + galley <- viewGalley let jsonBody :: Value jsonBody = [aesonQQ|{ @@ -74,7 +74,7 @@ getByDomainFound = do getByDomainDeleted :: TestM () getByDomainDeleted = do - galley <- view tsGalley + galley <- viewGalley let jsonBody :: Value jsonBody = [aesonQQ|{ @@ -90,7 +90,7 @@ getByDomainDeleted = do getByDomainIsCaseInsensitive :: TestM () getByDomainIsCaseInsensitive = do - galley <- view tsGalley + galley <- viewGalley let jsonBody :: Value jsonBody = [aesonQQ|{ diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 1f55cfe02a3..ec4a5dc80da 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -67,7 +67,7 @@ testAllConversationRoles = do connectUsers alice (list1 bob [chuck]) let role = roleNameWireAdmin c <- decodeConvId <$> postConvWithRole alice [bob] (Just "gossip") [] Nothing Nothing role - g <- view tsGalley + g <- viewGalley get ( g . paths ["conversations", toByteString' c, "roles"] diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index df7d9fe6f31..5765f83b3c8 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -74,8 +74,8 @@ import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit -import TestHelpers (eventually, test, viewFederationDomain) -import TestSetup (TestM, TestSetup, tsBrig, tsCannon, tsGConf, tsGalley) +import TestHelpers +import TestSetup import UnliftIO (mapConcurrently) import Wire.API.Conversation import Wire.API.Conversation.Protocol @@ -381,7 +381,7 @@ testEnableSSOPerTeam = do liftIO $ assertEqual msg enabledness statusValue let putSSOEnabledInternalCheckNotImplemented :: HasCallStack => TestM () putSSOEnabledInternalCheckNotImplemented = do - g <- view tsGalley + g <- viewGalley Wai.Error status label _ _ <- responseJsonUnsafe <$> put @@ -405,27 +405,27 @@ testEnableTeamSearchVisibilityPerTeam = do (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: String -> Public.FeatureStatus -> TestM () check msg enabledness = do - g <- view tsGalley + g <- viewGalley status :: Public.WithStatusNoLock Public.SearchVisibilityAvailableConfig <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam liftIO $ do assertEqual "bad status" status403 status assertEqual "bad label" "team-search-visibility-not-enabled" label let getSearchVisibilityCheck :: TeamSearchVisibility -> TestM () getSearchVisibilityCheck vis = do - g <- view tsGalley + g <- viewGalley getSearchVisibility g owner tid !!! do const 200 === statusCode const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe Util.withCustomSearchFeature FeatureTeamSearchVisibilityAvailableByDefault $ do - g <- view tsGalley + g <- viewGalley check "Teams should start with Custom Search Visibility enabled" Public.FeatureStatusEnabled putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! const 204 === statusCode putSearchVisibility g owner tid SearchVisibilityStandard !!! const 204 === statusCode @@ -433,7 +433,7 @@ testEnableTeamSearchVisibilityPerTeam = do check "Teams should start with Custom Search Visibility disabled" Public.FeatureStatusDisabled putSearchVisibilityCheckNotAllowed - g <- view tsGalley + g <- viewGalley Util.putTeamSearchVisibilityAvailableInternal g tid Public.FeatureStatusEnabled -- Nothing was set, default value getSearchVisibilityCheck SearchVisibilityStandard @@ -563,7 +563,7 @@ testAddTeamMemberInternal = do testRemoveBindingTeamMember :: Bool -> TestM () testRemoveBindingTeamMember ownerHasPassword = do localDomain <- viewFederationDomain - g <- view tsGalley + g <- viewGalley c <- view tsCannon -- Owner who creates the team must have an email, This is why we run all tests with a second -- owner @@ -686,7 +686,7 @@ testRemoveBindingTeamOwner = do where check :: HasCallStack => TeamId -> UserId -> UserId -> Maybe PlainTextPassword -> Maybe LText -> TestM () check tid deleter deletee pass maybeError = do - g <- view tsGalley + g <- viewGalley delete ( g . paths ["teams", toByteString' tid, "members", toByteString' deletee] @@ -910,7 +910,7 @@ testUpdateTeamConv _ convRole = do testDeleteBindingTeamSingleMember :: TestM () testDeleteBindingTeamSingleMember = do - g <- view tsGalley + g <- viewGalley c <- view tsCannon (owner, tid) <- Util.createBindingTeam other <- Util.addUserToTeam owner tid @@ -971,7 +971,7 @@ testDeleteBindingTeamSingleMember = do testDeleteBindingTeamNoMembers :: TestM () testDeleteBindingTeamNoMembers = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- Util.createBindingTeam deleteUser owner !!! const 200 === statusCode ensureQueueEmpty @@ -982,7 +982,7 @@ testDeleteBindingTeamNoMembers = do testDeleteBindingTeamMoreThanOneMember :: TestM () testDeleteBindingTeamMoreThanOneMember = do - g <- view tsGalley + g <- viewGalley b <- view tsBrig c <- view tsCannon (alice, tid, members) <- Util.createBindingTeamWithNMembers 10 @@ -1011,7 +1011,7 @@ testDeleteBindingTeamMoreThanOneMember = do testDeleteTeamVerificationCodeSuccess :: TestM () testDeleteTeamVerificationCodeSuccess = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- Util.createBindingTeam' let Just email = U.userEmail owner setFeatureLockStatus @Public.SndFactorPasswordChallengeConfig tid Public.LockStatusUnlocked @@ -1035,7 +1035,7 @@ testDeleteTeamVerificationCodeSuccess = do -- Test that team cannot be deleted with missing second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeMissingCode :: TestM () testDeleteTeamVerificationCodeMissingCode = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- Util.createBindingTeam' setFeatureLockStatus @Public.SndFactorPasswordChallengeConfig tid Public.LockStatusUnlocked setTeamSndFactorPasswordChallenge tid Public.FeatureStatusEnabled @@ -1060,7 +1060,7 @@ testDeleteTeamVerificationCodeMissingCode = do -- Test that team cannot be deleted with expired second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeExpiredCode :: TestM () testDeleteTeamVerificationCodeExpiredCode = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- Util.createBindingTeam' setFeatureLockStatus @Public.SndFactorPasswordChallengeConfig tid Public.LockStatusUnlocked setTeamSndFactorPasswordChallenge tid Public.FeatureStatusEnabled @@ -1088,7 +1088,7 @@ testDeleteTeamVerificationCodeExpiredCode = do -- Test that team cannot be deleted with wrong second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeWrongCode :: TestM () testDeleteTeamVerificationCodeWrongCode = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- Util.createBindingTeam' setFeatureLockStatus @Public.SndFactorPasswordChallengeConfig tid Public.LockStatusUnlocked setTeamSndFactorPasswordChallenge tid Public.FeatureStatusEnabled @@ -1111,7 +1111,7 @@ testDeleteTeamVerificationCodeWrongCode = do setFeatureLockStatus :: forall cfg. (Public.IsFeatureConfig cfg, KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> Public.LockStatus -> TestM () setFeatureLockStatus tid status = do - g <- view tsGalley + g <- viewGalley put (g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' status]) !!! const 200 === statusCode generateVerificationCode :: Public.SendVerificationCode -> TestM () @@ -1122,7 +1122,7 @@ generateVerificationCode req = do setTeamSndFactorPasswordChallenge :: TeamId -> Public.FeatureStatus -> TestM () setTeamSndFactorPasswordChallenge tid status = do - g <- view tsGalley + g <- viewGalley let js = RequestBodyLBS $ encode $ Public.WithStatusNoLock status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited put (g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode @@ -1136,7 +1136,7 @@ getVerificationCode uid action = do testDeleteBindingTeam :: Bool -> TestM () testDeleteBindingTeam ownerHasPassword = do - g <- view tsGalley + g <- viewGalley c <- view tsCannon (ownerWithPassword, tid) <- Util.createBindingTeam ownerMem <- @@ -1272,7 +1272,7 @@ testDeleteTeamConv = do testUpdateTeamIconValidation :: TestM () testUpdateTeamIconValidation = do - g <- view tsGalley + g <- viewGalley (tid, owner, _) <- Util.createBindingTeamWithMembers 2 let update payload expectedStatusCode = put @@ -1297,7 +1297,7 @@ testUpdateTeamIconValidation = do testUpdateTeam :: TestM () testUpdateTeam = do - g <- view tsGalley + g <- viewGalley c <- view tsCannon (tid, owner, [member]) <- Util.createBindingTeamWithMembers 2 @@ -1421,7 +1421,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do modifyTeamDataAndExpectEvent :: HasCallStack => Bool -> TeamId -> UserId -> TestM () modifyTeamDataAndExpectEvent expect tid origin = do c <- view tsCannon - g <- view tsGalley + g <- viewGalley let u = newTeamUpdateData & nameUpdate .~ (Just $ unsafeRange "bar") WS.bracketR c origin $ \wsOrigin -> do put @@ -1450,7 +1450,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do removeTeamMemberAndExpectEvent :: HasCallStack => Bool -> UserId -> TeamId -> UserId -> [UserId] -> TestM () removeTeamMemberAndExpectEvent expect owner tid victim others = do c <- view tsCannon - g <- view tsGalley + g <- viewGalley WS.bracketRN c (owner : victim : others) $ \(wsOwner : _wsVictim : wsOthers) -> do delete ( g @@ -1470,7 +1470,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do deleteTeam :: HasCallStack => TeamId -> UserId -> [UserId] -> [Qualified ConvId] -> UserId -> TestM () deleteTeam tid owner otherRealUsersInTeam teamCidsThatExternBelongsTo extern = do c <- view tsCannon - g <- view tsGalley + g <- viewGalley void . WS.bracketRN c (owner : extern : otherRealUsersInTeam) $ \(_wsOwner : wsExtern : _wsotherRealUsersInTeam) -> do delete ( g @@ -1497,7 +1497,7 @@ testBillingInLargeTeam = do (firstOwner, team) <- Util.createBindingTeam refreshIndex opts <- view tsGConf - galley <- view tsGalley + galley <- viewGalley let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts allOwnersBeforeFanoutLimit <- foldM @@ -1534,7 +1534,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do (firstOwner, team) <- Util.createBindingTeam refreshIndex opts <- view tsGConf - galley <- view tsGalley + galley <- viewGalley let withoutIndexedBillingTeamMembers = withSettingsOverrides (\o -> o & optSettings . setEnableIndexedBillingTeamMembers ?~ False) let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts @@ -1566,7 +1566,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do -- We cannot properly add the new owner with an invite as we don't have a way to -- override galley settings while making a call to brig withoutIndexedBillingTeamMembers $ do - g <- view tsGalley + g <- viewGalley post (g . paths ["i", "teams", toByteString' team, "members"] . memFanoutPlusTwo) !!! const 200 === statusCode assertQueue ("add " <> show (fanoutLimit + 2) <> "th billing member: " <> show ownerFanoutPlusTwo) $ @@ -1632,7 +1632,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do -- Demotion by inferior roles is NOT allowed. testUpdateTeamMember :: TestM () testUpdateTeamMember = do - g <- view tsGalley + g <- viewGalley c <- view tsCannon (owner, tid) <- Util.createBindingTeam member <- Util.addUserToTeamWithRole (Just RoleAdmin) owner tid @@ -1698,7 +1698,7 @@ testUpdateTeamMember = do testUpdateTeamStatus :: TestM () testUpdateTeamStatus = do - g <- view tsGalley + g <- viewGalley (_, tid) <- Util.createBindingTeam -- Check for idempotency Util.changeTeamStatus tid TeamsIntra.Active diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index b2324c7c3e6..cf56f46ddd0 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -335,14 +335,14 @@ testSearchVisibility :: TestM () testSearchVisibility = do let getTeamSearchVisibility :: TeamId -> UserId -> Public.FeatureStatus -> TestM () getTeamSearchVisibility teamid uid expected = do - g <- view tsGalley + g <- viewGalley getTeamSearchVisibilityAvailable g uid teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.WithStatusNoLock expected Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited)) let getTeamSearchVisibilityInternal :: TeamId -> Public.FeatureStatus -> TestM () getTeamSearchVisibilityInternal teamid expected = do - g <- view tsGalley + g <- viewGalley getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.WithStatusNoLock expected Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited)) @@ -354,7 +354,7 @@ testSearchVisibility = do let setTeamSearchVisibilityInternal :: TeamId -> Public.FeatureStatus -> TestM () setTeamSearchVisibilityInternal teamid val = do - g <- view tsGalley + g <- viewGalley putTeamSearchVisibilityAvailableInternal g teamid val (owner, tid, [member]) <- createBindingTeamWithNMembers 1 @@ -715,7 +715,7 @@ testSimpleFlagWithLockStatus :: Public.LockStatus -> TestM () testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do - galley <- view tsGalley + galley <- viewGalley (owner, tid, member : _) <- createBindingTeamWithNMembers 1 nonMember <- randomUser @@ -826,7 +826,7 @@ testSelfDeletingMessages = do liftIO $ result @?= settingWithLockStatus FeatureStatusEnabled 0 defLockStatus -- team users - galley <- view tsGalley + galley <- viewGalley (owner, tid, []) <- createBindingTeamWithNMembers 0 let checkSet :: FeatureStatus -> Int32 -> Int -> TestM () @@ -893,7 +893,7 @@ testSelfDeletingMessages = do testGuestLinksInternal :: TestM () testGuestLinksInternal = do - galley <- view tsGalley + galley <- viewGalley testGuestLinks (const $ getTeamFeatureFlagInternal @Public.GuestLinksConfig) (const $ putTeamFeatureFlagInternal @Public.GuestLinksConfig galley) @@ -901,7 +901,7 @@ testGuestLinksInternal = do testGuestLinksPublic :: TestM () testGuestLinksPublic = do - galley <- view tsGalley + galley <- viewGalley testGuestLinks (getTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) (putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley) @@ -966,7 +966,7 @@ testAllFeatures = do -- This block catches potential errors in the logic that reverts to default if there is a disinction made between -- 1. there is no row for a team_id in galley.team_features -- 2. there is a row for team_id in galley.team_features but the feature has a no entry (null value) - galley <- view tsGalley + galley <- viewGalley -- this sets the guest links config to its default value thereby creating a row for the team in galley.team_features putTeamFeatureFlagInternal @Public.GuestLinksConfig galley tid (Public.WithStatusNoLock FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! statusCode === const 200 @@ -1074,7 +1074,7 @@ testMLS :: TestM () testMLS = do (owner, tid, member : _) <- createBindingTeamWithNMembers 1 - galley <- view tsGalley + galley <- viewGalley cannon <- view tsCannon let getForTeam :: HasCallStack => Public.WithStatusNoLock MLSConfig -> TestM () @@ -1146,7 +1146,7 @@ testExposeInvitationURLsToTeamAdminTeamIdInAllowList = do assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - g <- view tsGalley + g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled Public.LockStatusUnlocked let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig Public.FeatureTTLUnlimited void $ @@ -1161,7 +1161,7 @@ testExposeInvitationURLsToTeamAdminEmptyAllowList = do assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist .~ Nothing) $ do - g <- view tsGalley + g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled Public.LockStatusLocked let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig Public.FeatureTTLUnlimited void $ @@ -1182,7 +1182,7 @@ testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do assertQueue "create team" tActivate void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - g <- view tsGalley + g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled Public.LockStatusUnlocked let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig Public.FeatureTTLUnlimited void $ @@ -1191,7 +1191,7 @@ testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusEnabled Public.LockStatusUnlocked void $ withSettingsOverrides (\opts -> opts & optSettings . setExposeInvitationURLsTeamAllowlist .~ Nothing) $ do - g <- view tsGalley + g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled Public.LockStatusLocked let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig Public.FeatureTTLUnlimited void $ @@ -1201,7 +1201,7 @@ testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do assertExposeInvitationURLsToTeamAdminConfigStatus :: UserId -> TeamId -> FeatureStatus -> LockStatus -> TestM () assertExposeInvitationURLsToTeamAdminConfigStatus owner tid fStatus lStatus = do - g <- view tsGalley + g <- viewGalley Util.getTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid !!! do const 200 === statusCode const (Right (Public.withStatus fStatus lStatus Public.ExposeInvitationURLsToTeamAdminConfig Public.FeatureTTLUnlimited)) === responseJsonEither diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 115b547161d..55b1f9f630e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -671,7 +671,7 @@ testGetTeamMembersIncludesLHStatus = do testInWhitelist :: TestM () testInWhitelist = do - g <- view tsGalley + g <- viewGalley (owner, tid) <- createBindingTeam member <- randomUser addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing @@ -826,7 +826,7 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect regularClient <- randomClient legalholder (head someLastPrekeys) peer :: UserId <- if teamPeer then fst <$> createBindingTeam else randomUser - galley <- view tsGalley + galley <- viewGalley putLHWhitelistTeam tid !!! const 200 === statusCode @@ -966,7 +966,7 @@ testNoConsentRemoveFromGroupConv whoIsAdmin = do qLegalHolder <- Qualified legalholder <$> viewFederationDomain (peer :: UserId, teamPeer) <- createBindingTeam qPeer <- Qualified peer <$> viewFederationDomain - galley <- view tsGalley + galley <- viewGalley let enableLHForLegalholder :: HasCallStack => TestM () enableLHForLegalholder = do @@ -1058,7 +1058,7 @@ testGroupConvInvitationHandlesLHConflicts inviteCase = do -- activate legalhold for legalholder do - galley <- view tsGalley + galley <- viewGalley requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid @@ -1108,7 +1108,7 @@ testNoConsentCannotBeInvited = do -- activate legalhold for legalholder do - galley <- view tsGalley + galley <- viewGalley requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid @@ -1147,7 +1147,7 @@ testCannotCreateGroupWithUsersInConflict = do -- activate legalhold for legalholder do - galley <- view tsGalley + galley <- viewGalley requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid @@ -1267,7 +1267,7 @@ testBenchHack' :: HasCallStack => Int -> TestM (Int, Time.NominalDiffTime) testBenchHack' numPeers = do (legalholder :: UserId, tid) <- createBindingTeam peers :: [UserId] <- replicateM numPeers randomUser - galley <- view tsGalley + galley <- viewGalley let doEnableLH :: HasCallStack => TestM () doEnableLH = do @@ -1305,7 +1305,7 @@ testBenchHack' numPeers = do getEnabled :: HasCallStack => TeamId -> TestM ResponseLBS getEnabled tid = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] @@ -1321,7 +1321,7 @@ renewToken tok = do _putEnabled :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () _putEnabled tid enabled = do - g <- view tsGalley + g <- viewGalley putEnabledM g tid enabled putEnabledM :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> Public.FeatureStatus -> m () @@ -1329,7 +1329,7 @@ putEnabledM g tid enabled = void $ putEnabledM' g expect2xx tid enabled putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> TestM ResponseLBS putEnabled' extra tid enabled = do - g <- view tsGalley + g <- viewGalley putEnabledM' g extra tid enabled putEnabledM' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> m ResponseLBS @@ -1345,7 +1345,7 @@ postSettings uid tid new = -- Retry calls to this endpoint, on k8s it sometimes takes a while to establish a working -- connection. retrying policy only412 $ \_ -> do - g <- view tsGalley + g <- viewGalley post $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -1364,7 +1364,7 @@ getSettingsTyped uid tid = responseJsonUnsafe <$> (getSettings uid tid UserId -> TeamId -> TestM ResponseLBS getSettings uid tid = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -1374,7 +1374,7 @@ getSettings uid tid = do deleteSettings :: HasCallStack => Maybe PlainTextPassword -> UserId -> TeamId -> TestM ResponseLBS deleteSettings mPassword uid tid = do - g <- view tsGalley + g <- viewGalley delete $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -1385,7 +1385,7 @@ deleteSettings mPassword uid tid = do getUserStatusTyped :: HasCallStack => UserId -> TeamId -> TestM UserLegalHoldStatusResponse getUserStatusTyped uid tid = do - g <- view tsGalley + g <- viewGalley getUserStatusTyped' g uid tid getUserStatusTyped' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => GalleyR -> UserId -> TeamId -> m UserLegalHoldStatusResponse @@ -1404,7 +1404,7 @@ getUserStatus' g uid tid = do approveLegalHoldDevice :: HasCallStack => Maybe PlainTextPassword -> UserId -> UserId -> TeamId -> TestM ResponseLBS approveLegalHoldDevice mPassword zusr uid tid = do - g <- view tsGalley + g <- viewGalley approveLegalHoldDevice' g mPassword zusr uid tid approveLegalHoldDevice' :: @@ -1432,7 +1432,7 @@ disableLegalHoldForUser :: UserId -> TestM ResponseLBS disableLegalHoldForUser mPassword tid zusr uid = do - g <- view tsGalley + g <- viewGalley disableLegalHoldForUser' g mPassword tid zusr uid disableLegalHoldForUser' :: @@ -1476,7 +1476,7 @@ assertZeroLegalHoldDevices uid = do requestLegalHoldDevice :: HasCallStack => UserId -> UserId -> TeamId -> TestM ResponseLBS requestLegalHoldDevice zusr uid tid = do - g <- view tsGalley + g <- viewGalley requestLegalHoldDevice' g zusr uid tid requestLegalHoldDevice' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> UserId -> UserId -> TeamId -> m ResponseLBS @@ -1814,7 +1814,7 @@ assertMatchChan c match = go [] getLHWhitelistedTeam :: HasCallStack => TeamId -> TestM ResponseLBS getLHWhitelistedTeam tid = do - galley <- view tsGalley + galley <- viewGalley getLHWhitelistedTeam' galley tid getLHWhitelistedTeam' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> m ResponseLBS @@ -1826,7 +1826,7 @@ getLHWhitelistedTeam' g tid = do putLHWhitelistTeam :: HasCallStack => TeamId -> TestM ResponseLBS putLHWhitelistTeam tid = do - galley <- view tsGalley + galley <- viewGalley putLHWhitelistTeam' galley tid putLHWhitelistTeam' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> m ResponseLBS @@ -1838,7 +1838,7 @@ putLHWhitelistTeam' g tid = do _deleteLHWhitelistTeam :: HasCallStack => TeamId -> TestM ResponseLBS _deleteLHWhitelistTeam tid = do - galley <- view tsGalley + galley <- viewGalley deleteLHWhitelistTeam' galley tid deleteLHWhitelistTeam' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> m ResponseLBS diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index f8e390259c1..a7b4977cb97 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -841,7 +841,7 @@ testClaimKeys testcase = do getEnabled :: HasCallStack => TeamId -> TestM ResponseLBS getEnabled tid = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] @@ -857,7 +857,7 @@ renewToken tok = do putEnabled :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () putEnabled tid enabled = do - g <- view tsGalley + g <- viewGalley putEnabledM g tid enabled putEnabledM :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> Public.FeatureStatus -> m () @@ -865,7 +865,7 @@ putEnabledM g tid enabled = void $ putEnabledM' g expect2xx tid enabled putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> TestM ResponseLBS putEnabled' extra tid enabled = do - g <- view tsGalley + g <- viewGalley putEnabledM' g extra tid enabled putEnabledM' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> m ResponseLBS @@ -881,7 +881,7 @@ postSettings uid tid new = -- Retry calls to this endpoint, on k8s it sometimes takes a while to establish a working -- connection. retrying policy only412 $ \_ -> do - g <- view tsGalley + g <- viewGalley post $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -900,7 +900,7 @@ getSettingsTyped uid tid = responseJsonUnsafe <$> (getSettings uid tid UserId -> TeamId -> TestM ResponseLBS getSettings uid tid = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -910,7 +910,7 @@ getSettings uid tid = do deleteSettings :: HasCallStack => Maybe PlainTextPassword -> UserId -> TeamId -> TestM ResponseLBS deleteSettings mPassword uid tid = do - g <- view tsGalley + g <- viewGalley delete $ g . paths ["teams", toByteString' tid, "legalhold", "settings"] @@ -921,7 +921,7 @@ deleteSettings mPassword uid tid = do getUserStatusTyped :: HasCallStack => UserId -> TeamId -> TestM UserLegalHoldStatusResponse getUserStatusTyped uid tid = do - g <- view tsGalley + g <- viewGalley getUserStatusTyped' g uid tid getUserStatusTyped' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => GalleyR -> UserId -> TeamId -> m UserLegalHoldStatusResponse @@ -940,7 +940,7 @@ getUserStatus' g uid tid = do approveLegalHoldDevice :: HasCallStack => Maybe PlainTextPassword -> UserId -> UserId -> TeamId -> TestM ResponseLBS approveLegalHoldDevice mPassword zusr uid tid = do - g <- view tsGalley + g <- viewGalley approveLegalHoldDevice' g mPassword zusr uid tid approveLegalHoldDevice' :: @@ -968,7 +968,7 @@ disableLegalHoldForUser :: UserId -> TestM ResponseLBS disableLegalHoldForUser mPassword tid zusr uid = do - g <- view tsGalley + g <- viewGalley disableLegalHoldForUser' g mPassword tid zusr uid disableLegalHoldForUser' :: @@ -1012,7 +1012,7 @@ assertZeroLegalHoldDevices uid = do grantConsent :: HasCallStack => TeamId -> UserId -> TestM () grantConsent tid zusr = do - g <- view tsGalley + g <- viewGalley grantConsent' g tid zusr grantConsent' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> UserId -> m () @@ -1030,7 +1030,7 @@ grantConsent'' expectation g tid zusr = do requestLegalHoldDevice :: HasCallStack => UserId -> UserId -> TeamId -> TestM ResponseLBS requestLegalHoldDevice zusr uid tid = do - g <- view tsGalley + g <- viewGalley requestLegalHoldDevice' g zusr uid tid requestLegalHoldDevice' :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> UserId -> UserId -> TeamId -> m ResponseLBS diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index d486dee0f72..97adfcc5be2 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -143,7 +143,7 @@ class HasGalley m where viewGalleyOpts :: m Opts.Opts instance HasGalley TestM where - viewGalley = view tsGalley + viewGalley = view tsUnversionedGalley viewGalleyOpts = view tsGConf instance (HasGalley m, Monad m) => HasGalley (SessionT m) where @@ -189,7 +189,7 @@ createBindingTeamWithQualifiedMembers num = do getTeams :: UserId -> [(ByteString, Maybe ByteString)] -> TestM TeamList getTeams u queryItems = do - g <- view tsGalley + g <- viewGalley r <- get ( g @@ -236,7 +236,7 @@ createBindingTeamWithNMembersWithHandles withHandles n = do changeTeamStatus :: HasCallStack => TeamId -> TeamStatus -> TestM () changeTeamStatus tid s = do - g <- view tsGalley + g <- viewGalley put ( g . paths ["i", "teams", toByteString' tid, "status"] . json (TeamStatusUpdate s Nothing) @@ -252,7 +252,7 @@ createBindingTeamInternal name owner = do createBindingTeamInternalNoActivate :: HasCallStack => Text -> UserId -> TestM TeamId createBindingTeamInternalNoActivate name owner = do - g <- view tsGalley + g <- viewGalley tid <- randomId let nt = BindingNewTeam $ newNewTeam (unsafeRange name) DefaultIcon _ <- @@ -263,7 +263,7 @@ createBindingTeamInternalNoActivate name owner = do createBindingTeamInternalWithCurrency :: HasCallStack => Text -> UserId -> Currency.Alpha -> TestM TeamId createBindingTeamInternalWithCurrency name owner cur = do - g <- view tsGalley + g <- viewGalley tid <- createBindingTeamInternalNoActivate name owner _ <- put (g . paths ["i", "teams", toByteString' tid, "status"] . json (TeamStatusUpdate Active $ Just cur)) @@ -272,39 +272,39 @@ createBindingTeamInternalWithCurrency name owner cur = do getTeamInternal :: HasCallStack => TeamId -> TestM TeamData getTeamInternal tid = do - g <- view tsGalley + g <- viewGalley r <- get (g . paths ["i/teams", toByteString' tid]) UserId -> TeamId -> TestM Team getTeam usr tid = do - g <- view tsGalley + g <- viewGalley r <- get (g . paths ["teams", toByteString' tid] . zUser usr) UserId -> TeamId -> TestM TeamMemberList getTeamMembers usr tid = do - g <- view tsGalley + g <- viewGalley r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr) UserId -> TeamId -> TestM ResponseLBS getTeamMembersCsv usr tid = do - g <- view tsGalley + g <- viewGalley get (g . accept "text/csv" . paths ["teams", toByteString' tid, "members/csv"] . zUser usr) UserId -> TeamId -> Int -> TestM TeamMemberList getTeamMembersTruncated usr tid n = do - g <- view tsGalley + g <- viewGalley r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr . queryItem "maxResults" (C.pack $ show n)) TeamId -> Int -> TestM TeamMemberList getTeamMembersInternalTruncated tid n = do - g <- view tsGalley + g <- viewGalley r <- get ( g @@ -317,7 +317,7 @@ getTeamMembersInternalTruncated tid n = do bulkGetTeamMembers :: HasCallStack => UserId -> TeamId -> [UserId] -> TestM TeamMemberList bulkGetTeamMembers usr tid uids = do - g <- view tsGalley + g <- viewGalley r <- post ( g @@ -331,7 +331,7 @@ bulkGetTeamMembers usr tid uids = do bulkGetTeamMembersTruncated :: HasCallStack => UserId -> TeamId -> [UserId] -> Int -> TestM ResponseLBS bulkGetTeamMembersTruncated usr tid uids trnc = do - g <- view tsGalley + g <- viewGalley post ( g . paths ["teams", toByteString' tid, "get-members-by-ids-using-post"] @@ -342,7 +342,7 @@ bulkGetTeamMembersTruncated usr tid uids trnc = do getTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestM TeamMember getTeamMember getter tid gettee = do - g <- view tsGalley + g <- viewGalley getTeamMember' g getter tid gettee getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => GalleyR -> UserId -> TeamId -> UserId -> m TeamMember @@ -352,13 +352,13 @@ getTeamMember' g getter tid gettee = do getTeamMemberInternal :: HasCallStack => TeamId -> UserId -> TestM TeamMember getTeamMemberInternal tid mid = do - g <- view tsGalley + g <- viewGalley r <- get (g . paths ["i", "teams", toByteString' tid, "members", toByteString' mid]) UserId -> TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () addTeamMember usr tid muid mperms mmbinv = do - g <- view tsGalley + g <- viewGalley let payload = json (mkNewTeamMember muid mperms mmbinv) post (g . paths ["teams", toByteString' tid, "members"] . zUser usr . zConn "conn" . payload) !!! const 200 === statusCode @@ -370,7 +370,7 @@ addTeamMemberInternal tid muid mperms mmbinv = addTeamMemberInternal' tid muid m -- | FUTUREWORK: do not use this, it's broken!! use 'addUserToTeam' instead! https://wearezeta.atlassian.net/browse/SQSERVICES-471 addTeamMemberInternal' :: HasCallStack => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM ResponseLBS addTeamMemberInternal' tid muid mperms mmbinv = do - g <- view tsGalley + g <- viewGalley let payload = json (mkNewTeamMember muid mperms mmbinv) post (g . paths ["i", "teams", toByteString' tid, "members"] . payload) @@ -417,7 +417,7 @@ addUserToTeamWithSSO hasEmail tid = do makeOwner :: HasCallStack => UserId -> TeamMember -> TeamId -> TestM () makeOwner owner mem tid = do - galley <- view tsGalley + galley <- viewGalley let changeMember = mkNewTeamMember (mem ^. Team.userId) fullPermissions (mem ^. Team.invitation) put ( galley @@ -483,7 +483,7 @@ getInvitationCode t ref = do -- it clearly shows the API that old(er) clients use. createTeamConvLegacy :: HasCallStack => UserId -> TeamId -> [UserId] -> Maybe Text -> TestM ConvId createTeamConvLegacy u tid us name = do - g <- view tsGalley + g <- viewGalley let tinfo = ConvTeamInfo tid let convPayload = object @@ -550,7 +550,7 @@ createTeamConvAccessRaw :: Maybe RoleName -> TestM ResponseLBS createTeamConvAccessRaw u tid us name acc role mtimer convRole = do - g <- view tsGalley + g <- viewGalley let tinfo = ConvTeamInfo tid let conv = NewConv us [] (name >>= checked) (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) ProtocolProteusTag Nothing @@ -606,7 +606,7 @@ createMLSTeamConv lusr c tid users name access role timer convRole = do updateTeamConv :: UserId -> ConvId -> ConversationRename -> TestM ResponseLBS updateTeamConv zusr convid upd = do - g <- view tsGalley + g <- viewGalley put ( g . paths ["/conversations", toByteString' convid] @@ -618,7 +618,7 @@ updateTeamConv zusr convid upd = do createOne2OneTeamConv :: UserId -> UserId -> Maybe Text -> TeamId -> TestM ResponseLBS createOne2OneTeamConv u1 u2 n tid = do - g <- view tsGalley + g <- viewGalley let conv = NewConv [u2] [] (n >>= checked) mempty Nothing (Just $ ConvTeamInfo tid) Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv @@ -674,7 +674,7 @@ postConvWithRemoteUsers u n = postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do - g <- view tsGalley + g <- viewGalley let conv = NewConv us [] (name >>= checked) (Set.fromList a) r (Just (ConvTeamInfo tid)) mtimer Nothing roleNameWireAdmin ProtocolProteusTag Nothing post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv @@ -711,25 +711,25 @@ postConvWithRole u members name access arole timer role = postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do - g <- view tsGalley + g <- viewGalley let conv = NewConv us [] (name >>= checked) (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin ProtocolProteusTag Nothing post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postSelfConv :: UserId -> TestM ResponseLBS postSelfConv u = do - g <- view tsGalley + g <- viewGalley post $ g . path "/conversations/self" . zUser u . zConn "conn" . zType "access" postO2OConv :: UserId -> UserId -> Maybe Text -> TestM ResponseLBS postO2OConv u1 u2 n = do - g <- view tsGalley + g <- viewGalley let conv = NewConv [u2] [] (n >>= checked) mempty Nothing Nothing Nothing Nothing roleNameWireAdmin ProtocolProteusTag Nothing post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS postConnectConv a b name msg email = do qb <- Qualified b <$> viewFederationDomain - g <- view tsGalley + g <- viewGalley post $ g . path "/i/conversations/connect" @@ -740,7 +740,7 @@ postConnectConv a b name msg email = do putConvAccept :: UserId -> ConvId -> TestM ResponseLBS putConvAccept invited cid = do - g <- view tsGalley + g <- viewGalley put $ g . paths ["/i/conversations", C.pack $ show cid, "accept", "v2"] @@ -766,7 +766,7 @@ postOtrMessage' :: [(UserId, ClientId, Text)] -> TestM ResponseLBS postOtrMessage' reportMissing f u d c rec = do - g <- view tsGalley + g <- viewGalley post $ g . f @@ -906,7 +906,7 @@ postProtoOtrMessage = postProtoOtrMessage' Nothing id postProtoOtrMessage' :: Maybe [UserId] -> (Request -> Request) -> UserId -> ClientId -> ConvId -> OtrRecipients -> TestM ResponseLBS postProtoOtrMessage' reportMissing modif u d c rec = do - g <- view tsGalley + g <- viewGalley let m = runPut (encodeMessage $ mkOtrProtoMessage d rec reportMissing "ZXhhbXBsZQ==") in post $ g @@ -929,7 +929,7 @@ mkOtrProtoMessage sender rec reportMissing ad = getConvs :: UserId -> Maybe (Either [ConvId] ConvId) -> Maybe Int32 -> TestM ResponseLBS getConvs u r s = do - g <- view tsGalley + g <- viewGalley get $ g . path "/conversations" @@ -971,7 +971,7 @@ getConvQualified u (Qualified conv domain) = do getConvIds :: UserId -> Maybe (Either [ConvId] ConvId) -> Maybe Int32 -> TestM ResponseLBS getConvIds u r s = do - g <- view tsGalley + g <- viewGalley get $ g . path "/conversations/ids" @@ -982,7 +982,7 @@ getConvIds u r s = do listConvIds :: UserId -> GetPaginatedConversationIds -> TestM ResponseLBS listConvIds u paginationOpts = do - g <- view tsGalley + g <- viewGalley post $ g . path "/conversations/list-ids" @@ -1014,7 +1014,7 @@ postQualifiedMembers zusr invitees conv = do . json invite postMembers :: - (MonadIO m, MonadHttp m, MonadReader TestSetup m) => + (MonadIO m, MonadHttp m, HasGalley m) => UserId -> NonEmpty (Qualified UserId) -> Qualified ConvId -> @@ -1022,14 +1022,14 @@ postMembers :: postMembers u us c = postMembersWithRole u us c roleNameWireAdmin postMembersWithRole :: - (MonadIO m, MonadHttp m, MonadReader TestSetup m) => + (MonadIO m, MonadHttp m, HasGalley m) => UserId -> NonEmpty (Qualified UserId) -> Qualified ConvId -> RoleName -> m ResponseLBS postMembersWithRole u us c r = do - g <- view tsGalley + g <- viewGalley let i = InviteQualified us r post $ g @@ -1071,7 +1071,7 @@ deleteMemberQualified u1 (Qualified u2 u2Domain) (Qualified conv convDomain) = d getSelfMember :: UserId -> ConvId -> TestM ResponseLBS getSelfMember u c = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["conversations", toByteString' c, "self"] @@ -1081,7 +1081,7 @@ getSelfMember u c = do putMember :: UserId -> MemberUpdate -> Qualified ConvId -> TestM ResponseLBS putMember u m (Qualified c dom) = do - g <- view tsGalley + g <- viewGalley put $ g . paths ["conversations", toByteString' dom, toByteString' c, "self"] @@ -1116,7 +1116,7 @@ putOtherMemberQualified from to m c = do putOtherMember :: UserId -> UserId -> OtherMemberUpdate -> ConvId -> TestM ResponseLBS putOtherMember from to m c = do - g <- view tsGalley + g <- viewGalley put $ g . paths ["conversations", toByteString' c, "members", toByteString' to] @@ -1150,7 +1150,7 @@ putQualifiedConversationName u c n = do putConversationName :: UserId -> ConvId -> Text -> TestM ResponseLBS putConversationName u c n = do - g <- view tsGalley + g <- viewGalley let update = ConversationRename n put ( g @@ -1181,7 +1181,7 @@ putQualifiedReceiptMode u (Qualified c dom) r = do putReceiptMode :: UserId -> ConvId -> ReceiptMode -> TestM ResponseLBS putReceiptMode u c r = do - g <- view tsGalley + g <- viewGalley let update = ConversationReceiptModeUpdate r put ( g @@ -1194,7 +1194,7 @@ putReceiptMode u c r = do getJoinCodeConv :: UserId -> Code.Key -> Code.Value -> TestM ResponseLBS getJoinCodeConv u k v = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["/conversations", "join"] @@ -1204,7 +1204,7 @@ getJoinCodeConv u k v = do postJoinConv :: UserId -> ConvId -> TestM ResponseLBS postJoinConv u c = do - g <- view tsGalley + g <- viewGalley post $ g . paths ["/conversations", toByteString' c, "join"] @@ -1214,7 +1214,7 @@ postJoinConv u c = do postJoinCodeConv :: UserId -> ConversationCode -> TestM ResponseLBS postJoinCodeConv u j = do - g <- view tsGalley + g <- viewGalley post $ g . paths ["/conversations", "join"] @@ -1225,7 +1225,7 @@ postJoinCodeConv u j = do putAccessUpdate :: UserId -> ConvId -> ConversationAccessData -> TestM ResponseLBS putAccessUpdate u c acc = do - g <- view tsGalley + g <- viewGalley put $ g . paths ["/conversations", toByteString' c, "access"] @@ -1274,7 +1274,7 @@ putMessageTimerUpdateQualified u c acc = do putMessageTimerUpdate :: UserId -> ConvId -> ConversationMessageTimerUpdate -> TestM ResponseLBS putMessageTimerUpdate u c acc = do - g <- view tsGalley + g <- viewGalley put $ g . paths ["/conversations", toByteString' c, "message-timer"] @@ -1285,7 +1285,7 @@ putMessageTimerUpdate u c acc = do postConvCode :: UserId -> ConvId -> TestM ResponseLBS postConvCode u c = do - g <- view tsGalley + g <- viewGalley post $ g . paths ["/conversations", toByteString' c, "code"] @@ -1295,7 +1295,7 @@ postConvCode u c = do postConvCodeCheck :: ConversationCode -> TestM ResponseLBS postConvCodeCheck code = do - g <- view tsGalley + g <- viewGalley post $ g . path "/conversations/code-check" @@ -1303,7 +1303,7 @@ postConvCodeCheck code = do getConvCode :: UserId -> ConvId -> TestM ResponseLBS getConvCode u c = do - g <- view tsGalley + g <- viewGalley get $ g . paths ["/conversations", toByteString' c, "code"] @@ -1313,7 +1313,7 @@ getConvCode u c = do deleteConvCode :: UserId -> ConvId -> TestM ResponseLBS deleteConvCode u c = do - g <- view tsGalley + g <- viewGalley delete $ g . paths ["/conversations", toByteString' c, "code"] @@ -1355,7 +1355,7 @@ getTeamQueue zusr msince msize onlyLast = getTeamQueue' :: HasCallStack => UserId -> Maybe NotificationId -> Maybe Int -> Bool -> TestM ResponseLBS getTeamQueue' zusr msince msize onlyLast = do - g <- view tsGalley + g <- viewGalley get ( g . path "/teams/notifications" . zUser zusr @@ -1392,7 +1392,7 @@ registerRemoteConv convId originUser name othMembers = do getFeatureStatusMulti :: forall cfg. (IsFeatureConfig cfg, KnownSymbol (FeatureSymbol cfg)) => Multi.TeamFeatureNoConfigMultiRequest -> TestM ResponseLBS getFeatureStatusMulti req = do - g <- view tsGalley + g <- viewGalley post ( g . paths ["i", "features-multi-teams", featureNameBS @cfg] . json req @@ -2089,7 +2089,7 @@ isUserDeleted u = do isMember :: UserId -> ConvId -> TestM Bool isMember usr cnv = do - g <- view tsGalley + g <- viewGalley res <- get $ g @@ -2337,7 +2337,7 @@ instance HasSettingsOverrides TestM where runReaderT (runTestM action) ( ts - & tsGalley .~ Bilge.host "127.0.0.1" . Bilge.port port' + & tsUnversionedGalley .~ Bilge.host "127.0.0.1" . Bilge.port port' & tsFedGalleyClient .~ FedClient (ts ^. tsManager) (Endpoint "127.0.0.1" port') ) @@ -2349,7 +2349,7 @@ waitForMemberDeletion zusr tid uid = do assertFailure "Timed out waiting for member deletion" where loop = do - galley <- view tsGalley + galley <- viewGalley res <- get (galley . paths ["teams", toByteString' tid, "members", toByteString' uid] . zUser zusr) case statusCode res of 404 -> pure () @@ -2369,7 +2369,7 @@ deleteTeamMember g tid owner deletee = deleteTeam :: UserId -> TeamId -> TestM () deleteTeam owner tid = do - g <- view tsGalley + g <- viewGalley delete ( g . paths ["teams", toByteString' tid] @@ -2724,7 +2724,7 @@ assertJust Nothing = liftIO $ error "Expected Just, got Nothing" iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS iUpsertOne2OneConversation req = do - galley <- view tsGalley + galley <- viewGalley post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) createOne2OneConvWithRemote :: HasCallStack => Local UserId -> Remote UserId -> TestM () diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 5e62e7b77f9..b56ee21c1b4 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -20,7 +20,7 @@ module API.Util.TeamFeature where import API.Util (HasGalley (viewGalley), zUser) import qualified API.Util as Util import Bilge -import Control.Lens (view, (.~), (^?)) +import Control.Lens ((.~), (^?)) import Control.Monad.Catch (MonadThrow) import Data.Aeson (FromJSON, Result (Success), ToJSON, Value, fromJSON) import Data.Aeson.Lens @@ -129,7 +129,7 @@ getFeatureConfig uid = do getAllFeatureConfigs :: HasCallStack => UserId -> TestM ResponseLBS getAllFeatureConfigs uid = do - g <- view tsGalley + g <- viewGalley getAllFeatureConfigsWithGalley g uid getAllFeatureConfigsWithGalley :: (MonadIO m, MonadHttp m, HasCallStack) => (Request -> Request) -> UserId -> m ResponseLBS @@ -171,7 +171,7 @@ putTeamFeatureFlagInternalTTL :: Public.WithStatusNoLock cfg -> TestM ResponseLBS putTeamFeatureFlagInternalTTL reqmod tid status = do - g <- view tsGalley + g <- viewGalley putTeamFeatureFlagInternalWithGalleyAndMod @cfg g reqmod tid status putTeamFeatureFlagInternal :: @@ -186,7 +186,7 @@ putTeamFeatureFlagInternal :: Public.WithStatusNoLock cfg -> TestM ResponseLBS putTeamFeatureFlagInternal reqmod tid status = do - g <- view tsGalley + g <- viewGalley putTeamFeatureFlagInternalWithGalleyAndMod @cfg g reqmod tid status putTeamFeatureFlagInternalWithGalleyAndMod :: @@ -222,7 +222,7 @@ setLockStatusInternal :: Public.LockStatus -> TestM ResponseLBS setLockStatusInternal reqmod tid lockStatus = do - galley <- view tsGalley + galley <- viewGalley put $ galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' lockStatus] @@ -238,7 +238,7 @@ getFeatureStatusInternal :: TeamId -> TestM ResponseLBS getFeatureStatusInternal tid = do - galley <- view tsGalley + galley <- viewGalley get $ galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] @@ -255,7 +255,7 @@ patchFeatureStatusInternal :: Public.WithStatusPatch cfg -> TestM ResponseLBS patchFeatureStatusInternal tid reqBody = do - galley <- view tsGalley + galley <- viewGalley patch $ galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] @@ -274,7 +274,7 @@ patchFeatureStatusInternalWithMod :: Public.WithStatusPatch cfg -> TestM ResponseLBS patchFeatureStatusInternalWithMod reqmod tid reqBody = do - galley <- view tsGalley + galley <- viewGalley patch $ galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 9dcae5c3143..40438cefe62 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -25,7 +25,7 @@ module TestSetup tsGConf, tsIConf, tsManager, - tsGalley, + tsUnversionedGalley, tsBrig, tsCannon, tsAwsEnv, @@ -112,7 +112,7 @@ data TestSetup = TestSetup { _tsGConf :: Opts, _tsIConf :: IntegrationConfig, _tsManager :: Manager, - _tsGalley :: GalleyR, + _tsUnversionedGalley :: GalleyR, _tsBrig :: BrigR, _tsCannon :: CannonR, _tsAwsEnv :: Maybe Aws.Env, From ab49fa1a504acab15a2f62c95cd7e2582210879a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Sep 2022 12:38:08 +0200 Subject: [PATCH 03/18] Add v2 prefix to all galley requests --- .../galley/test/integration/API/MLS/Util.hs | 2 +- services/galley/test/integration/API/Util.hs | 31 ++++++++++++------- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 436b7673f1b..645d78bef4a 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -110,7 +110,7 @@ postMessage :: postMessage sender msg = do galley <- viewGalley post - ( galley . paths ["v2", "mls", "messages"] + ( galley . paths ["mls", "messages"] . zUser sender . zConn "conn" . content "message/mls" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 97adfcc5be2..d258fdc4476 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -34,6 +34,7 @@ import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy @@ -79,6 +80,7 @@ import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra import Galley.Types.UserList import Imports +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Media.MediaType import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) @@ -120,7 +122,6 @@ import qualified Wire.API.Message.Proto as Proto import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi import Wire.API.Routes.MultiTablePaging -import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature import Wire.API.Team.Invitation @@ -143,7 +144,12 @@ class HasGalley m where viewGalleyOpts :: m Opts.Opts instance HasGalley TestM where - viewGalley = view tsUnversionedGalley + viewGalley = fmap (addPrefix .) (view tsUnversionedGalley) + where + addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} + removeSlash s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s viewGalleyOpts = view tsGConf instance (HasGalley m, Monad m) => HasGalley (SessionT m) where @@ -938,12 +944,16 @@ getConvs u r s = do . zType "access" . convRange r s -listConvs :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> ListConversations -> m ResponseLBS +listConvs :: + (MonadIO m, MonadHttp m, MonadReader TestSetup m) => + UserId -> + ListConversations -> + m ResponseLBS listConvs u req = do - g <- viewGalley + g <- view tsUnversionedGalley post $ g - . path "/conversations/list/v2" + . path "/v1/conversations/list/v2" . zUser u . zConn "conn" . zType "access" @@ -997,17 +1007,17 @@ listRemoteConvs remoteDomain uid = do pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs postQualifiedMembers :: - (HasGalley m, MonadIO m, MonadHttp m) => + (MonadReader TestSetup m, MonadIO m, MonadHttp m) => UserId -> NonEmpty (Qualified UserId) -> ConvId -> m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- viewGalley + g <- view tsUnversionedGalley let invite = InviteQualified invitees roleNameWireAdmin post $ g - . paths ["conversations", toByteString' conv, "members", "v2"] + . paths ["v1", "conversations", toByteString' conv, "members", "v2"] . zUser zusr . zConn "conn" . zType "access" @@ -1034,8 +1044,7 @@ postMembersWithRole u us c r = do post $ g . paths - [ v2, - "conversations", + [ "conversations", toByteString' (qDomain c), toByteString' (qUnqualified c), "members" @@ -1044,8 +1053,6 @@ postMembersWithRole u us c r = do . zConn "conn" . zType "access" . json i - where - v2 = toByteString' (toLower <$> show V2) deleteMemberQualified :: (HasCallStack, MonadIO m, MonadHttp m, HasGalley m) => From e79c5caf2a926c7acba3f750376b06d0f56ec901 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Sep 2022 16:01:14 +0200 Subject: [PATCH 04/18] Add v2 prefix to all brig requests --- services/galley/test/integration/API.hs | 8 +- .../galley/test/integration/API/MLS/Util.hs | 11 ++- services/galley/test/integration/API/Teams.hs | 10 +- .../test/integration/API/Teams/LegalHold.hs | 4 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 4 +- services/galley/test/integration/API/Util.hs | 98 ++++++++++--------- services/galley/test/integration/TestSetup.hs | 4 +- 7 files changed, 75 insertions(+), 64 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index bad7f34aeb5..f8d9b3092f9 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -441,7 +441,6 @@ postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do -- This test verifies basic mismatch behavior of the the JSON endpoint. postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson :: TestM () postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do - b <- view tsBrig (alice, ac) <- randomUserWithClient (head someLastPrekeys) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) @@ -455,8 +454,9 @@ postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do assertMismatchWithMessage (Just "client mismatch") [(eve, Set.singleton ec)] [] [] let x = responseJsonUnsafeWithMsg "ClientMismatch" r1 -- Fetch all missing clients prekeys + b <- view tsUnversionedBrig r2 <- - post (b . zUser alice . path "/users/prekeys" . json (missingClients x)) + post (b . zUser alice . path "v1/users/prekeys" . json (missingClients x)) @@ -273,7 +276,7 @@ createLocalMLSClient (qUntagged -> qusr) = do -- set public key pkey <- mlscli qcid ["public-key"] Nothing - brig <- view tsBrig + brig <- viewBrig let update = defUpdateClient {updateClientMLSPublicKeys = Map.singleton Ed25519 pkey} put ( brig @@ -305,7 +308,7 @@ uploadNewKeyPackage qcid = do (kp, _) <- generateKeyPackage qcid -- upload key package - brig <- view tsBrig + brig <- viewBrig post ( brig . paths ["mls", "key-packages", "self", toByteString' . ciClient $ qcid] @@ -437,7 +440,7 @@ keyPackageFile qcid ref = claimLocalKeyPackages :: HasCallStack => ClientIdentity -> Local UserId -> MLSTest KeyPackageBundle claimLocalKeyPackages qcid lusr = do - brig <- view tsBrig + brig <- viewBrig responseJsonError =<< post ( brig @@ -460,7 +463,7 @@ getUserClients qusr = do -- | Generate one key package for each client of a remote user claimRemoteKeyPackages :: HasCallStack => Remote UserId -> MLSTest KeyPackageBundle claimRemoteKeyPackages (qUntagged -> qusr) = do - brig <- view tsBrig + brig <- viewBrig clients <- getUserClients qusr bundle <- fmap (KeyPackageBundle . Set.fromList) $ for clients $ \cid -> do diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 5765f83b3c8..353280ac05d 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -302,7 +302,7 @@ testListTeamMembersCsv numMembers = do addClient :: UserId -> Int -> TestM () addClient uid i = do - brig <- view tsBrig + brig <- viewBrig post (brig . paths ["i", "clients", toByteString' uid] . contentJson . json (newClient (someLastPrekeys !! i)) . queryItem "skip_reauth" "true") !!! const 201 === statusCode newClient :: PC.LastPrekey -> C.NewClient @@ -983,7 +983,7 @@ testDeleteBindingTeamNoMembers = do testDeleteBindingTeamMoreThanOneMember :: TestM () testDeleteBindingTeamMoreThanOneMember = do g <- viewGalley - b <- view tsBrig + b <- viewBrig c <- view tsCannon (alice, tid, members) <- Util.createBindingTeamWithNMembers 10 ensureQueueEmpty @@ -1116,7 +1116,7 @@ setFeatureLockStatus tid status = do generateVerificationCode :: Public.SendVerificationCode -> TestM () generateVerificationCode req = do - brig <- view tsBrig + brig <- viewBrig let js = RequestBodyLBS $ encode req post (brig . paths ["verification-code", "send"] . contentJson . body js) !!! const 200 === statusCode @@ -1128,7 +1128,7 @@ setTeamSndFactorPasswordChallenge tid status = do getVerificationCode :: UserId -> Public.VerificationAction -> TestM Code.Value getVerificationCode uid action = do - brig <- view tsBrig + brig <- viewBrig resp <- get (brig . paths ["i", "users", toByteString' uid, "verification-code", toByteString' action]) Bool -> UserId -> [UserId] -> TestM () modifyUserProfileAndExpectEvent expect target listeners = do c <- view tsCannon - b <- view tsBrig + b <- viewBrig WS.bracketRN c listeners $ \wsListeners -> do -- Do something let u = U.UserUpdate (Just $ U.Name "name") Nothing Nothing Nothing diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 55b1f9f630e..d4dde55c62e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -621,7 +621,7 @@ testCannotCreateLegalHoldDeviceOldAPI = do where tryout :: UserId -> TestM () tryout uid = do - brg <- view tsBrig + brg <- viewBrig let newClientBody = (newClient LegalHoldClientType (head someLastPrekeys)) { newClientPassword = Just defPassword @@ -1312,7 +1312,7 @@ getEnabled tid = do renewToken :: HasCallStack => Text -> TestM () renewToken tok = do - b <- view tsBrig + b <- viewBrig void . post $ b . paths ["access"] diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index a7b4977cb97..677895ad58d 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -633,7 +633,7 @@ testCannotCreateLegalHoldDeviceOldAPI = do where tryout :: UserId -> TestM () tryout uid = do - brg <- view tsBrig + brg <- viewBrig let newClientBody = (newClient LegalHoldClientType (head someLastPrekeys)) { newClientPassword = Just defPassword @@ -848,7 +848,7 @@ getEnabled tid = do renewToken :: HasCallStack => Text -> TestM () renewToken tok = do - b <- view tsBrig + b <- viewBrig void . post $ b . paths ["access"] diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index d258fdc4476..44a4e97f4aa 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -138,6 +138,13 @@ import Wire.API.User.Client.Prekey ------------------------------------------------------------------------------- -- API Operations +addPrefix :: Request -> Request +addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} + where + removeSlash s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s + -- | A class for monads with access to a Sem r instance class HasGalley m where viewGalley :: m GalleyR @@ -145,17 +152,18 @@ class HasGalley m where instance HasGalley TestM where viewGalley = fmap (addPrefix .) (view tsUnversionedGalley) - where - addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} - removeSlash s = case B8.uncons s of - Just ('/', s') -> s' - _ -> s viewGalleyOpts = view tsGConf instance (HasGalley m, Monad m) => HasGalley (SessionT m) where viewGalley = lift viewGalley viewGalleyOpts = lift viewGalleyOpts +class HasBrig m where + viewBrig :: m BrigR + +instance HasBrig TestM where + viewBrig = fmap (addPrefix .) (view tsUnversionedBrig) + symmPermissions :: [Perm] -> Permissions symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s) @@ -230,7 +238,7 @@ createBindingTeamWithNMembersWithHandles withHandles n = do setHandle :: UserId -> TestM () setHandle uid = when withHandles $ do - b <- view tsBrig + b <- viewBrig randomHandle <- mkRandomHandle put ( b @@ -400,7 +408,7 @@ addUserToTeamWithRole role inviter tid = do addUserToTeamWithRole' :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) addUserToTeamWithRole' role inviter tid = do - brig <- view tsBrig + brig <- viewBrig inviteeEmail <- randomEmail let invite = InvitationRequest Nothing role Nothing inviteeEmail Nothing invResponse <- postInvitation tid inviter invite @@ -447,7 +455,7 @@ acceptInviteBody email code = postInvitation :: TeamId -> UserId -> InvitationRequest -> TestM ResponseLBS postInvitation t u i = do - brig <- view tsBrig + brig <- viewBrig post $ brig . paths ["teams", toByteString' t, "invitations"] @@ -463,7 +471,7 @@ zAuthAccess u conn = getInvitationCode :: HasCallStack => TeamId -> InvitationId -> TestM InvitationCode getInvitationCode t ref = do - brig <- view tsBrig + brig <- viewBrig let getm :: TestM (Maybe InvitationCode) getm = do @@ -1826,13 +1834,13 @@ connectUsersWith :: connectUsersWith fn u = mapM connectTo where connectTo v = do - b <- view tsBrig + b <- view tsUnversionedBrig r1 <- post ( b . zUser u . zConn "conn" - . path "/connections" + . paths ["v1", "connections"] . json (ConnectionRequest v (unsafeRange "chat")) . fn ) @@ -1841,20 +1849,20 @@ connectUsersWith fn u = mapM connectTo ( b . zUser v . zConn "conn" - . paths ["connections", toByteString' u] + . paths ["v1", "connections", toByteString' u] . json (ConnectionUpdate Accepted) . fn ) pure (r1, r2) connectWithRemoteUser :: - (MonadReader TestSetup m, MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => + (HasBrig m, MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => UserId -> Qualified UserId -> m () connectWithRemoteUser self other = do let req = CreateConnectionForTest self other - b <- view tsBrig + b <- viewBrig put ( b . zUser self @@ -1869,10 +1877,10 @@ connectWithRemoteUser self other = do -- | A copy of 'postConnection' from Brig integration tests. postConnection :: UserId -> UserId -> TestM ResponseLBS postConnection from to = do - brig <- view tsBrig + brig <- view tsUnversionedBrig post $ brig - . path "/connections" + . paths ["v1", "connections"] . contentJson . body payload . zUser from @@ -1884,10 +1892,10 @@ postConnection from to = do postConnectionQualified :: UserId -> Qualified UserId -> TestM ResponseLBS postConnectionQualified from (Qualified toUser toDomain) = do - brig <- view tsBrig + brig <- viewBrig post $ brig - . paths ["/connections", toByteString' toDomain, toByteString' toUser] + . paths ["connections", toByteString' toDomain, toByteString' toUser] . contentJson . zUser from . zConn "conn" @@ -1895,10 +1903,10 @@ postConnectionQualified from (Qualified toUser toDomain) = do -- | A copy of 'putConnection' from Brig integration tests. putConnection :: UserId -> UserId -> Relation -> TestM ResponseLBS putConnection from to r = do - brig <- view tsBrig + brig <- view tsUnversionedBrig put $ brig - . paths ["/connections", toByteString' to] + . paths ["v1", "connections", toByteString' to] . contentJson . body payload . zUser from @@ -1916,10 +1924,10 @@ putConnectionQualified fromQualified to r = do "The qualified user's domain is not local" localDomain qualifiedDomain - brig <- view tsBrig + brig <- view tsUnversionedBrig put $ brig - . paths ["/connections", toByteString' to] + . paths ["v1", "connections", toByteString' to] . contentJson . body payload . zUser from @@ -1930,7 +1938,7 @@ putConnectionQualified fromQualified to r = do -- | A copy of `assertConnections from Brig integration tests. assertConnections :: HasCallStack => UserId -> [ConnectionStatus] -> TestM () assertConnections u cstat = do - brig <- view tsBrig + brig <- view tsUnversionedBrig resp <- listConnections brig u show cstat <> " is not a subset of " <> show cstat' where status c = ConnectionStatus (ucFrom c) (qUnqualified $ ucTo c) (ucStatus c) - listConnections brig usr = get $ brig . path "connections" . zUser usr + listConnections brig usr = get $ brig . paths ["v1", "connections"] . zUser usr randomUsers :: Int -> TestM [UserId] randomUsers n = replicateM n randomUser @@ -1971,7 +1979,7 @@ randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' is randomUserProfile' :: HasCallStack => Bool -> Bool -> Bool -> TestM SelfProfile randomUserProfile' isCreator hasPassword hasEmail = do - b <- view tsBrig + b <- viewBrig e <- liftIO randomEmail let p = object $ @@ -1983,7 +1991,7 @@ randomUserProfile' isCreator hasPassword hasEmail = do ephemeralUser :: HasCallStack => TestM UserId ephemeralUser = do - b <- view tsBrig + b <- viewBrig name <- UUID.toText <$> liftIO nextRandom let p = object ["name" .= name] r <- post (b . path "/register" . json p) UserId -> LastPrekey -> Maybe (Set Client.ClientCapability) -> TestM ClientId randomClientWithCaps uid lk caps = do - b <- view tsBrig + b <- viewBrig resp <- post ( b @@ -2022,18 +2030,18 @@ ensureDeletedState check from u = do getDeletedState :: HasCallStack => UserId -> UserId -> TestM (Maybe Bool) getDeletedState from u = do - b <- view tsBrig + b <- view tsUnversionedBrig fmap profileDeleted . responseJsonMaybe <$> get ( b - . paths ["users", toByteString' u] + . paths ["v1", "users", toByteString' u] . zUser from . zConn "conn" ) getClients :: UserId -> TestM ResponseLBS getClients u = do - b <- view tsBrig + b <- viewBrig get $ b . paths ["clients"] @@ -2042,7 +2050,7 @@ getClients u = do getInternalClientsFull :: UserSet -> TestM UserClientsFull getInternalClientsFull userSet = do - b <- view tsBrig + b <- viewBrig res <- post $ b @@ -2060,7 +2068,7 @@ ensureClientCaps uid cid caps = do -- TODO: Refactor, as used also in brig deleteClient :: UserId -> ClientId -> Maybe PlainTextPassword -> TestM ResponseLBS deleteClient u c pw = do - b <- view tsBrig + b <- viewBrig delete $ b . paths ["clients", toByteString' c] @@ -2078,7 +2086,7 @@ deleteClient u c pw = do -- TODO: Refactor, as used also in brig isUserDeleted :: HasCallStack => UserId -> TestM Bool isUserDeleted u = do - b <- view tsBrig + b <- viewBrig r <- get (b . paths ["i", "users", toByteString' u, "status"]) Bool -> UserSSOId -> TeamId -> TestM ResponseLBS postSSOUser name hasEmail ssoid teamid = do - brig <- view tsBrig + brig <- viewBrig email <- randomEmail let o = object $ @@ -2396,7 +2404,7 @@ getUsersByHandle = getUsersBy "handles" getUsersBy :: forall uidsOrHandles. (ToByteString uidsOrHandles) => ByteString -> [uidsOrHandles] -> TestM [User] getUsersBy keyName = chunkify $ \keys -> do - brig <- view tsBrig + brig <- viewBrig let users = BS.intercalate "," $ toByteString' <$> keys res <- get @@ -2410,8 +2418,8 @@ getUsersBy keyName = chunkify $ \keys -> do getUserProfile :: UserId -> UserId -> TestM UserProfile getUserProfile zusr uid = do - brig <- view tsBrig - res <- get (brig . zUser zusr . paths ["users", toByteString' uid]) + brig <- view tsUnversionedBrig + res <- get (brig . zUser zusr . paths ["v1", "users", toByteString' uid]) responseJsonError res upgradeClientToLH :: HasCallStack => UserId -> ClientId -> TestM () @@ -2420,7 +2428,7 @@ upgradeClientToLH zusr cid = putCapabilities :: HasCallStack => UserId -> ClientId -> [ClientCapability] -> TestM () putCapabilities zusr cid caps = do - brig <- view tsBrig + brig <- viewBrig void $ put ( brig @@ -2432,29 +2440,29 @@ putCapabilities zusr cid caps = do getUsersPrekeysClientUnqualified :: HasCallStack => UserId -> UserId -> ClientId -> TestM ResponseLBS getUsersPrekeysClientUnqualified zusr uid cid = do - brig <- view tsBrig + brig <- view tsUnversionedBrig get ( brig . zUser zusr - . paths ["users", toByteString' uid, "prekeys", toByteString' cid] + . paths ["v1", "users", toByteString' uid, "prekeys", toByteString' cid] ) getUsersPrekeyBundleUnqualified :: HasCallStack => UserId -> UserId -> TestM ResponseLBS getUsersPrekeyBundleUnqualified zusr uid = do - brig <- view tsBrig + brig <- view tsUnversionedBrig get ( brig . zUser zusr - . paths ["users", toByteString' uid, "prekeys"] + . paths ["v1", "users", toByteString' uid, "prekeys"] ) getMultiUserPrekeyBundleUnqualified :: HasCallStack => UserId -> UserClients -> TestM ResponseLBS getMultiUserPrekeyBundleUnqualified zusr userClients = do - brig <- view tsBrig + brig <- view tsUnversionedBrig post ( brig . zUser zusr - . paths ["users", "prekeys"] + . paths ["v1", "users", "prekeys"] . json userClients ) diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 40438cefe62..e01fc52b14c 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -26,7 +26,7 @@ module TestSetup tsIConf, tsManager, tsUnversionedGalley, - tsBrig, + tsUnversionedBrig, tsCannon, tsAwsEnv, tsMaxConvSize, @@ -113,7 +113,7 @@ data TestSetup = TestSetup _tsIConf :: IntegrationConfig, _tsManager :: Manager, _tsUnversionedGalley :: GalleyR, - _tsBrig :: BrigR, + _tsUnversionedBrig :: BrigR, _tsCannon :: CannonR, _tsAwsEnv :: Maybe Aws.Env, _tsMaxConvSize :: Word16, From 8c38ce08998fa56afca66e41ff1bf9a2f9d27883 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 19 Sep 2022 15:13:47 +0200 Subject: [PATCH 05/18] client tests --- .../brig/test/integration/API/User/Client.hs | 29 ++++++++------ .../brig/test/integration/API/User/Util.hs | 3 +- services/brig/test/integration/Main.hs | 33 ++++++++++----- services/brig/test/integration/Util.hs | 40 ++++++++++++++++++- 4 files changed, 79 insertions(+), 26 deletions(-) diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index ef2abc5109b..50bf88810ee 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -378,7 +378,8 @@ testListClientsBulk opts brig = do ] ) post - ( brig + ( apiVersion "v1" + . brig . paths ["users", "list-clients"] . zUser uid3 . contentJson @@ -418,7 +419,8 @@ testListClientsBulkV2 opts brig = do ] ) post - ( brig + ( apiVersion "v1" + . brig . paths ["users", "list-clients", "v2"] . zUser uid3 . contentJson @@ -456,12 +458,12 @@ generateClients n brig = do testGetUserPrekeys :: Brig -> Http () testGetUserPrekeys brig = do [(uid, _c, lpk, cpk)] <- generateClients 1 brig - get (brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do const 200 === statusCode const (Just $ PrekeyBundle uid [cpk]) === responseJsonMaybe -- prekeys are deleted when retrieved, except the last one replicateM_ 2 $ - get (brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do const 200 === statusCode const (Just $ PrekeyBundle uid [lpk]) === responseJsonMaybe @@ -482,7 +484,7 @@ testGetUserPrekeysInvalidDomain brig = do testGetClientPrekey :: Brig -> Http () testGetClientPrekey brig = do [(uid, c, _lpk, cpk)] <- generateClients 1 brig - get (brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do const 200 === statusCode const (Just $ cpk) === responseJsonMaybe @@ -512,7 +514,8 @@ testMultiUserGetPrekeys brig = do uid <- userId <$> randomUser brig post - ( brig + ( apiVersion "v1" + . brig . paths ["users", "prekeys"] . contentJson . body (RequestBodyLBS $ encode userClients) @@ -708,7 +711,7 @@ testUpdateClient opts brig = do newClientModel = Just "featurephone" } c <- responseJsonError =<< addClient brig uid clt - get (brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do const 200 === statusCode const (Just $ ClientPrekey (clientId c) (somePrekeys !! 0)) === responseJsonMaybe getClient brig uid (clientId c) !!! do @@ -731,7 +734,7 @@ testUpdateClient opts brig = do ) !!! const 200 === statusCode - get (brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) !!! do const 200 === statusCode const (Just $ ClientPrekey (clientId c) newPrekey) === responseJsonMaybe @@ -741,7 +744,7 @@ testUpdateClient opts brig = do const (Just "label") === (clientLabel <=< responseJsonMaybe) -- via `/users/:uid/clients/:client`, only `id` and `class` are visible: - get (brig . paths ["users", toByteString' uid, "clients", toByteString' (clientId c)]) !!! do + get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "clients", toByteString' (clientId c)]) !!! do const 200 === statusCode const (Just $ clientId c) === (fmap pubClientId . responseJsonMaybe) const (Just PhoneClient) === (pubClientClass <=< responseJsonMaybe) @@ -761,7 +764,8 @@ testUpdateClient opts brig = do -- empty update should be a no-op put - ( brig + ( apiVersion "v1" + . brig . paths ["clients", toByteString' (clientId c)] . zUser uid . contentJson @@ -780,7 +784,8 @@ testUpdateClient opts brig = do checkUpdate capsIn respStatusOk capsOut = do let update'' = defUpdateClient {updateClientCapabilities = Set.fromList <$> capsIn} put - ( brig + ( apiVersion "v1" + . brig . paths ["clients", toByteString' (clientId c)] . zUser uid . contentJson @@ -813,7 +818,7 @@ testUpdateClient opts brig = do flushClientPrekey = do responseJsonMaybe <$> ( get - (brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) + (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) Email -> (Bilge.Cookie, Brig.ZAuth.AccessToken) -> UserId -> (MonadIO m, MonadCatch m, MonadHttp m) => m ResponseLBS initiateEmailUpdateCreds brig email (cky, tok) uid = do put $ - brig + unversioned + . brig . path "/access/self/email" . cookie cky . header "Authorization" ("Bearer " <> toByteString' tok) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 3e51716247c..1b15638b14f 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -41,6 +41,7 @@ import qualified Brig.Options as Opts import Cassandra.Util (defInitCassandra) import Control.Lens import Data.Aeson +import qualified Data.ByteString.Char8 as B8 import Data.Metrics.Test (pathsConsistencyCheck) import Data.Metrics.WaiRoute (treeToPaths) import Data.Text.Encoding (encodeUtf8) @@ -48,6 +49,7 @@ import Data.Yaml (decodeFileEither) import qualified Federation.End2end import Imports hiding (local) import qualified Index.Create +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) @@ -104,18 +106,18 @@ instance FromJSON Config runTests :: Config -> Opts.Opts -> [String] -> IO () runTests iConf brigOpts otherArgs = do - let b = mkRequest $ brig iConf - c = mkRequest $ cannon iConf - gd = mkRequest $ gundeck iConf - ch = mkRequest $ cargohold iConf - g = mkRequest $ galley iConf - n = mkRequest $ nginz iConf - s = mkRequest $ spar iConf + let b = mkVersionedRequest $ brig iConf + c = mkVersionedRequest $ cannon iConf + gd = mkVersionedRequest $ gundeck iConf + ch = mkVersionedRequest $ cargohold iConf + g = mkVersionedRequest $ galley iConf + n = mkVersionedRequest $ nginz iConf + s = mkVersionedRequest $ spar iConf f = federatorInternal iConf - brigTwo = mkRequest $ remoteBrig (backendTwo iConf) - cannonTwo = mkRequest $ remoteCannon (backendTwo iConf) - galleyTwo = mkRequest $ remoteGalley (backendTwo iConf) - ch2 = mkRequest $ remoteCargohold (backendTwo iConf) + brigTwo = mkVersionedRequest $ remoteBrig (backendTwo iConf) + cannonTwo = mkVersionedRequest $ remoteCannon (backendTwo iConf) + galleyTwo = mkVersionedRequest $ remoteGalley (backendTwo iConf) + ch2 = mkVersionedRequest $ remoteCargohold (backendTwo iConf) let Opts.TurnServersFiles turnFile turnFileV2 = case Opts.serversSource $ Opts.turn brigOpts of Opts.TurnSourceFiles files -> files @@ -178,6 +180,15 @@ runTests iConf brigOpts otherArgs = do where mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p + mkVersionedRequest endpoint = addPrefix . mkRequest endpoint + + addPrefix :: Request -> Request + addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} + where + removeSlash s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s + parseEmailAWSOpts :: IO (Maybe Opts.EmailAWSOpts) parseEmailAWSOpts = case Opts.email . Opts.emailSMS $ brigOpts of (Opts.EmailAWS aws) -> pure (Just aws) diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index e832bb08b12..bfc0e98eb28 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -40,6 +40,7 @@ import Control.Exception (throw) import Control.Lens ((^.), (^?), (^?!)) import Control.Monad.Catch (MonadCatch, MonadMask) import qualified Control.Monad.Catch as Catch +import qualified Control.Monad.State as State import Control.Monad.State.Class (MonadState) import qualified Control.Monad.State.Class as MonadState import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) @@ -50,6 +51,7 @@ import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import Data.Domain (Domain (..), domainText, mkDomain) @@ -135,6 +137,38 @@ type Spar = Request -> Request data FedClient (comp :: Component) = FedClient HTTP.Manager Endpoint +-- | Note: Apply this function last when composing (Request -> Request) functions +apiVersion :: ByteString -> Request -> Request +apiVersion newVersion r = r {HTTP.path = setVersion newVersion (HTTP.path r)} + where + setVersion :: ByteString -> ByteString -> ByteString + setVersion v p = + let p' = removeSlash' p + in v <> "/" <> fromMaybe p' (removeVersionPrefix p') + +removeSlash' :: ByteString -> ByteString +removeSlash' s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s + +removeVersionPrefix :: ByteString -> Maybe ByteString +removeVersionPrefix bs = do + let (x, s) = C8.splitAt 1 bs + guard (x == C8.pack "v") + (_, s') <- C8.readInteger s + pure (C8.tail s') + +-- | Note: Apply this function last when composing (Request -> Request) functions +unversioned :: Request -> Request +unversioned r = + r + { HTTP.path = + maybe + (HTTP.path r) + (C8.pack "/" <>) + (removeVersionPrefix . removeSlash' $ HTTP.path r) + } + runFedClient :: forall (name :: Symbol) comp api. ( HasFedEndpoint comp api name, @@ -450,7 +484,8 @@ login :: Brig -> Login -> CookieType -> (MonadIO m, MonadHttp m) => m ResponseLB login b l t = let js = RequestBodyLBS (encode l) in post $ - b + unversioned + . b . path "/login" . contentJson . (if t == PersistentCookie then queryItem "persist" "true" else id) @@ -649,7 +684,8 @@ defNewClientWithVerificationCode mbCode ty pks lpk = getPreKey :: Brig -> UserId -> UserId -> ClientId -> Http ResponseLBS getPreKey brig zusr u c = get $ - brig + apiVersion "v1" + . brig . paths ["users", toByteString' u, "prekeys", toByteString' c] . zUser zusr From 168d9c7e1dca60f18daad4f6aa831988b8a6ec7c Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 19 Sep 2022 15:18:17 +0200 Subject: [PATCH 06/18] account tests --- .../brig/test/integration/API/User/Account.hs | 25 +++++++++++-------- .../brig/test/integration/API/User/Util.hs | 7 +++--- services/brig/test/integration/Util.hs | 9 ++++--- 3 files changed, 24 insertions(+), 17 deletions(-) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index eb579b44388..a88ada5d19b 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -589,11 +589,11 @@ testNonExistingUserUnqualified :: Brig -> Http () testNonExistingUserUnqualified brig = do findingOne <- liftIO $ Id <$> UUID.nextRandom foundOne <- liftIO $ Id <$> UUID.nextRandom - get (brig . paths ["users", pack $ show foundOne] . zUser findingOne) + get (apiVersion "v1" . brig . paths ["users", pack $ show foundOne] . zUser findingOne) !!! do const 404 === statusCode const (Just "not-found") === fmap Error.label . responseJsonMaybe - get (brig . paths ["users", pack $ show foundOne] . zUser foundOne) + get (apiVersion "v1" . brig . paths ["users", pack $ show foundOne] . zUser foundOne) !!! do const 404 === statusCode const (Just "not-found") === fmap Error.label . responseJsonMaybe @@ -605,11 +605,11 @@ testNonExistingUser brig = do uid2 <- liftIO $ Id <$> UUID.nextRandom let uid = qUnqualified qself domain = qDomain qself - get (brig . paths ["users", toByteString' domain, toByteString' uid1] . zUser uid) + get (apiVersion "v1" . brig . paths ["users", toByteString' domain, toByteString' uid1] . zUser uid) !!! do const 404 === statusCode const (Just "not-found") === fmap Error.label . responseJsonMaybe - get (brig . paths ["users", toByteString' domain, toByteString' uid2] . zUser uid) + get (apiVersion "v1" . brig . paths ["users", toByteString' domain, toByteString' uid2] . zUser uid) !!! do const 404 === statusCode const (Just "not-found") === fmap Error.label . responseJsonMaybe @@ -629,7 +629,7 @@ testUserInvalidDomain brig = do testExistingUserUnqualified :: Brig -> Http () testExistingUserUnqualified brig = do uid <- userId <$> randomUser brig - get (brig . paths ["users", pack $ show uid] . zUser uid) !!! do + get (apiVersion "v1" . brig . paths ["users", pack $ show uid] . zUser uid) !!! do const 200 === statusCode const (Just uid) === ( \r -> do @@ -643,7 +643,8 @@ testExistingUser brig = do let uid = qUnqualified quser domain = qDomain quser get - ( brig + ( apiVersion "v1" + . brig . zUser uid . paths [ "users", @@ -664,7 +665,8 @@ testUserExistsUnqualified brig = do qself <- userQualifiedId <$> randomUser brig quser <- userQualifiedId <$> randomUser brig head - ( brig + ( apiVersion "v1" + . brig . paths ["users", toByteString' (qUnqualified quser)] . zUser (qUnqualified qself) ) @@ -726,7 +728,8 @@ testMultipleUsersUnqualified brig = do (Just $ userDisplayName u3, Nothing) ] get - ( brig + ( apiVersion "v1" + . brig . zUser (userId u1) . contentJson . path "users" @@ -794,7 +797,7 @@ testCreateUserAnonExpiry b = do liftIO $ assertBool "Bob must be in deleted state" (fromMaybe False $ deleted resBob') where getProfile :: UserId -> UserId -> Http ResponseLBS - getProfile zusr uid = get (b . zUser zusr . paths ["users", toByteString' uid]) UserId -> UserId -> Http () awaitExpiry n zusr uid = do -- after expiration, a profile lookup should trigger garbage collection of ephemeral users @@ -818,7 +821,7 @@ testCreateUserAnonExpiry b = do field :: FromJSON a => Text -> Value -> Maybe a field f u = u ^? key f >>= maybeFromJSON -testUserUpdate :: Brig -> Cannon -> AWS.Env -> Http () +testUserUpdate :: HasCallStack => Brig -> Cannon -> AWS.Env -> Http () testUserUpdate brig cannon aws = do aliceUser <- randomUser brig liftIO $ Util.assertUserJournalQueue "user create alice" aws (userActivateJournaled aliceUser) @@ -1749,7 +1752,7 @@ execAndAssertUserDeletion brig cannon u hdl others aws execDelete = do Search.refreshIndex brig -- Does not appear in search; public profile shows the user as deleted forM_ others $ \usr -> do - get (brig . paths ["users", toByteString' uid] . zUser usr) !!! assertDeletedProfilePublic + get (apiVersion "v1" . brig . paths ["users", toByteString' uid] . zUser usr) !!! assertDeletedProfilePublic Search.assertCan'tFind brig usr quid (fromName (userDisplayName u)) Search.assertCan'tFind brig usr quid (fromHandle hdl) -- Email address is available again diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 942c1ffd791..73c80fc32d9 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -290,7 +290,8 @@ deleteClient brig u c pw = listConnections :: Brig -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS listConnections brig u = get $ - brig + apiVersion "v1" + . brig . path "connections" . zUser u @@ -453,7 +454,7 @@ uploadAsset c usr sts dat = do mpb = buildMultipartBody sts ct (LB.fromStrict dat) post ( c - . path "/assets/v3" + . path "/assets" . zUser usr . zConn "conn" . content "multipart/mixed" @@ -471,7 +472,7 @@ downloadAsset :: downloadAsset c usr ast = get ( c - . paths ["/assets/v4", toByteString' (qDomain ast), toByteString' (qUnqualified ast)] + . paths ["/assets", toByteString' (qDomain ast), toByteString' (qUnqualified ast)] . zUser usr . zConn "conn" ) diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index bfc0e98eb28..67db427ab4e 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -367,7 +367,8 @@ assertUpdateNotification ws uid upd = WS.assertMatch (5 # Second) ws $ \n -> do getConnection :: Brig -> UserId -> UserId -> Http ResponseLBS getConnection brig from to = get $ - brig + apiVersion "v1" + . brig . paths ["/connections", toByteString' to] . zUser from . zConn "conn" @@ -545,7 +546,8 @@ sendLoginCode b p typ force = postConnection :: Brig -> UserId -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS postConnection brig from to = post $ - brig + apiVersion "v1" + . brig . path "/connections" . contentJson . body payload @@ -568,7 +570,8 @@ postConnectionQualified brig from (Qualified toUser toDomain) = putConnection :: Brig -> UserId -> UserId -> Relation -> (MonadIO m, MonadHttp m) => m ResponseLBS putConnection brig from to r = put $ - brig + apiVersion "v1" + . brig . paths ["/connections", toByteString' to] . contentJson . body payload From 76d775b59e6e352ceb7f99156d00cd7c926e8098 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 19 Sep 2022 16:10:57 +0200 Subject: [PATCH 07/18] auth tests wip --- deploy/services-demo/conf/nginz/nginx.conf | 6 +- .../brig/test/integration/API/User/Auth.hs | 76 ++++++++++--------- 2 files changed, 42 insertions(+), 40 deletions(-) diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index f969a7e61c1..8dcbae109b2 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -226,7 +226,7 @@ http { ## brig authenticated endpoints - location /self { + location ~* (/v[0-9]+)?/self { include common_response_with_zauth.conf; proxy_pass http://brig; } @@ -261,7 +261,7 @@ http { proxy_pass http://brig; } - location /clients { + location ~* (/v[0-9]+)?/clients { include common_response_with_zauth.conf; proxy_pass http://brig; } @@ -454,7 +454,7 @@ http { proxy_pass http://gundeck; } - location /notifications { + location ~* (/v[0-9]+)?/notifications { include common_response_with_zauth.conf; proxy_pass http://gundeck; } diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 3bcdca313b5..0e49c654262 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -199,7 +199,7 @@ testNginz b n = do liftIO $ assertEqual "Ensure nginz is started. Ensure nginz and brig share the same private/public zauth keys. Ensure ACL file is correct." 200 (statusCode _rs) -- ensure nginz allows refresh at /access _rs <- - post (n . path "/access" . cookie c . header "Authorization" ("Bearer " <> toByteString' t)) toByteString' t)) toByteString' t)) !!! const 200 === statusCode @@ -233,7 +233,7 @@ testNginzLegalHold b g n = do =<< createConversation g (userId alice) [] toByteString' t)) !!! do + post (unversioned . n . path "/access" . cookie c . header "Authorization" ("Bearer " <> toByteString' t)) !!! do const 200 === statusCode -- ensure legalhold tokens CANNOT fetch /clients get (n . path "/clients" . header "Authorization" ("Bearer " <> toByteString' t)) !!! const 403 === statusCode @@ -274,16 +274,16 @@ testNginzMultipleCookies o b n = do badCookie2 <- (\c -> c {cookie_value = "SKsjKQbiqxuEugGMWVbq02fNEA7QFdNmTiSa1Y0YMgaEP5tWl3nYHWlIrM5F8Tt7Cfn2Of738C7oeiY8xzPHAC==.v=1.k=1.d=1.t=u.l=.u=13da31b4-c6bb-4561-8fed-07e728fa6cc5.r=f844b420"}) . decodeCookie <$> dologin -- Basic sanity checks - post (n . path "/access" . cookie goodCookie) !!! const 200 === statusCode - post (n . path "/access" . cookie badCookie1) !!! const 403 === statusCode - post (n . path "/access" . cookie badCookie2) !!! const 403 === statusCode + post (unversioned . n . path "/access" . cookie goodCookie) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie badCookie1) !!! const 403 === statusCode + post (unversioned . n . path "/access" . cookie badCookie2) !!! const 403 === statusCode -- Sending both cookies should always work, regardless of the order (they are ordered by time) - post (n . path "/access" . cookie badCookie1 . cookie goodCookie . cookie badCookie2) !!! const 200 === statusCode - post (n . path "/access" . cookie goodCookie . cookie badCookie1 . cookie badCookie2) !!! const 200 === statusCode - post (n . path "/access" . cookie badCookie1 . cookie badCookie2 . cookie goodCookie) !!! const 200 === statusCode -- -- Sending a bad cookie and an unparseble one should work too - post (n . path "/access" . cookie unparseableCookie . cookie goodCookie) !!! const 200 === statusCode - post (n . path "/access" . cookie goodCookie . cookie unparseableCookie) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie badCookie1 . cookie goodCookie . cookie badCookie2) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie goodCookie . cookie badCookie1 . cookie badCookie2) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie badCookie1 . cookie badCookie2 . cookie goodCookie) !!! const 200 === statusCode -- -- Sending a bad cookie and an unparseble one should work too + post (unversioned . n . path "/access" . cookie unparseableCookie . cookie goodCookie) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie goodCookie . cookie unparseableCookie) !!! const 200 === statusCode -- We want to make sure we are using a cookie that was deleted from the DB but not expired - this way the client -- will still have it in the cookie jar because it did not get overriden @@ -291,10 +291,10 @@ testNginzMultipleCookies o b n = do now <- liftIO getCurrentTime liftIO $ assertBool "cookie should not be expired" (cookie_expiry_time deleted > now) liftIO $ assertBool "cookie should not be expired" (cookie_expiry_time valid > now) - post (n . path "/access" . cookie deleted) !!! const 403 === statusCode - post (n . path "/access" . cookie valid) !!! const 200 === statusCode - post (n . path "/access" . cookie deleted . cookie valid) !!! const 200 === statusCode - post (n . path "/access" . cookie valid . cookie deleted) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie deleted) !!! const 403 === statusCode + post (unversioned . n . path "/access" . cookie valid) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie deleted . cookie valid) !!! const 200 === statusCode + post (unversioned . n . path "/access" . cookie valid . cookie deleted) !!! const 200 === statusCode ------------------------------------------------------------------------------- -- Login @@ -663,11 +663,11 @@ testLegalHoldLogout brig galley = do uid <- prepareLegalHoldUser brig galley _rs <- legalHoldLogin brig (LegalHoldLogin uid (Just defPassword) Nothing) PersistentCookie ZAuth.Env -> Brig -> Http () testInvalidCookie z b = do -- Syntactically invalid - post (b . path "/access" . cookieRaw "zuid" "xxx") !!! do + post (unversioned . b . path "/access" . cookieRaw "zuid" "xxx") !!! do const 403 === statusCode const (Just "Invalid user token") =~= responseBody -- Expired @@ -727,7 +727,7 @@ testInvalidCookie z b = do let f = set (ZAuth.userTTL (Proxy @u)) 0 t <- toByteString' <$> runZAuth z (ZAuth.localSettings f (ZAuth.newUserToken @u user)) liftIO $ threadDelay 1000000 - post (b . path "/access" . cookieRaw "zuid" t) !!! do + post (unversioned . b . path "/access" . cookieRaw "zuid" t) !!! do const 403 === statusCode const (Just "expired") =~= responseBody @@ -736,9 +736,9 @@ testInvalidCookie z b = do testInvalidToken :: Brig -> Http () testInvalidToken b = do -- Syntactically invalid - post (b . path "/access" . queryItem "access_token" "xxx") + post (unversioned . b . path "/access" . queryItem "access_token" "xxx") !!! errResponse - post (b . path "/access" . header "Authorization" "Bearer xxx") + post (unversioned . b . path "/access" . header "Authorization" "Bearer xxx") !!! errResponse where errResponse = do @@ -748,12 +748,12 @@ testInvalidToken b = do testMissingCookie :: forall u a. ZAuth.TokenPair u a => ZAuth.Env -> Brig -> Http () testMissingCookie z b = do -- Missing cookie, i.e. token refresh mandates a cookie. - post (b . path "/access") + post (unversioned . b . path "/access") !!! errResponse t <- toByteString' <$> runZAuth z (randomAccessToken @u @a) - post (b . path "/access" . header "Authorization" ("Bearer " <> t)) + post (unversioned . b . path "/access" . header "Authorization" ("Bearer " <> t)) !!! errResponse - post (b . path "/access" . queryItem "access_token" t) + post (unversioned . b . path "/access" . queryItem "access_token" t) !!! errResponse where errResponse = do @@ -765,7 +765,7 @@ testUnknownCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Htt testUnknownCookie z b = do -- Valid cookie but unknown to the server. t <- toByteString' <$> runZAuth z (randomUserToken @u) - post (b . path "/access" . cookieRaw "zuid" t) !!! do + post (unversioned . b . path "/access" . cookieRaw "zuid" t) !!! do const 403 === statusCode const (Just "invalid-credentials") =~= responseBody @@ -779,7 +779,7 @@ testTokenMismatchLegalhold z brig galley = do -- try refresh with a regular UserCookie but a LegalHoldAccessToken let c = decodeCookie _rs t <- toByteString' <$> runZAuth z (randomAccessToken @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess) - post (brig . path "/access" . cookie c . header "Authorization" ("Bearer " <> t)) !!! do + post (unversioned . brig . path "/access" . cookie c . header "Authorization" ("Bearer " <> t)) !!! do const 403 === statusCode const (Just "Token mismatch") =~= responseBody -- try refresh with a regular AccessToken but a LegalHoldUserCookie @@ -788,7 +788,7 @@ testTokenMismatchLegalhold z brig galley = do _rs <- legalHoldLogin brig (LegalHoldLogin alice (Just defPassword) Nothing) PersistentCookie let c' = decodeCookie _rs t' <- toByteString' <$> runZAuth z (randomAccessToken @ZAuth.User @ZAuth.Access) - post (brig . path "/access" . cookie c' . header "Authorization" ("Bearer " <> t')) !!! do + post (unversioned . brig . path "/access" . cookie c' . header "Authorization" ("Bearer " <> t')) !!! do const 403 === statusCode const (Just "Token mismatch") =~= responseBody @@ -808,7 +808,8 @@ testAccessSelfEmailAllowed nginz brig = do decodeToken rsp ) let req = - nginz + unversioned + . nginz . path "/access/self/email" . maybe id cookie mbCky . header "Authorization" ("Bearer " <> toByteString' tok) @@ -836,7 +837,8 @@ testAccessSelfEmailDenied zenv nginz brig = do pure Nothing tok <- runZAuth zenv (randomAccessToken @ZAuth.User @ZAuth.Access) let req = - nginz + unversioned + . nginz . path "/access/self/email" . Bilge.json () . maybe id cookie mbCky @@ -877,7 +879,7 @@ getAndTestDBSupersededCookieAndItsValidSuccessor config b n = do liftIO $ threadDelay minAge -- Refresh tokens _rs <- - post (n . path "/access" . cookie c) do - post (brig . path "/access" . cookie cky) !!! do + post (unversioned . brig . path "/access" . cookie cky) !!! do const 403 === statusCode const Nothing === getHeader "Set-Cookie" "/login" -> do @@ -1108,11 +1110,11 @@ testLogout b = do Just email <- userEmail <$> randomUser b _rs <- login b (defEmailLogin email) SessionCookie let (t, c) = (decodeToken _rs, decodeCookie _rs) - post (b . path "/access" . cookie c) + post (unversioned . b . path "/access" . cookie c) !!! const 200 === statusCode - post (b . path "/access/logout" . cookie c . queryItem "access_token" (toByteString' t)) + post (unversioned . b . path "/access/logout" . cookie c . queryItem "access_token" (toByteString' t)) !!! const 200 === statusCode - post (b . path "/access" . cookie c) + post (unversioned . b . path "/access" . cookie c) !!! const 403 === statusCode testReauthentication :: Brig -> Http () From 420189587ad14436f4f7b6f05747436bb734f02d Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 20 Sep 2022 13:54:21 +0200 Subject: [PATCH 08/18] Fix one more client test --- services/brig/test/integration/API/User/Util.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 73c80fc32d9..d23ea711fad 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -262,7 +262,8 @@ getClientCapabilities brig u c = getUserClientsUnqualified :: Brig -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS getUserClientsUnqualified brig uid = get $ - brig + apiVersion "v1" + . brig . paths ["users", toByteString' uid, "clients"] . zUser uid From ead32f7824b86439f30099cbd9f69f3befc1328d Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 20 Sep 2022 13:54:32 +0200 Subject: [PATCH 09/18] Add versioned paths to legalhold ACL --- deploy/services-demo/conf/nginz/nginx.conf | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 8dcbae109b2..8d799b141c0 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -325,7 +325,7 @@ http { proxy_pass http://galley; } - location ~* /legalhold/conversations/(.*) { + location ~* (/v[0-9]+)?/legalhold/conversations/(.*) { include common_response_with_zauth.conf; proxy_pass http://galley; } From 84b4fada06086c0c4c6f2499514f574abdf31a32 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 20 Sep 2022 18:45:33 +0200 Subject: [PATCH 10/18] Refactor: factor out test cases --- .../brig/test/integration/API/User/Auth.hs | 123 +++++++++--------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 0e49c654262..4e2ccc67cbe 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -150,8 +150,10 @@ tests conf m z db b g n = ], testGroup "update /access/self/email" - [ test m "valid token (idempotency case)" (testAccessSelfEmailAllowed n b), - test m "invalid or missing token" (testAccessSelfEmailDenied z n b) + [ test m "valid token (idempotency case) (with cookie)" (testAccessSelfEmailAllowed n b True), + test m "valid token (idempotency case) (without cookie)" (testAccessSelfEmailAllowed n b False), + test m "invalid or missing token (with cookie)" (testAccessSelfEmailDenied z n b True), + test m "invalid or missing token (without cookie)" (testAccessSelfEmailDenied z n b False) ], testGroup "cookies" @@ -793,66 +795,65 @@ testTokenMismatchLegalhold z brig galley = do const (Just "Token mismatch") =~= responseBody -- | This only tests access; the logic is tested in 'testEmailUpdate' in `Account.hs`. -testAccessSelfEmailAllowed :: Nginz -> Brig -> Http () -testAccessSelfEmailAllowed nginz brig = do - -- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. - forM_ [True, False] $ \withCookie -> do - usr <- randomUser brig - let Just email = userEmail usr - (mbCky, tok) <- do - rsp <- - login nginz (emailLogin email defPassword (Just "nexus1")) PersistentCookie - toByteString' tok) - - put (req . Bilge.json ()) - !!! const (if withCookie then 400 else 403) === statusCode - put (req . Bilge.json (EmailUpdate email)) - !!! const (if withCookie then 204 else 403) === statusCode - -testAccessSelfEmailDenied :: ZAuth.Env -> Nginz -> Brig -> Http () -testAccessSelfEmailDenied zenv nginz brig = do - -- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. - forM_ [True, False] $ \withCookie -> do - mbCky <- - if withCookie - then do - usr <- randomUser brig - let Just email = userEmail usr - rsp <- - login nginz (emailLogin email defPassword (Just "nexus1")) PersistentCookie - toByteString' tok)) - !!! errResponse withCookie "invalid-credentials" "Invalid token" +-- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. +testAccessSelfEmailAllowed :: Nginz -> Brig -> Bool -> Http () +testAccessSelfEmailAllowed nginz brig withCookie = do + usr <- randomUser brig + let Just email = userEmail usr + (mbCky, tok) <- do + rsp <- + login nginz (emailLogin email defPassword (Just "nexus1")) PersistentCookie + toByteString' tok) + + put (req . Bilge.json ()) + !!! const (if withCookie then 400 else 403) === statusCode + + put (req . Bilge.json (EmailUpdate email)) + !!! const (if withCookie then 204 else 403) === statusCode + +-- this test duplicates some of 'initiateEmailUpdateLogin' intentionally. +testAccessSelfEmailDenied :: ZAuth.Env -> Nginz -> Brig -> Bool -> Http () +testAccessSelfEmailDenied zenv nginz brig withCookie = do + mbCky <- + if withCookie + then do + usr <- randomUser brig + let Just email = userEmail usr + rsp <- + login nginz (emailLogin email defPassword (Just "nexus1")) PersistentCookie + toByteString' tok)) + !!! errResponse "invalid-credentials" "Invalid token" where - errResponse withCookie label msg = do + errResponse label msg = do const 403 === statusCode when withCookie $ do const (Just label) =~= responseBody From 693bb1be5b50f235e905261a3036e772cfe593a7 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 20 Sep 2022 18:49:44 +0200 Subject: [PATCH 11/18] fix bug: regex routes match too much --- deploy/services-demo/conf/nginz/nginx.conf | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 8d799b141c0..fee4a00912a 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -226,7 +226,7 @@ http { ## brig authenticated endpoints - location ~* (/v[0-9]+)?/self { + location ~* ^(/v[0-9]+)?/self$ { include common_response_with_zauth.conf; proxy_pass http://brig; } @@ -261,7 +261,7 @@ http { proxy_pass http://brig; } - location ~* (/v[0-9]+)?/clients { + location ~* ^(/v[0-9]+)?/clients$ { include common_response_with_zauth.conf; proxy_pass http://brig; } @@ -325,7 +325,7 @@ http { proxy_pass http://galley; } - location ~* (/v[0-9]+)?/legalhold/conversations/(.*) { + location ~* ^(/v[0-9]+)?/legalhold/conversations/(.*)$ { include common_response_with_zauth.conf; proxy_pass http://galley; } @@ -454,7 +454,7 @@ http { proxy_pass http://gundeck; } - location ~* (/v[0-9]+)?/notifications { + location ~* ^(/v[0-9]+)?/notifications$ { include common_response_with_zauth.conf; proxy_pass http://gundeck; } From b08bfc0ebc5f48902c6384a5bfb2c87edbeb97a8 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 21 Sep 2022 10:25:15 +0200 Subject: [PATCH 12/18] Fix the remaining brig tests --- deploy/services-demo/conf/nginz/nginx.conf | 2 +- .../brig/test/integration/API/Internal.hs | 2 +- services/brig/test/integration/API/Metrics.hs | 7 +++--- .../brig/test/integration/API/Settings.hs | 4 +-- services/brig/test/integration/API/Team.hs | 12 +++++---- .../brig/test/integration/API/Team/Util.hs | 10 -------- .../brig/test/integration/API/User/Account.hs | 2 +- .../test/integration/API/User/Connection.hs | 2 +- .../brig/test/integration/API/User/Handles.hs | 25 +++++++++++-------- .../brig/test/integration/API/User/Util.hs | 4 +-- services/brig/test/integration/API/Version.hs | 4 +-- services/brig/test/integration/Util.hs | 3 ++- 12 files changed, 38 insertions(+), 39 deletions(-) diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index fee4a00912a..9074229501c 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -214,7 +214,7 @@ http { proxy_pass http://brig; } - location ~* ^/teams/invitations/([^/]*)$ { + location ~* ^(/v[0-9]+)?/teams/invitations/([^/]*)$ { include common_response_no_zauth.conf; proxy_pass http://brig; } diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index 93d0eebb759..f6b7f3f4d42 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -363,7 +363,7 @@ testAddKeyPackageRef brig = do getFeatureConfig :: forall cfg m. (MonadIO m, MonadHttp m, HasCallStack, ApiFt.IsFeatureConfig cfg, KnownSymbol (ApiFt.FeatureSymbol cfg)) => (Request -> Request) -> UserId -> m ResponseLBS getFeatureConfig galley uid = do - get $ galley . paths ["feature-configs", featureNameBS @cfg] . zUser uid + get $ apiVersion "v1" . galley . paths ["feature-configs", featureNameBS @cfg] . zUser uid getAllFeatureConfigs :: (MonadIO m, MonadHttp m, HasCallStack) => (Request -> Request) -> UserId -> m ResponseLBS getAllFeatureConfigs galley uid = do diff --git a/services/brig/test/integration/API/Metrics.hs b/services/brig/test/integration/API/Metrics.hs index a1679dc12af..807942b60d0 100644 --- a/services/brig/test/integration/API/Metrics.hs +++ b/services/brig/test/integration/API/Metrics.hs @@ -51,8 +51,9 @@ testPrometheusMetrics brig = do const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody testMetricsEndpoint :: Brig -> Http () -testMetricsEndpoint brig = do - let p1 = "/self" +testMetricsEndpoint brig0 = do + let brig = apiVersion "v1" . brig0 + p1 = "/self" p2 uid = "/users/" <> uid <> "/clients" p3 = "/login" beforeSelf <- getCount "/self" "GET" @@ -73,7 +74,7 @@ testMetricsEndpoint brig = do liftIO $ assertEqual "/login was called twice" (beforeProperties + 2) countProperties where getCount endpoint m = do - rsp <- responseBody <$> get (brig . path "i/metrics") + rsp <- responseBody <$> get (brig0 . path "i/metrics") -- is there some responseBodyAsText function used elsewhere? let asText = fromMaybe "" (fromByteString' (fromMaybe "" rsp)) pure $ fromRight 0 (parseOnly (parseCount endpoint m) asText) diff --git a/services/brig/test/integration/API/Settings.hs b/services/brig/test/integration/API/Settings.hs index ff2059d1ee0..0efdb338d8e 100644 --- a/services/brig/test/integration/API/Settings.hs +++ b/services/brig/test/integration/API/Settings.hs @@ -125,7 +125,7 @@ testUsersEmailVisibleIffExpected opts brig galley viewingUserIs visibilitySettin ] let newOpts = opts & Opt.optionSettings . Opt.emailVisibility .~ visibilitySetting withSettingsOverrides newOpts $ do - get (brig . zUser viewerId . path "users" . queryItem "ids" uids) !!! do + get (apiVersion "v1" . brig . zUser viewerId . path "users" . queryItem "ids" uids) !!! do const 200 === statusCode const (Just expected) === result where @@ -155,7 +155,7 @@ testGetUserEmailShowsEmailsIffExpected opts brig galley viewingUserIs visibility let newOpts = opts & Opt.optionSettings . Opt.emailVisibility .~ visibilitySetting withSettingsOverrides newOpts $ do forM_ expectations $ \(uid, expectedEmail) -> - get (brig . zUser viewerId . paths ["users", toByteString' uid]) !!! do + get (apiVersion "v1" . brig . zUser viewerId . paths ["users", toByteString' uid]) !!! do const 200 === statusCode const expectedEmail === emailResult where diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 45b2ce69d2c..9cff893a447 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -24,7 +24,7 @@ where import qualified API.Search.Util as SearchUtil import API.Team.Util -import API.User.Util as Util hiding (listConnections) +import API.User.Util as Util import Bilge hiding (accept, head, timeout) import qualified Bilge import Bilge.Assert @@ -218,9 +218,9 @@ testInvitationEmailLookupNginz brig nginz = do -- expect an invitation to be found querying with email after invite headInvitationByEmail nginz email 200 -headInvitationByEmail :: Brig -> Email -> Int -> Http () -headInvitationByEmail brig email expectedCode = - Bilge.head (brig . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) +headInvitationByEmail :: (Request -> Request) -> Email -> Int -> Http () +headInvitationByEmail service email expectedCode = + Bilge.head (service . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) !!! const expectedCode === statusCode testInvitationTooManyPending :: Brig -> TeamSizeLimit -> Http () @@ -383,7 +383,9 @@ createAndVerifyInvitation' replacementBrigApp acceptFn invite brig galley = do mem <- getTeamMember invitee tid galley liftIO $ assertEqual "Member not part of the team" invitee (mem ^. Member.userId) liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Member.invitation) - conns <- listConnections invitee brig + conns <- + responseJsonError =<< listConnections brig invitee + UserId -> Brig -> (MonadIO m, MonadHttp m, MonadThrow m) => m UserConnectionList -listConnections u brig = do - responseJsonError - =<< get - ( brig - . path "connections" - . zUser u - ) - getInvitation :: Brig -> InvitationCode -> (MonadIO m, MonadHttp m) => m (Maybe Invitation) getInvitation brig c = do r <- diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index a88ada5d19b..24cbcf0968e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -24,7 +24,7 @@ module API.User.Account where import qualified API.Search.Util as Search -import API.Team.Util hiding (listConnections) +import API.Team.Util import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 1bd463d0ee3..2911dd3aea1 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -619,7 +619,7 @@ testLocalConnectionsPaging b = do let count' = count + step let range = queryRange (toByteString' <$> start) (Just step) r <- - get (b . path "/connections" . zUser u . range) + get (apiVersion "v1" . b . path "/connections" . zUser u . range) conns) diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 5eb3a44c293..f15c65bb0cc 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -176,7 +176,7 @@ testHandleQuery opts brig = do Bilge.head (brig . paths ["users", "handles", toByteString' hdl] . zUser uid) !!! const 200 === statusCode -- Query user profiles by handles - get (brig . path "/users" . queryItem "handles" (toByteString' hdl) . zUser uid) !!! do + get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' hdl) . zUser uid) !!! do const 200 === statusCode const (Just (Handle hdl)) === (profileHandle <=< listToMaybe <=< responseJsonMaybe) -- Bulk availability check @@ -241,7 +241,8 @@ testGetUserByUnqualifiedHandle brig = do _ <- putHandle brig (userId user) handle requestingUser <- randomId get - ( brig + ( apiVersion "v1" + . brig . paths ["users", "handles", toByteString' handle] . zUser requestingUser ) @@ -254,7 +255,8 @@ testGetUserByUnqualifiedHandleFailure brig = do handle <- randomHandle requestingUser <- randomId get - ( brig + ( apiVersion "v1" + . brig . paths ["users", "handles", toByteString' handle] . zUser requestingUser ) @@ -272,7 +274,8 @@ testGetUserByQualifiedHandle brig = do profileForUnconnectedUser <- responseJsonError =<< get - ( brig + ( apiVersion "v1" + . brig . paths ["users", "by-handle", toByteString' domain, toByteString' handle] . zUser (userId unconnectedUser) . expect2xx @@ -296,7 +299,8 @@ testGetUserByQualifiedHandleFailure brig = do handle <- randomHandle qself <- userQualifiedId <$> randomUser brig get - ( brig + ( apiVersion "v1" + . brig . paths [ "users", "by-handle", @@ -315,7 +319,8 @@ testGetUserByQualifiedHandleNoFederation opt brig = do someUser <- randomUser brig withSettingsOverrides newOpts $ get - ( brig + ( apiVersion "v1" + . brig . paths ["users", "by-handle", "non-existant.example.com", "oh-a-handle"] . zUser (userId someUser) ) @@ -328,10 +333,10 @@ assertCanFind :: (Monad m, MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) = assertCanFind brig from target = do liftIO $ assertBool "assertCanFind: Target must have a handle set" (isJust $ userHandle target) let targetHandle = fromMaybe (error "Impossible") (userHandle target) - get (brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do + get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do const 200 === statusCode const (userHandle target) === (>>= (listToMaybe >=> profileHandle)) . responseJsonMaybe - get (brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do + get (apiVersion "v1" . brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do const 200 === statusCode const (Just (UserHandleInfo $ userQualifiedId target)) === responseJsonMaybe @@ -339,7 +344,7 @@ assertCannotFind :: (Monad m, MonadCatch m, MonadIO m, MonadHttp m, HasCallStack assertCannotFind brig from target = do liftIO $ assertBool "assertCannotFind: Target must have a handle set" (isJust $ userHandle target) let targetHandle = fromMaybe (error "Impossible") (userHandle target) - get (brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do + get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do const 404 === statusCode - get (brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do + get (apiVersion "v1" . brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do const 404 === statusCode diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index d23ea711fad..7551ef25c32 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -288,7 +288,7 @@ deleteClient brig u c pw = RequestBodyLBS . encode . object . maybeToList $ fmap ("password" .=) pw -listConnections :: Brig -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS +listConnections :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m ResponseLBS listConnections brig u = get $ apiVersion "v1" @@ -437,7 +437,7 @@ sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do assertEmailVisibility :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> Bool -> m () assertEmailVisibility brig a b visible = - get (brig . paths ["users", pack . show $ userId b] . zUser (userId a)) !!! do + get (apiVersion "v1" . brig . paths ["users", pack . show $ userId b] . zUser (userId a)) !!! do const 200 === statusCode if visible then const (Just (userEmail b)) === fmap userEmail . responseJsonMaybe diff --git a/services/brig/test/integration/API/Version.hs b/services/brig/test/integration/API/Version.hs index 0a0702509cf..455925be8c0 100644 --- a/services/brig/test/integration/API/Version.hs +++ b/services/brig/test/integration/API/Version.hs @@ -50,7 +50,7 @@ testVersion brig = do testVersionV1 :: Brig -> Http () testVersionV1 brig = do vinfo <- - responseJsonError =<< get (brig . path "/v1/api-version") + responseJsonError =<< get (apiVersion "v1" . brig . path "api-version") Http () testUnsupportedVersion brig = do e <- - responseJsonError =<< get (brig . path "/v500/api-version") + responseJsonError =<< get (apiVersion "v500" . brig . path "api-version") UserId -> UserId -> Http ResponseLBS getUser brig zusr usr = get $ - brig + apiVersion "v1" + . brig . paths ["users", toByteString' usr] . zUser zusr From 64d8d1fb7198d8e7fcf8faf3785196e8fb2b7eaa Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 21 Sep 2022 10:40:01 +0200 Subject: [PATCH 13/18] Use versioned API in cargohold tests --- services/brig/test/integration/Util.hs | 17 ++++---- .../cargohold/test/integration/API/Util.hs | 25 ++++++----- .../cargohold/test/integration/TestSetup.hs | 42 ++++++++++++++++++- 3 files changed, 64 insertions(+), 20 deletions(-) diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index adcdd00a3a6..547ff4187c0 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -52,7 +52,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import Data.Domain (Domain (..), domainText, mkDomain) import Data.Handle (Handle (..)) @@ -153,10 +152,10 @@ removeSlash' s = case B8.uncons s of removeVersionPrefix :: ByteString -> Maybe ByteString removeVersionPrefix bs = do - let (x, s) = C8.splitAt 1 bs - guard (x == C8.pack "v") - (_, s') <- C8.readInteger s - pure (C8.tail s') + let (x, s) = B8.splitAt 1 bs + guard (x == B8.pack "v") + (_, s') <- B8.readInteger s + pure (B8.tail s') -- | Note: Apply this function last when composing (Request -> Request) functions unversioned :: Request -> Request @@ -165,7 +164,7 @@ unversioned r = { HTTP.path = maybe (HTTP.path r) - (C8.pack "/" <>) + (B8.pack "/" <>) (removeVersionPrefix . removeSlash' $ HTTP.path r) } @@ -843,7 +842,7 @@ zAuthAccess :: UserId -> ByteString -> Request -> Request zAuthAccess u c = header "Z-Type" "access" . zUser u . zConn c zUser :: UserId -> Request -> Request -zUser = header "Z-User" . C8.pack . show +zUser = header "Z-User" . B8.pack . show zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" @@ -933,7 +932,7 @@ somePrekeys = Prekey (PrekeyId 23) "pQABARcCoQBYIASE94LjK6Raipk/lN/YewouqO+kcQGpxIqP+iW2hyHiA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", Prekey (PrekeyId 24) "pQABARgYAqEAWCBZ222LpS6/99Btlw+83PihrA655skwsNevt//8oz5axQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", Prekey (PrekeyId 25) "pQABARgZAqEAWCDGEwo61w4O8T8lyw0HdoOjGWBKQUNqo6+jSfrPR9alrAOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", - Prekey (PrekeyId 26) "pQABARgaAqEAWCBMSQoQ6B35plC80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2" + Prekey (PrekeyId 26) "pQABARgaAqEAWCBMSQoQ6B35plB80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2" ] -- | The client ID of the first of 'someLastPrekeys' @@ -1278,7 +1277,7 @@ fromServantRequest domain r = <> headers <> [(originDomainHeaderName, T.encodeUtf8 (domainText domain))], Wai.isSecure = True, - Wai.pathInfo = filter (not . T.null) (map Data.String.Conversions.cs (C8.split '/' pathBS)), + Wai.pathInfo = filter (not . T.null) (map Data.String.Conversions.cs (B8.split '/' pathBS)), Wai.queryString = toList (Servant.requestQueryString r) } in WaiTest.SRequest req (cs bodyBS) diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index c0609d86609..c98851fdd41 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -64,9 +64,11 @@ uploadRaw :: Lazy.ByteString -> TestM (Response (Maybe Lazy.ByteString)) uploadRaw c usr bs = do - cargohold <- viewCargohold + cargohold <- viewUnversionedCargohold post $ - c . cargohold + apiVersion "v1" + . c + . cargohold . method POST . zUser usr . zConn "conn" @@ -90,8 +92,8 @@ zConn = header "Z-Connection" deleteAssetV3 :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAssetV3 u k = do - c <- viewCargohold - delete $ c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] + c <- viewUnversionedCargohold + delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAsset u k = do @@ -100,7 +102,6 @@ deleteAsset u k = do c . zUser u . paths [ "assets", - "v4", toByteString' (qDomain k), toByteString' (qUnqualified k) ] @@ -109,10 +110,14 @@ class IsAssetLocation key where locationPath :: key -> Request -> Request instance IsAssetLocation AssetKey where - locationPath k = paths ["assets", "v3", toByteString' k] + locationPath k = + apiVersion "v1" + . paths ["assets", "v3", toByteString' k] instance IsAssetLocation (Qualified AssetKey) where - locationPath k = paths ["assets", "v4", toByteString' (qDomain k), toByteString' (qUnqualified k)] + locationPath k = + apiVersion "v2" + . paths ["assets", toByteString' (qDomain k), toByteString' (qUnqualified k)] instance IsAssetLocation ByteString where locationPath = path @@ -137,7 +142,7 @@ downloadAssetWith :: tok -> TestM (Response (Maybe LByteString)) downloadAssetWith r uid loc tok = do - c <- viewCargohold + c <- viewUnversionedCargohold get $ c . r . zUser uid @@ -158,14 +163,14 @@ postToken uid key = do c <- viewCargohold post $ c . zUser uid - . paths ["assets", "v3", toByteString' key, "token"] + . paths ["assets", toByteString' key, "token"] deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) deleteToken uid key = do c <- viewCargohold delete $ c . zUser uid - . paths ["assets", "v3", toByteString' key, "token"] + . paths ["assets", toByteString' key, "token"] viewFederationDomain :: TestM Domain viewFederationDomain = view (tsOpts . optSettings . setFederationDomain) diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index cd92d677f98..e3cfc78de34 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -26,11 +26,14 @@ module TestSetup Cargohold, TestM, runTestM, + viewUnversionedCargohold, viewCargohold, createTestSetup, runFederationClient, withFederationClient, withFederationError, + apiVersion, + unversioned, ) where @@ -42,12 +45,14 @@ import Control.Monad.Codensity import Control.Monad.Except import Control.Monad.Morph import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as B8 import Data.ByteString.Conversion import qualified Data.Text as T import Data.Text.Encoding import Data.Yaml import Imports import Network.HTTP.Client hiding (responseBody) +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS import qualified Network.Wai.Utilities.Error as Wai import Servant.Client.Streaming @@ -73,8 +78,43 @@ data TestSetup = TestSetup makeLenses ''TestSetup +-- | Note: Apply this function last when composing (Request -> Request) functions +apiVersion :: ByteString -> Request -> Request +apiVersion newVersion r = r {HTTP.path = setVersion newVersion (HTTP.path r)} + where + setVersion :: ByteString -> ByteString -> ByteString + setVersion v p = + let p' = removeSlash' p + in v <> "/" <> fromMaybe p' (removeVersionPrefix p') + +removeSlash' :: ByteString -> ByteString +removeSlash' s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s + +removeVersionPrefix :: ByteString -> Maybe ByteString +removeVersionPrefix bs = do + let (x, s) = B8.splitAt 1 bs + guard (x == B8.pack "v") + (_, s') <- B8.readInteger s + pure (B8.tail s') + +-- | Note: Apply this function last when composing (Request -> Request) functions +unversioned :: Request -> Request +unversioned r = + r + { HTTP.path = + maybe + (HTTP.path r) + (B8.pack "/" <>) + (removeVersionPrefix . removeSlash' $ HTTP.path r) + } + viewCargohold :: TestM Cargohold -viewCargohold = mkRequest <$> view tsEndpoint +viewCargohold = fmap (apiVersion "v2" .) viewUnversionedCargohold + +viewUnversionedCargohold :: TestM Cargohold +viewUnversionedCargohold = mkRequest <$> view tsEndpoint runTestM :: TestSetup -> TestM a -> IO a runTestM ts action = runHttpT (view tsManager ts) (runReaderT action ts) From ec74e40e23e820053aaf8cbb23eccf520f919908 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 21 Sep 2022 11:12:08 +0200 Subject: [PATCH 14/18] Always use most recent version in galley tests --- libs/wire-api/src/Wire/API/Routes/Version.hs | 4 ++++ services/galley/test/integration/API/MLS/Util.hs | 2 +- services/galley/test/integration/API/Util.hs | 9 ++++++--- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index 959c6abd3c1..a269f644426 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -73,6 +73,10 @@ instance FromHttpApiData Version where parseHeader = first Text.pack . Aeson.eitherDecode . LBS.fromStrict parseUrlPiece = parseHeader . Text.encodeUtf8 +instance ToHttpApiData Version where + toHeader = LBS.toStrict . Aeson.encode + toUrlPiece = Text.decodeUtf8 . toHeader + supportedVersions :: [Version] supportedVersions = [minBound .. maxBound] diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 40dad82ddbe..3e7f6c8eb91 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -131,7 +131,7 @@ postCommitBundle :: postCommitBundle sender bundle = do galley <- viewGalley post - ( galley . paths ["v2", "mls", "commit-bundles"] + ( galley . paths ["mls", "commit-bundles"] . zUser sender . zConn "conn" . content "message/mls" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 44a4e97f4aa..5664206d251 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -83,11 +83,11 @@ import Imports import qualified Network.HTTP.Client as HTTP import Network.HTTP.Media.MediaType import qualified Network.HTTP.Types as HTTP -import Network.Wai (Application, defaultRequest) +import Network.Wai (defaultRequest) import qualified Network.Wai as Wai import qualified Network.Wai.Test as Wai import Network.Wai.Utilities.MockServer (withMockServer) -import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) +import Servant import System.Exit import System.Process import System.Random @@ -122,6 +122,7 @@ import qualified Wire.API.Message.Proto as Proto import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi import Wire.API.Routes.MultiTablePaging +import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature import Wire.API.Team.Invitation @@ -139,11 +140,13 @@ import Wire.API.User.Client.Prekey -- API Operations addPrefix :: Request -> Request -addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} +addPrefix r = r {HTTP.path = "v" <> toHeader latestVersion <> "/" <> removeSlash (HTTP.path r)} where removeSlash s = case B8.uncons s of Just ('/', s') -> s' _ -> s + latestVersion :: Version + latestVersion = maxBound -- | A class for monads with access to a Sem r instance class HasGalley m where From febfaffbcc9ca55cd344a35099de994220ae77b2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 21 Sep 2022 11:23:15 +0200 Subject: [PATCH 15/18] Use latest API version in brig --- services/brig/test/integration/Main.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 1b15638b14f..b206405bfff 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -62,7 +62,9 @@ import Test.Tasty.HUnit import Util import Util.Options import Util.Test +import Web.HttpApiData import Wire.API.Federation.API +import Wire.API.Routes.Version import Wire.Sem.Paging.Cassandra (InternalPaging) data BackendConf = BackendConf @@ -183,11 +185,13 @@ runTests iConf brigOpts otherArgs = do mkVersionedRequest endpoint = addPrefix . mkRequest endpoint addPrefix :: Request -> Request - addPrefix r = r {HTTP.path = "v2/" <> removeSlash (HTTP.path r)} + addPrefix r = r {HTTP.path = "v" <> toHeader latestVersion <> "/" <> removeSlash (HTTP.path r)} where removeSlash s = case B8.uncons s of Just ('/', s') -> s' _ -> s + latestVersion :: Version + latestVersion = maxBound parseEmailAWSOpts :: IO (Maybe Opts.EmailAWSOpts) parseEmailAWSOpts = case Opts.email . Opts.emailSMS $ brigOpts of From e5cf81822a940c52c3baef5197249805cc0176fe Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 21 Sep 2022 11:23:15 +0200 Subject: [PATCH 16/18] Use latest API version in cargohold --- services/cargohold/cargohold.cabal | 1 + services/cargohold/test/integration/TestSetup.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index f82b665ae31..74ebc915c50 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -290,6 +290,7 @@ executable cargohold-integration , extended , federator , HsOpenSSL >=0.11 + , http-api-data , http-client >=0.4 , http-client-tls >=0.2 , http-media diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index e3cfc78de34..af4eb7d6677 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -61,7 +61,9 @@ import Test.Tasty.HUnit import Util.Options import Util.Options.Common import Util.Test +import Web.HttpApiData import Wire.API.Federation.Domain +import Wire.API.Routes.Version type Cargohold = Request -> Request @@ -111,7 +113,13 @@ unversioned r = } viewCargohold :: TestM Cargohold -viewCargohold = fmap (apiVersion "v2" .) viewUnversionedCargohold +viewCargohold = + fmap + (apiVersion ("v" <> toHeader latestVersion) .) + viewUnversionedCargohold + where + latestVersion :: Version + latestVersion = maxBound viewUnversionedCargohold :: TestM Cargohold viewUnversionedCargohold = mkRequest <$> view tsEndpoint From 7a99387c6eb71810f13aa0199e0e2cd586e191a3 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 23 Sep 2022 09:33:23 +0200 Subject: [PATCH 17/18] Use v1 API in End2End tests --- services/brig/test/integration/Federation/End2end.hs | 2 +- services/brig/test/integration/Util.hs | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index cd668f00283..6f07be67ef8 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -290,7 +290,7 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do let invite = InviteQualified (userQualifiedId bob :| []) roleNameWireAdmin post - ( galley1 + ( apiVersion "v1" . galley1 . paths ["conversations", (toByteString' . qUnqualified) convId, "members", "v2"] . zUser (userId alice) . zConn "conn" diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 547ff4187c0..bcb0e9031aa 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -640,7 +640,8 @@ getUserInfoFromHandle brig domain handle = do u <- randomId responseJsonError =<< get - ( brig + ( apiVersion "v1" + . brig . paths ["users", "by-handle", toByteString' (domainText domain), toByteString' handle] . zUser u . expect2xx @@ -783,7 +784,8 @@ listConvs :: m ResponseLBS listConvs galley zusr convs = do post $ - galley + apiVersion "v1" + . galley . path "/conversations/list/v2" . zUser zusr . zConn "conn" From fa7dd56c0a802e65708b5a49e165608267b21312 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 26 Sep 2022 13:21:11 +0200 Subject: [PATCH 18/18] Add CHANGELOG entry --- changelog.d/5-internal/integration-test-version | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/integration-test-version diff --git a/changelog.d/5-internal/integration-test-version b/changelog.d/5-internal/integration-test-version new file mode 100644 index 00000000000..3f769d8deea --- /dev/null +++ b/changelog.d/5-internal/integration-test-version @@ -0,0 +1 @@ +Make test API calls point to the most recent version by default