From 93cf861ed03c785f165880422fd191f7679b5ffe Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 2 May 2019 02:06:47 +0000 Subject: [PATCH] When delivering a comment on a remote ticket, enable inbox forwarding In the new inbox forwarding scheme, we use an additional special HTTP signature to indicate that we allow or expect forwarding, and to allow that forwarding to later be verified. When delivering a comment on a remote ticket, we'd like the project to do inbox forwarding. Based on the URI alone, it's impossible to tell which recipient is the project, and I guess there are various tricks we could use here, but for now a very simple solution is used: Enable forwarding for all remote recipients whose host is the same as the ticket's host. --- src/Vervis/Federation.hs | 81 ++++++++++++++++++++++++---------------- 1 file changed, 48 insertions(+), 33 deletions(-) diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 085580f..51a9069 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -822,11 +822,12 @@ runDBExcept action = do deliverHttp :: (MonadSite m, SiteEnv m ~ App) => Doc Activity + -> Maybe LocalURI -> Text -> LocalURI -> m (Either APPostError (Response ())) -deliverHttp doc h luInbox = - postActivity (l2f h luInbox) Nothing doc +deliverHttp doc mfwd h luInbox = + postActivity (l2f h luInbox) (Left . l2f h <$> mfwd) doc isInstanceErrorHttp (InvalidUrlException _ _) = False isInstanceErrorHttp (HttpExceptionRequest _ hec) = @@ -934,7 +935,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c Left (FedError t) -> throwE t Right r -> return r let handleDeliveryError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e) - lift $ forkHandler handleDeliveryError $ deliverRemoteHttp obid doc remotesHttp + lift $ forkHandler handleDeliveryError $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp return lmid where verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m () @@ -1176,9 +1177,15 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c fst3 :: (a, b, c) -> a fst3 (x, _, _) = x + fst4 :: (a, b, c, d) -> a + fst4 (x, _, _, _) = x + thd3 :: (a, b, c) -> c thd3 (_, _, z) = z + fourth4 :: (a, b, c, d) -> d + fourth4 (_, _, _, w) = w + -- Deliver to local recipients. For local users, find in DB and deliver. -- For local collections, expand them, deliver to local users, and return a -- list of remote actors found in them. @@ -1187,7 +1194,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c -> OutboxItemId -> [ShrIdent] -> Maybe (SharerId, FollowerSetId) - -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))] + -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] deliverLocal pidAuthor obid recips mticket = do recipPids <- traverse getPersonId $ nub recips when (pidAuthor `elem` recipPids) $ @@ -1238,7 +1245,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c -- instances aren't repeated. Use a custom merge -- where we can unionBy or LO.unionBy whenever both -- lists have the same instance. - , map (second $ NE.nubBy ((==) `on` fst3)) $ mergeConcat teamRemotes fsRemotes + , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes ) lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid return remotes @@ -1258,11 +1265,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c case id_ of Left pid -> return pid Right _gid -> throwE "Local Note addresses a local group" - groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))] + groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples where - toTuples (iid, h, rsid, lu, ms) = ((iid, h), (rsid, lu, ms)) - getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]) + toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms)) + getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]) getTicketTeam sid = do id_ <- getPersonOrGroupId sid (,[]) <$> case id_ of @@ -1270,7 +1277,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c Right gid -> map (groupMemberPerson . entityVal) <$> selectList [GroupMemberGroup ==. gid] [] - getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]) + getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]) getFollowers fsid = do local <- selectList [FollowTarget ==. fsid] [] remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do @@ -1282,14 +1289,15 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c ( i E.^. InstanceId , i E.^. InstanceHost , rs E.^. RemoteActorId + , rs E.^. RemoteActorIdent , rs E.^. RemoteActorInbox , rs E.^. RemoteActorErrorSince ) return ( map (followPerson . entityVal) local , groupRemotes $ - map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox, E.Value msince) -> - (iid, h, rsid, luInbox, msince) + map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) -> + (iid, h, rsid, luActor, luInbox, msince) ) remote ) @@ -1312,9 +1320,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c deliverRemoteDB :: OutboxItemId -> [FedURI] - -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))] + -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> AppDB - ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, DeliveryId))] + ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] ) @@ -1334,7 +1342,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c Nothing -> Left lu Just e -> Right $ case e of - Left (Entity raid ra) -> Left (raid, remoteActorInbox ra, remoteActorErrorSince ra) + Left (Entity raid ra) -> Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) Right (Entity uraid ura) -> Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura) let (unknown, newKnown) = partitionEithers $ NE.toList es (fetched, unfetched) = partitionEithers newKnown @@ -1343,9 +1351,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips' stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' -- TODO see the earlier TODO about merge, it applies here too - allFetched = map (second $ NE.nubBy ((==) `on` fst3)) $ mergeConcat known moreKnown + allFetched = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat known moreKnown fetchedDeliv <- for allFetched $ \ (i, rs) -> - (i,) <$> insertMany' (\ (raid, _, msince) -> Delivery raid obid $ isNothing msince) rs + (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid $ isNothing msince) rs unfetchedDeliv <- for unfetched $ \ (i, rs) -> (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid $ isNothing msince) rs unknownDeliv <- for stillUnknown $ \ (i, lus) -> do @@ -1353,8 +1361,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid True) rs return - ( takeNoError fetchedDeliv - , takeNoError unfetchedDeliv + ( takeNoError4 fetchedDeliv + , takeNoError3 unfetchedDeliv , map (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk)) unknownDeliv @@ -1370,21 +1378,28 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c Just y' | length x == length y' -> NE.zip x y' _ -> error "insertMany' returned different length!" - takeNoError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) + takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) + takeNoError3 = takeNoError noError where noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk) noError ((_ , _ , Just _ ), _ ) = Nothing + takeNoError4 = takeNoError noError + where + noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk) + noError ((_ , _ , _ , Just _ ), _ ) = Nothing deliverRemoteHttp - :: OutboxItemId + :: Text + -> OutboxItemId -> Doc Activity - -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, DeliveryId))] + -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] ) -> Handler () - deliverRemoteHttp obid doc (fetched, unfetched, unknown) = do - let deliver = deliverHttp doc + deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do + let deliver fwd h = + deliverHttp doc (if h == hContext then Just fwd else Nothing) h now <- liftIO getCurrentTime traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverUnfetched deliver now) unfetched @@ -1392,8 +1407,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c where fork = forkHandler $ \ e -> logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e) deliverFetched deliver now ((_, h), recips@(r :| rs)) = do - let (raid, luInbox, dlid) = r - e <- deliver h luInbox + let (raid, luActor, luInbox, dlid) = r + e <- deliver luActor h luInbox let e' = case e of Left err -> if isInstanceErrorP err @@ -1403,8 +1418,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c case e' of Nothing -> runDB $ do let recips' = NE.toList recips - updateWhere [RemoteActorId <-. map fst3 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - updateWhere [DeliveryId <-. map thd3 recips'] [DeliveryRunning =. False] + updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False] Just success -> do runDB $ if success @@ -1412,9 +1427,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c else do updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] update dlid [DeliveryRunning =. False] - for_ rs $ \ (raid, luInbox, dlid) -> + for_ rs $ \ (raid, luActor, luInbox, dlid) -> fork $ do - e <- deliver h luInbox + e <- deliver luActor h luInbox runDB $ case e of Left _err -> do @@ -1442,7 +1457,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c e <- fetchRemoteActor iid h luActor case e of Right (Right (Entity raid ra)) -> do - e' <- deliver h $ remoteActorInbox ra + e' <- deliver luActor h $ remoteActorInbox ra runDB $ case e' of Left _ -> do @@ -1458,7 +1473,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] update udlid [UnlinkedDeliveryRunning =. False] Just (Entity raid ra) -> do - e'' <- deliver h $ remoteActorInbox ra + e'' <- deliver luActor h $ remoteActorInbox ra runDB $ case e'' of Left _ -> do @@ -1586,7 +1601,7 @@ retryOutboxDelivery = do deliverLinked deliver now ((_, h), recips) = do waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do waitsD <- for delivs $ \ (dlid, doc) -> fork $ do - e <- deliver doc h inbox + e <- deliver doc Nothing h inbox case e of Left _err -> return False Right _resp -> do @@ -1610,7 +1625,7 @@ retryOutboxDelivery = do case e of Right (Right (Entity raid ra)) -> do waitsD <- for delivs $ \ (udlid, obid, doc) -> fork $ do - e' <- deliver doc h $ remoteActorInbox ra + e' <- deliver doc Nothing h $ remoteActorInbox ra case e' of Left _err -> do runSiteDB $ do