naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-01-10 21:56:46 +09:00
Code Activity

When delivering a comment on a remote ticket, enable inbox forwarding

Browse source 
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 2019-05-02 02:06:47 +00:00
parent 3d9438714b
commit 93cf861ed0
1 changed files with 48 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
src/Vervis/Federation.hs
View file

@ -822,11 +822,12 @@ runDBExcept action = do
deliverHttp deliverHttp
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Doc Activity => Doc Activity
-> Maybe LocalURI
-> Text -> Text
-> LocalURI -> LocalURI
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverHttp doc h luInbox = deliverHttp doc mfwd h luInbox =
postActivity (l2f h luInbox) Nothing doc postActivity (l2f h luInbox) (Left . l2f h <$> mfwd) doc
isInstanceErrorHttp (InvalidUrlException _ _) = False isInstanceErrorHttp (InvalidUrlException _ _) = False
isInstanceErrorHttp (HttpExceptionRequest _ hec) = isInstanceErrorHttp (HttpExceptionRequest _ hec) =
@ -934,7 +935,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Left (FedError t) -> throwE t Left (FedError t) -> throwE t
Right r -> return r Right r -> return r
let handleDeliveryError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e) 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 return lmid
where where
verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m () 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 :: (a, b, c) -> a
fst3 (x, _, _) = x fst3 (x, _, _) = x
fst4 :: (a, b, c, d) -> a
fst4 (x, _, _, _) = x
thd3 :: (a, b, c) -> c thd3 :: (a, b, c) -> c
thd3 (_, _, z) = z thd3 (_, _, z) = z
fourth4 :: (a, b, c, d) -> d
fourth4 (_, _, _, w) = w
-- Deliver to local recipients. For local users, find in DB and deliver. -- Deliver to local recipients. For local users, find in DB and deliver.
-- For local collections, expand them, deliver to local users, and return a -- For local collections, expand them, deliver to local users, and return a
-- list of remote actors found in them. -- list of remote actors found in them.
@ -1187,7 +1194,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
-> OutboxItemId -> OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId) -> 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 deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
when (pidAuthor `elem` recipPids) $ 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 -- instances aren't repeated. Use a custom merge
-- where we can unionBy or LO.unionBy whenever both -- where we can unionBy or LO.unionBy whenever both
-- lists have the same instance. -- 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 lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
return remotes return remotes
@ -1258,11 +1265,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
case id_ of case id_ of
Left pid -> return pid Left pid -> return pid
Right _gid -> throwE "Local Note addresses a local group" 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 groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where where
toTuples (iid, h, rsid, lu, ms) = ((iid, h), (rsid, lu, ms)) toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]) getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getTicketTeam sid = do getTicketTeam sid = do
id_ <- getPersonOrGroupId sid id_ <- getPersonOrGroupId sid
(,[]) <$> case id_ of (,[]) <$> case id_ of
@ -1270,7 +1277,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Right gid -> Right gid ->
map (groupMemberPerson . entityVal) <$> map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] [] 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 getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [] local <- selectList [FollowTarget ==. fsid] []
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do 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.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost
, rs E.^. RemoteActorId , rs E.^. RemoteActorId
, rs E.^. RemoteActorIdent
, rs E.^. RemoteActorInbox , rs E.^. RemoteActorInbox
, rs E.^. RemoteActorErrorSince , rs E.^. RemoteActorErrorSince
) )
return return
( map (followPerson . entityVal) local ( map (followPerson . entityVal) local
, groupRemotes $ , groupRemotes $
map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox, E.Value msince) -> map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
(iid, h, rsid, luInbox, msince) (iid, h, rsid, luActor, luInbox, msince)
) )
remote remote
) )
@ -1312,9 +1320,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
deliverRemoteDB deliverRemoteDB
:: OutboxItemId :: OutboxItemId
-> [FedURI] -> [FedURI]
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> AppDB -> 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))]
, [((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 Nothing -> Left lu
Just e -> Just e ->
Right $ case e of 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) Right (Entity uraid ura) -> Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura)
let (unknown, newKnown) = partitionEithers $ NE.toList es let (unknown, newKnown) = partitionEithers $ NE.toList es
(fetched, unfetched) = partitionEithers newKnown (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' unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips'
stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
-- TODO see the earlier TODO about merge, it applies here too -- 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) -> 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) -> unfetchedDeliv <- for unfetched $ \ (i, rs) ->
(i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid $ isNothing msince) rs (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid $ isNothing msince) rs
unknownDeliv <- for stillUnknown $ \ (i, lus) -> do 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 rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus
(i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid True) rs (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid True) rs
return return
( takeNoError fetchedDeliv ( takeNoError4 fetchedDeliv
, takeNoError unfetchedDeliv , takeNoError3 unfetchedDeliv
, map , map
(second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk)) (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
unknownDeliv 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' Just y' | length x == length y' -> NE.zip x y'
_ -> error "insertMany' returned different length!" _ -> 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 where
noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk) noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
noError ((_ , _ , Just _ ), _ ) = Nothing noError ((_ , _ , Just _ ), _ ) = Nothing
takeNoError4 = takeNoError noError
where
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
deliverRemoteHttp deliverRemoteHttp
:: OutboxItemId :: Text
-> OutboxItemId
-> Doc Activity -> 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))]
, [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
) )
-> Handler () -> Handler ()
deliverRemoteHttp obid doc (fetched, unfetched, unknown) = do deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
let deliver = deliverHttp doc let deliver fwd h =
deliverHttp doc (if h == hContext then Just fwd else Nothing) h
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverFetched deliver now) fetched
traverse_ (fork . deliverUnfetched deliver now) unfetched traverse_ (fork . deliverUnfetched deliver now) unfetched
@ -1392,8 +1407,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
where where
fork = forkHandler $ \ e -> logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e) fork = forkHandler $ \ e -> logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
deliverFetched deliver now ((_, h), recips@(r :| rs)) = do deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
let (raid, luInbox, dlid) = r let (raid, luActor, luInbox, dlid) = r
e <- deliver h luInbox e <- deliver luActor h luInbox
let e' = case e of let e' = case e of
Left err -> Left err ->
if isInstanceErrorP err if isInstanceErrorP err
@ -1403,8 +1418,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
case e' of case e' of
Nothing -> runDB $ do Nothing -> runDB $ do
let recips' = NE.toList recips let recips' = NE.toList recips
updateWhere [RemoteActorId <-. map fst3 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
updateWhere [DeliveryId <-. map thd3 recips'] [DeliveryRunning =. False] updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
Just success -> do Just success -> do
runDB $ runDB $
if success if success
@ -1412,9 +1427,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
else do else do
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update dlid [DeliveryRunning =. False] update dlid [DeliveryRunning =. False]
for_ rs $ \ (raid, luInbox, dlid) -> for_ rs $ \ (raid, luActor, luInbox, dlid) ->
fork $ do fork $ do
e <- deliver h luInbox e <- deliver luActor h luInbox
runDB $ runDB $
case e of case e of
Left _err -> do Left _err -> do
@ -1442,7 +1457,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
e <- fetchRemoteActor iid h luActor e <- fetchRemoteActor iid h luActor
case e of case e of
Right (Right (Entity raid ra)) -> do Right (Right (Entity raid ra)) -> do
e' <- deliver h $ remoteActorInbox ra e' <- deliver luActor h $ remoteActorInbox ra
runDB $ runDB $
case e' of case e' of
Left _ -> do Left _ -> do
@ -1458,7 +1473,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
update udlid [UnlinkedDeliveryRunning =. False] update udlid [UnlinkedDeliveryRunning =. False]
Just (Entity raid ra) -> do Just (Entity raid ra) -> do
e'' <- deliver h $ remoteActorInbox ra e'' <- deliver luActor h $ remoteActorInbox ra
runDB $ runDB $
case e'' of case e'' of
Left _ -> do Left _ -> do
@ -1586,7 +1601,7 @@ retryOutboxDelivery = do
deliverLinked deliver now ((_, h), recips) = do deliverLinked deliver now ((_, h), recips) = do
waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
waitsD <- for delivs $ \ (dlid, doc) -> fork $ do waitsD <- for delivs $ \ (dlid, doc) -> fork $ do
e <- deliver doc h inbox e <- deliver doc Nothing h inbox
case e of case e of
Left _err -> return False Left _err -> return False
Right _resp -> do Right _resp -> do
@ -1610,7 +1625,7 @@ retryOutboxDelivery = do
case e of case e of
Right (Right (Entity raid ra)) -> do Right (Right (Entity raid ra)) -> do
waitsD <- for delivs $ \ (udlid, obid, doc) -> fork $ 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 case e' of
Left _err -> do Left _err -> do
runSiteDB $ do runSiteDB $ do