From 93cf861ed03c785f165880422fd191f7679b5ffe Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
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