mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-10 11:16:46 +09:00
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.
This commit is contained in:
fr33domlover
parent
3d9438714b
commit
93cf861ed0
1 changed files with 48 additions and 33 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue