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