diff --git a/changelog.d/0-release-notes/nginz-upgrade b/changelog.d/0-release-notes/nginz-upgrade new file mode 100644 index 00000000000..c5de9375515 --- /dev/null +++ b/changelog.d/0-release-notes/nginz-upgrade @@ -0,0 +1 @@ +For wire.com operators: make sure that nginz is deployed diff --git a/changelog.d/1-api-changes/broadcast-qualified b/changelog.d/1-api-changes/broadcast-qualified new file mode 100644 index 00000000000..ae2d4d65a9c --- /dev/null +++ b/changelog.d/1-api-changes/broadcast-qualified @@ -0,0 +1 @@ +Add qualified broadcast endpoint diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 68306c486a8..e24b6989d3b 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -316,7 +316,7 @@ nginx_conf: - all max_body_size: 40m body_buffer_size: 256k - - path: /broadcast/otr/messages + - path: /broadcast envs: - all max_body_size: 40m diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index d7a3a6f4139..3900df1863f 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -336,7 +336,7 @@ http { proxy_pass http://galley; } - location /broadcast/otr/messages { + location /broadcast { include common_response_with_zauth.conf; proxy_pass http://galley; } diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index bd4c46d60f1..b1c5b1f97fb 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -880,6 +880,25 @@ type MessagingAPI = (PostOtrResponses MessageSendingStatus) (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus) ) + :<|> Named + "post-proteus-broadcast" + ( Summary "Post an encrypted message to all team members and all contacts (accepts only Protobuf)" + :> Description PostOtrDescription + :> ZLocalUser + :> ZConn + :> CanThrow TeamNotFound + :> CanThrow BroadcastLimitExceeded + :> CanThrow NonBindingTeam + :> "broadcast" + :> "proteus" + :> "messages" + :> ReqBody '[Proto] QualifiedNewOtrMessage + :> MultiVerb + 'POST + '[JSON] + (PostOtrResponses MessageSendingStatus) + (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus) + ) type BotAPI = Named @@ -1048,7 +1067,7 @@ type PostOtrDescription = \- `report_only`: Takes a list of qualified UserIDs. If any clients of the listed users are missing, the message is not sent. The missing clients are reported in the response.\n\ \- `ignore_only`: Takes a list of qualified UserIDs. If any clients of the non-listed users are missing, the message is not sent. The missing clients are reported in the response.\n\ \\n\ - \The sending of messages in a federated conversation could theorectically fail partially. \ + \The sending of messages in a federated conversation could theoretically fail partially. \ \To make this case unlikely, the backend first gets a list of clients from all the involved backends and then tries to send a message. \ \So, if any backend is down, the message is not propagated to anyone. \ \But the actual message fan out to multiple backends could still fail partially. This type of failure is reported as a 201, \ diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 4ce7d9094b0..f2d8c758882 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -408,6 +408,7 @@ executable galley-integration , containers , cookie , currency-codes + , data-default , data-timeout , errors , exceptions diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 8b17a10f8cd..211826d64d6 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -169,6 +169,7 @@ executables: - cookie - currency-codes - metrics-wai + - data-default - data-timeout - errors - exceptions diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index 78374814986..3c656cd0b22 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -83,6 +83,7 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> bot :< Named @"post-otr-message-unqualified" postOtrMessageUnqualified :<|> Named @"post-otr-broadcast-unqualified" postOtrBroadcastUnqualified :<|> Named @"post-proteus-message" postProteusMessage + :<|> Named @"post-proteus-broadcast" postProteusBroadcast bot = Named @"post-bot-message-unqualified" postBotMessageUnqualified diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 555cddb1277..85e358b34b2 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -52,6 +52,7 @@ module Galley.API.Update -- * Talking postProteusMessage, postOtrMessageUnqualified, + postProteusBroadcast, postOtrBroadcastUnqualified, isTypingUnqualified, @@ -1114,6 +1115,30 @@ postProteusMessage sender zcon conv msg = runLocalInput sender $ do (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) conv +postProteusBroadcast :: + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + Error ActionError, + Error TeamError, + FederatorAccess, + GundeckAccess, + ExternalAccess, + Input Opts, + Input UTCTime, + MemberStore, + TeamStore, + TinyLog + ] + r => + Local UserId -> + ConnId -> + QualifiedNewOtrMessage -> + Sem r (PostOtrResponse MessageSendingStatus) +postProteusBroadcast sender zcon msg = postBroadcast sender (Just zcon) msg + unqualifyEndpoint :: Functor f => Local x -> diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 6074a973613..fa070f2565b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -472,7 +472,7 @@ postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto = do conv <- decodeConvId <$> postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing -- Missing eve let ciphertext = toBase64Text "hello bob" - let m = otrRecipients [(bob, [(bc, ciphertext)])] + let m = otrRecipients [(bob, bc, ciphertext)] r1 <- postProtoOtrMessage alice ac conv m postConv alice [bob] (Just "gossip") [] Nothing Nothing -- Unknown client ID => 403 let ciphertext = toBase64Text "hello bob" - let m = otrRecipients [(bob, [(bc, ciphertext)])] + let m = otrRecipients [(bob, bc, ciphertext)] postProtoOtrMessage alice (ClientId "172618352518396") conv m !!! const 403 === statusCode @@ -576,7 +576,7 @@ postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam = do conv <- decodeConvId <$> postConv alice [bob, chad, eve] (Just "gossip") [] Nothing Nothing -- Missing eve let msgMissingChadAndEve = [(bob, bc, toBase64Text "hello bob")] - let m' = otrRecipients [(bob, [(bc, toBase64Text "hello bob")])] + let m' = otrRecipients [(bob, bc, toBase64Text "hello bob")] -- These three are equivalent (i.e. report all missing clients) postOtrMessage id alice ac conv msgMissingChadAndEve !!! const 412 === statusCode diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index de2e59bd46d..f16d2178e71 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -38,6 +38,7 @@ import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) import Data.Csv (FromNamedRecord (..), decodeByName) import qualified Data.Currency as Currency +import Data.Default import Data.Id import Data.Json.Util hiding ((#)) import qualified Data.LegalHold as LH @@ -135,13 +136,23 @@ tests s = test s "team tests around truncation limits - no events, too large team" (testTeamAddRemoveMemberAboveThresholdNoEvents >> ensureQueueEmpty), test s "send billing events to owners even in large teams" testBillingInLargeTeam, test s "send billing events to some owners in large teams (indexedBillingTeamMembers disabled)" testBillingInLargeTeamWithoutIndexedBillingTeamMembers, - test s "post crypto broadcast message json" postCryptoBroadcastMessageJson, - test s "post crypto broadcast message json - filtered only, too large team" postCryptoBroadcastMessageJsonFilteredTooLargeTeam, - test s "post crypto broadcast message json (report missing in body)" postCryptoBroadcastMessageJsonReportMissingBody, - test s "post crypto broadcast message protobuf" postCryptoBroadcastMessageProto, - test s "post crypto broadcast message redundant/missing" postCryptoBroadcastMessageJson2, - test s "post crypto broadcast message no-team" postCryptoBroadcastMessageNoTeam, - test s "post crypto broadcast message 100 (or max conns)" postCryptoBroadcastMessage100OrMaxConns + testGroup "broadcast" $ + [ (BroadcastLegacyBody, BroadcastJSON), + (BroadcastLegacyQueryParams, BroadcastJSON), + (BroadcastLegacyBody, BroadcastProto), + (BroadcastQualified, BroadcastProto) + ] + <&> \(api, ty) -> + let bcast = def {bAPI = api, bType = ty} + in testGroup + (broadcastAPIName api <> " - " <> broadcastTypeName ty) + [ test s "message" (postCryptoBroadcastMessage bcast), + test s "filtered only, too large team" (postCryptoBroadcastMessageFilteredTooLargeTeam bcast), + test s "report missing in body" (postCryptoBroadcastMessageReportMissingBody bcast), + test s "redundant/missing" (postCryptoBroadcastMessage2 bcast), + test s "no-team" (postCryptoBroadcastMessageNoTeam bcast), + test s "100 (or max conns)" (postCryptoBroadcastMessage100OrMaxConns bcast) + ] ] timeout :: WS.Timeout @@ -1610,8 +1621,8 @@ testUpdateTeamStatus = do const 403 === statusCode const "invalid-team-status-update" === (Error.label . responseJsonUnsafeWithMsg "error label") -postCryptoBroadcastMessageJson :: TestM () -postCryptoBroadcastMessageJson = do +postCryptoBroadcastMessage :: Broadcast -> TestM () +postCryptoBroadcastMessage bcast = do localDomain <- viewFederationDomain let q :: Id a -> Qualified (Id a) q = (`Qualified` localDomain) @@ -1642,9 +1653,9 @@ postCryptoBroadcastMessageJson = do -- Alice's clients 1 and 2 listen to their own messages only WS.bracketR (c . queryItem "client" (toByteString' ac2)) alice $ \wsA2 -> WS.bracketR (c . queryItem "client" (toByteString' ac)) alice $ \wsA1 -> do - Util.postOtrBroadcastMessage id alice ac msg !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = msg} !!! do const 201 === statusCode - assertMismatch [] [] [] + assertBroadcastMismatch localDomain (bAPI bcast) [] [] [] -- Bob should get the broadcast (team member of alice) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext1")) @@ -1660,13 +1671,12 @@ postCryptoBroadcastMessageJson = do void . liftIO $ WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 (toBase64Text "ciphertext0")) -postCryptoBroadcastMessageJsonFilteredTooLargeTeam :: TestM () -postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do +postCryptoBroadcastMessageFilteredTooLargeTeam :: Broadcast -> TestM () +postCryptoBroadcastMessageFilteredTooLargeTeam bcast = do localDomain <- viewFederationDomain let q :: Id a -> Qualified (Id a) q = (`Qualified` localDomain) opts <- view tsGConf - g <- view tsCannon c <- view tsCannon -- Team1: alice, bob and 3 unnamed (alice, tid) <- Util.createBindingTeam @@ -1705,14 +1715,14 @@ postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do & optSettings . setMaxConvSize .~ 4 withSettingsOverrides newOpts $ do -- Untargeted, Alice's team is too large - Util.postOtrBroadcastMessage' g Nothing id alice ac msg !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = msg} !!! do const 400 === statusCode const "too-many-users-to-broadcast" === Error.label . responseJsonUnsafeWithMsg "error label" -- We target the message to the 4 users, that should be fine let inbody = Just [alice, bob, charlie, dan] - Util.postOtrBroadcastMessage' g inbody id alice ac msg !!! do + Util.postBroadcast (q alice) ac bcast {bReport = inbody, bMessage = msg} !!! do const 201 === statusCode - assertMismatch [] [] [] + assertBroadcastMismatch localDomain (bAPI bcast) [] [] [] -- Bob should get the broadcast (team member of alice) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext1")) @@ -1728,23 +1738,26 @@ postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do void . liftIO $ WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 (toBase64Text "ciphertext0")) -postCryptoBroadcastMessageJsonReportMissingBody :: TestM () -postCryptoBroadcastMessageJsonReportMissingBody = do - g <- view tsGalley +postCryptoBroadcastMessageReportMissingBody :: Broadcast -> TestM () +postCryptoBroadcastMessageReportMissingBody bcast = do + localDomain <- viewFederationDomain (alice, tid) <- Util.createBindingTeam + let qalice = Qualified alice localDomain bob <- view userId <$> Util.addUserToTeam alice tid _bc <- Util.randomClient bob (someLastPrekeys !! 1) -- this is important! assertQueue "add bob" $ tUpdate 2 [alice] refreshIndex ac <- Util.randomClient alice (someLastPrekeys !! 0) - let inbody = Just [bob] -- body triggers report - inquery = (queryItem "report_missing" (toByteString' alice)) -- query doesn't + let -- add extraneous query parameter (unless using query parameter API) + inquery = case bAPI bcast of + BroadcastLegacyQueryParams -> id + _ -> queryItem "report_missing" (toByteString' alice) msg = [(alice, ac, "ciphertext0")] - Util.postOtrBroadcastMessage' g inbody inquery alice ac msg + Util.postBroadcast qalice ac bcast {bReport = Just [bob], bMessage = msg, bReq = inquery} !!! const 412 === statusCode -postCryptoBroadcastMessageJson2 :: TestM () -postCryptoBroadcastMessageJson2 = do +postCryptoBroadcastMessage2 :: Broadcast -> TestM () +postCryptoBroadcastMessage2 bcast = do localDomain <- viewFederationDomain let q :: Id a -> Qualified (Id a) q = (`Qualified` localDomain) @@ -1763,15 +1776,15 @@ postCryptoBroadcastMessageJson2 = do let t = 3 # Second -- WS receive timeout -- Missing charlie let m1 = [(bob, bc, toBase64Text "ciphertext1")] - Util.postOtrBroadcastMessage id alice ac m1 !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = m1} !!! do const 412 === statusCode - assertMismatchWithMessage (Just "1: Only Charlie and his device") [(charlie, Set.singleton cc)] [] [] + assertBroadcastMismatch localDomain (bAPI bcast) [(charlie, Set.singleton cc)] [] [] -- Complete WS.bracketR2 c bob charlie $ \(wsB, wsE) -> do let m2 = [(bob, bc, toBase64Text "ciphertext2"), (charlie, cc, toBase64Text "ciphertext2")] - Util.postOtrBroadcastMessage id alice ac m2 !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = m2} !!! do const 201 === statusCode - assertMismatchWithMessage (Just "No devices expected") [] [] [] + assertBroadcastMismatch localDomain (bAPI bcast) [] [] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext2")) void . liftIO $ @@ -1783,9 +1796,9 @@ postCryptoBroadcastMessageJson2 = do (bob, bc, toBase64Text "ciphertext3"), (charlie, cc, toBase64Text "ciphertext3") ] - Util.postOtrBroadcastMessage id alice ac m3 !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = m3} !!! do const 201 === statusCode - assertMismatchWithMessage (Just "2: Only Alice and her device") [] [(alice, Set.singleton ac)] [] + assertBroadcastMismatch localDomain (bAPI bcast) [] [(alice, Set.singleton ac)] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext3")) void . liftIO $ @@ -1796,66 +1809,26 @@ postCryptoBroadcastMessageJson2 = do WS.bracketR2 c bob charlie $ \(wsB, wsE) -> do deleteClient charlie cc (Just defPassword) !!! const 200 === statusCode let m4 = [(bob, bc, toBase64Text "ciphertext4"), (charlie, cc, toBase64Text "ciphertext4")] - Util.postOtrBroadcastMessage id alice ac m4 !!! do + Util.postBroadcast (q alice) ac bcast {bMessage = m4} !!! do const 201 === statusCode - assertMismatchWithMessage (Just "3: Only Charlie and his device") [] [] [(charlie, Set.singleton cc)] + assertBroadcastMismatch localDomain (bAPI bcast) [] [] [(charlie, Set.singleton cc)] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext4")) -- charlie should not get it assertNoMsg wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext4")) -postCryptoBroadcastMessageProto :: TestM () -postCryptoBroadcastMessageProto = do +postCryptoBroadcastMessageNoTeam :: Broadcast -> TestM () +postCryptoBroadcastMessageNoTeam bcast = do localDomain <- viewFederationDomain - let q :: Id a -> Qualified (Id a) - q = (`Qualified` localDomain) - -- similar to postCryptoBroadcastMessageJson, postCryptoBroadcastMessageJsonReportMissingBody except uses protobuf - - c <- view tsCannon - -- Team1: Alice, Bob. Team2: Charlie. Regular user: Dan. Connect Alice,Charlie,Dan - (alice, tid) <- Util.createBindingTeam - bob <- view userId <$> Util.addUserToTeam alice tid - assertQueue "add bob" $ tUpdate 2 [alice] - refreshIndex - (charlie, _) <- Util.createBindingTeam - refreshIndex - ac <- Util.randomClient alice (someLastPrekeys !! 0) - bc <- Util.randomClient bob (someLastPrekeys !! 1) - cc <- Util.randomClient charlie (someLastPrekeys !! 2) - (dan, dc) <- randomUserWithClient (someLastPrekeys !! 3) - connectUsers alice (list1 charlie [dan]) - -- Complete: Alice broadcasts a message to Bob,Charlie,Dan - let t = 1 # Second -- WS receive timeout - let ciphertext = toBase64Text "hello bob" - WS.bracketRN c [alice, bob, charlie, dan] $ \ws@[_, wsB, wsC, wsD] -> do - let msg = otrRecipients [(bob, [(bc, ciphertext)]), (charlie, [(cc, ciphertext)]), (dan, [(dc, ciphertext)])] - Util.postProtoOtrBroadcast alice ac msg !!! do - const 201 === statusCode - assertMismatch [] [] [] - -- Bob should get the broadcast (team member of alice) - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr' (toBase64Text "data") (q (selfConv bob)) (q alice) ac bc ciphertext) - -- Charlie should get the broadcast (contact of alice and user of teams feature) - void . liftIO $ WS.assertMatch t wsC (wsAssertOtr' (toBase64Text "data") (q (selfConv charlie)) (q alice) ac cc ciphertext) - -- Dan should get the broadcast (contact of alice and not user of teams feature) - void . liftIO $ WS.assertMatch t wsD (wsAssertOtr' (toBase64Text "data") (q (selfConv dan)) (q alice) ac dc ciphertext) - -- Alice should not get her own broadcast - WS.assertNoEvent timeout ws - let inbody = Just [bob] -- body triggers report - inquery = (queryItem "report_missing" (toByteString' alice)) -- query doesn't - msg = otrRecipients [(alice, [(ac, ciphertext)])] - Util.postProtoOtrBroadcast' inbody inquery alice ac msg - !!! const 412 === statusCode - -postCryptoBroadcastMessageNoTeam :: TestM () -postCryptoBroadcastMessageNoTeam = do (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) + let qalice = Qualified alice localDomain (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) connectUsers alice (list1 bob []) let msg = [(bob, bc, toBase64Text "ciphertext1")] - Util.postOtrBroadcastMessage id alice ac msg !!! const 404 === statusCode + Util.postBroadcast qalice ac bcast {bMessage = msg} !!! const 404 === statusCode -postCryptoBroadcastMessage100OrMaxConns :: TestM () -postCryptoBroadcastMessage100OrMaxConns = do +postCryptoBroadcastMessage100OrMaxConns :: Broadcast -> TestM () +postCryptoBroadcastMessage100OrMaxConns bcast = do localDomain <- viewFederationDomain c <- view tsCannon (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) @@ -1868,9 +1841,9 @@ postCryptoBroadcastMessage100OrMaxConns = do WS.bracketRN c (bob : (fst <$> others)) $ \ws -> do let f (u, clt) = (u, clt, toBase64Text "ciphertext") let msg = (bob, bc, toBase64Text "ciphertext") : (f <$> others) - Util.postOtrBroadcastMessage id alice ac msg !!! do + Util.postBroadcast qalice ac bcast {bMessage = msg} !!! do const 201 === statusCode - assertMismatch [] [] [] + assertBroadcastMismatch localDomain (bAPI bcast) [] [] [] let qbobself = Qualified (selfConv bob) localDomain void . liftIO $ WS.assertMatch t (Imports.head ws) (wsAssertOtr qbobself qalice ac bc (toBase64Text "ciphertext")) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index e0d0af359af..73fd845971e 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -42,11 +42,12 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Code as Code import qualified Data.Currency as Currency import Data.Data (Proxy (Proxy)) +import Data.Default import Data.Domain import qualified Data.Handle as Handle import qualified Data.HashMap.Strict as HashMap import Data.Id -import Data.Json.Util (UTCTimeMillis) +import Data.Json.Util hiding ((#)) import Data.LegalHold (defUserLegalHoldStatus) import Data.List.NonEmpty (NonEmpty) import Data.List1 as List1 @@ -673,7 +674,7 @@ postOtrMessage' reportMissing f u d c rec = do . zUser u . zConn "conn" . zType "access" - . json (mkOtrPayload d rec reportMissing) + . json (mkOtrPayload d rec reportMissing "ZXhhbXBsZQ==") postProteusMessageQualifiedWithMockFederator :: UserId -> @@ -711,30 +712,86 @@ postProteusMessageQualified senderUser senderClient (Qualified conv domain) reci . contentProtobuf . bytes (Protolens.encodeMessage protoMsg) --- | FUTUREWORK: remove first argument, it's 'id' in all calls to this function! -postOtrBroadcastMessage :: (Request -> Request) -> UserId -> ClientId -> [(UserId, ClientId, Text)] -> TestM ResponseLBS -postOtrBroadcastMessage req usrs clt rcps = do - g <- view tsGalley - postOtrBroadcastMessage' g Nothing req usrs clt rcps +data BroadcastAPI + = BroadcastLegacyQueryParams + | BroadcastLegacyBody + | BroadcastQualified + +broadcastAPIName :: BroadcastAPI -> String +broadcastAPIName BroadcastLegacyQueryParams = "legacy API with query parameters only" +broadcastAPIName BroadcastLegacyBody = "legacy API with report_missing in the body" +broadcastAPIName BroadcastQualified = "qualified API" + +data BroadcastType = BroadcastJSON | BroadcastProto + +broadcastTypeName :: BroadcastType -> String +broadcastTypeName BroadcastJSON = "json" +broadcastTypeName BroadcastProto = "protobuf" --- | 'postOtrBroadcastMessage' with @"report_missing"@ in body. -postOtrBroadcastMessage' :: (Monad m, MonadCatch m, MonadIO m, MonadHttp m, MonadFail m, HasCallStack) => (Request -> Request) -> Maybe [UserId] -> (Request -> Request) -> UserId -> ClientId -> [(UserId, ClientId, Text)] -> m ResponseLBS -postOtrBroadcastMessage' g reportMissingBody f u d rec = +data Broadcast = Broadcast + { bAPI :: BroadcastAPI, + bType :: BroadcastType, + bMessage :: [(UserId, ClientId, Text)], + bData :: Text, + bReport :: Maybe [UserId], + bReq :: Request -> Request + } + +instance Default Broadcast where + def = Broadcast BroadcastLegacyQueryParams BroadcastJSON mempty "ZXhhbXBsZQ==" mempty id + +postBroadcast :: + (MonadIO m, MonadHttp m, HasGalley m) => + Qualified UserId -> + ClientId -> + Broadcast -> + m ResponseLBS +postBroadcast lu c b = do + let u = qUnqualified lu + g <- viewGalley + let (bodyReport, queryReport) = case bAPI b of + BroadcastLegacyQueryParams -> (Nothing, maybe id mkOtrReportMissing (bReport b)) + _ -> (bReport b, id) + let bdy = case (bAPI b, bType b) of + (BroadcastQualified, BroadcastJSON) -> error "JSON not supported for the qualified broadcast API" + (BroadcastQualified, BroadcastProto) -> + let m = + Protolens.encodeMessage $ + mkQualifiedOtrPayload + c + (map ((_1 %~ (lu $>)) . (_3 %~ fromBase64TextLenient)) (bMessage b)) + (fromBase64TextLenient (bData b)) + ( maybe + MismatchReportAll + (MismatchReportOnly . Set.fromList . map (lu $>)) + (bReport b) + ) + in contentProtobuf . bytes m + (_, BroadcastJSON) -> json (mkOtrPayload c (bMessage b) bodyReport (bData b)) + (_, BroadcastProto) -> + let m = + runPut . encodeMessage $ + mkOtrProtoMessage c (otrRecipients (bMessage b)) bodyReport (bData b) + in contentProtobuf . bytes m + let name = case bAPI b of BroadcastQualified -> "proteus"; _ -> "otr" post $ - g - . f - . paths ["broadcast", "otr", "messages"] + g . bReq b + . paths ["broadcast", name, "messages"] . zUser u . zConn "conn" . zType "access" - . json (mkOtrPayload d rec reportMissingBody) + . queryReport + . bdy -mkOtrPayload :: ClientId -> [(UserId, ClientId, Text)] -> Maybe [UserId] -> Value -mkOtrPayload sender rec reportMissingBody = +mkOtrReportMissing :: [UserId] -> Request -> Request +mkOtrReportMissing = queryItem "report_missing" . BS.intercalate "," . map toByteString' + +mkOtrPayload :: ClientId -> [(UserId, ClientId, Text)] -> Maybe [UserId] -> Text -> Value +mkOtrPayload sender rec reportMissingBody ad = object [ "sender" .= sender, "recipients" .= (HashMap.map toJSON . HashMap.fromListWith HashMap.union $ map mkOtrMessage rec), - "data" .= Just ("data" :: Text), + "data" .= Just ad, "report_missing" .= reportMissingBody ] @@ -750,7 +807,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 - let m = runPut (encodeMessage $ mkOtrProtoMessage d rec reportMissing) + let m = runPut (encodeMessage $ mkOtrProtoMessage d rec reportMissing "ZXhhbXBsZQ==") in post $ g . modif @@ -761,30 +818,13 @@ postProtoOtrMessage' reportMissing modif u d c rec = do . contentProtobuf . bytes m -postProtoOtrBroadcast :: UserId -> ClientId -> OtrRecipients -> TestM ResponseLBS -postProtoOtrBroadcast = postProtoOtrBroadcast' Nothing id - -postProtoOtrBroadcast' :: Maybe [UserId] -> (Request -> Request) -> UserId -> ClientId -> OtrRecipients -> TestM ResponseLBS -postProtoOtrBroadcast' reportMissing modif u d rec = do - g <- view tsGalley - let m = runPut (encodeMessage $ mkOtrProtoMessage d rec reportMissing) - in post $ - g - . modif - . paths ["broadcast", "otr", "messages"] - . zUser u - . zConn "conn" - . zType "access" - . contentProtobuf - . bytes m - -mkOtrProtoMessage :: ClientId -> OtrRecipients -> Maybe [UserId] -> Proto.NewOtrMessage -mkOtrProtoMessage sender rec reportMissing = +mkOtrProtoMessage :: ClientId -> OtrRecipients -> Maybe [UserId] -> Text -> Proto.NewOtrMessage +mkOtrProtoMessage sender rec reportMissing ad = let rcps = protoFromOtrRecipients rec sndr = Proto.fromClientId sender rmis = Proto.fromUserId <$> fromMaybe [] reportMissing in Proto.newOtrMessage sndr rcps - & Proto.newOtrMessageData ?~ "data" + & Proto.newOtrMessageData ?~ fromBase64TextLenient ad & Proto.newOtrMessageReportMissing .~ rmis getConvs :: UserId -> Maybe (Either [ConvId] ConvId) -> Maybe Int32 -> TestM ResponseLBS @@ -1399,7 +1439,7 @@ wsAssertOtr :: Text -> Notification -> IO () -wsAssertOtr = wsAssertOtr' "data" +wsAssertOtr = wsAssertOtr' "ZXhhbXBsZQ==" wsAssertOtr' :: HasCallStack => @@ -1924,6 +1964,21 @@ assertExpected msg expected tparser = where addTitle s = unlines [msg, s] +assertBroadcastMismatch :: + Domain -> + BroadcastAPI -> + [(UserId, Set ClientId)] -> + [(UserId, Set ClientId)] -> + [(UserId, Set ClientId)] -> + Assertions () +assertBroadcastMismatch localDomain BroadcastQualified = + \m r d -> assertMismatchQualified mempty (mk m) (mk r) (mk d) + where + mk :: [(UserId, Set ClientId)] -> Client.QualifiedUserClients + mk [] = mempty + mk uc = Client.QualifiedUserClients . Map.singleton localDomain . Map.fromList $ uc +assertBroadcastMismatch _ _ = assertMismatch + assertMismatchWithMessage :: HasCallStack => Maybe String -> @@ -1964,10 +2019,13 @@ assertMismatchQualified failedToSend missing redundant deleted = do assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe) -otrRecipients :: [(UserId, [(ClientId, Text)])] -> OtrRecipients -otrRecipients = OtrRecipients . UserClientMap . buildMap - where - buildMap = fmap Map.fromList . Map.fromList +otrRecipients :: [(UserId, ClientId, Text)] -> OtrRecipients +otrRecipients = + OtrRecipients + . UserClientMap + . fmap Map.fromList + . foldr (uncurry Map.insert . fmap pure) mempty + . map (\(a, b, c) -> (a, (b, c))) genRandom :: (Q.Arbitrary a, MonadIO m) => m a genRandom = liftIO . Q.generate $ Q.arbitrary