From 756c2952f285bfdb4b2a465764e30106611d0d78 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 25 Oct 2022 18:02:06 +0000 Subject: [PATCH] S2S: Re-implement and re-enable personFollowF --- src/Vervis/Federation/Offer.hs | 241 ++++++++++++++++++++++++--------- src/Vervis/Handler/Person.hs | 7 +- vervis.cabal | 2 +- 3 files changed, 178 insertions(+), 72 deletions(-) diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 658e7cc..8e830fe 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -13,18 +13,20 @@ - . -} +{-# LANGUAGE RankNTypes #-} + module Vervis.Federation.Offer - ( sharerAcceptF + ( --sharerAcceptF - , sharerRejectF + --, sharerRejectF - , sharerFollowF - , projectFollowF - , repoFollowF + personFollowF + --, projectFollowF + --, repoFollowF - , sharerUndoF - , projectUndoF - , repoUndoF + --, sharerUndoF + --, projectUndoF + --, repoUndoF ) where @@ -50,6 +52,7 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Traversable import Database.Persist +import Database.Persist.Sql import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) @@ -63,7 +66,6 @@ import qualified Data.Text.Lazy as TL import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -77,7 +79,8 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient +import Vervis.Cloth +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util @@ -85,9 +88,12 @@ import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket -import Vervis.Patch +import Vervis.Persist.Actor +import Vervis.Recipient import Vervis.Ticket +import Vervis.Web.Delivery +{- sharerAcceptF :: KeyHashid Person -> UTCTime @@ -100,7 +106,6 @@ sharerAcceptF sharerAcceptF recipHash now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) mresult) = do error "sharerAcceptF temporarily disabled" -{- mres <- lift $ runDB $ do @@ -238,6 +243,7 @@ sharerAcceptF recipHash now author body mfwd luAccept (Accept (ObjURI hOffer luO ) -} +{- sharerRejectF :: KeyHashid Person -> UTCTime @@ -251,7 +257,6 @@ sharerRejectF recipHash now author body mfwd luReject (Reject (ObjURI hOffer luO error "sharerRejectF temporarily disabled" -{- @@ -292,6 +297,137 @@ sharerRejectF recipHash now author body mfwd luReject (Reject (ObjURI hOffer luO lift $ delete frrid -} +followF + :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) + => (Route App -> ExceptT Text Handler a) + -> (r -> ActorId) + -> Bool + -> (Key r -> Actor -> a -> ExceptT Text AppDB FollowerSetId) + -> (a -> AppDB RecipientRoutes) + -> (forall f. f r -> LocalActorBy f) + -> (a -> Handler [Aud URIMode]) + -> UTCTime + -> KeyHashid r + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Follow URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +followF parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipHash author body mfwd luFollow (AP.Follow uObject _ hide) = (,Nothing) <$> do + + -- Check input + recipID <- decodeKeyHashid404 recipHash + followee <- nameExceptT "Follow object" $ do + route <- do + routeOrRemote <- parseFedURI uObject + case routeOrRemote of + Left route -> pure route + Right _ -> throwE "Remote, so definitely not me/mine" + parseFollowee route + verifyNothingE + (AP.activityCapability $ actbActivity body) + "Capability not needed" + + maybeHttp <- runDBExcept $ do + + -- Find recipient actor in DB, returning 404 if doesn't exist because + -- we're in the actor's inbox post handler + recip <- lift $ get404 recipID + let recipActorID = grabActor recip + recipActor <- lift $ getJust recipActorID + + -- Insert the Follow to actor's inbox + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread + for mractid $ \ followID -> do + + -- Find followee in DB + followerSetID <- getFollowee recipID recipActor followee + + -- Verify not already following us + let followerID = remoteAuthorId author + maybeFollow <- + lift $ getBy $ UniqueRemoteFollow followerID followerSetID + verifyNothingE maybeFollow "You're already following this object" + + -- Forward the Follow activity to relevant local stages, and + -- schedule delivery for unavailable remote members of them + maybeHttpFwdFollow <- lift $ for mfwd $ \ (localRecips, sig) -> do + sieve <- getSieve followee + forwardActivityDB + (actbBL body) localRecips sig recipActorID + (makeLocalActor recipHash) sieve followID + + -- Record the new follow in DB + acceptID <- + lift $ insertEmptyOutboxItem (actorOutbox recipActor) now + lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID + + -- Prepare an Accept activity and insert to actor's outbox + (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ prepareAccept followee + _luAccept <- lift $ updateOutboxItem (makeLocalActor recipID) acceptID actionAccept + + -- Deliver the Accept to local recipients, and schedule delivery + -- for unavailable remote recipients + deliverHttpAccept <- + deliverActivityDB + (makeLocalActor recipHash) recipActorID + localRecipsAccept remoteRecipsAccept fwdHostsAccept + acceptID actionAccept + + -- Return instructions for HTTP inbox-forwarding of the Follow + -- activity, and for HTTP delivery of the Accept activity to + -- remote recipients + return (maybeHttpFwdFollow, deliverHttpAccept) + + -- Launch asynchronous HTTP forwarding of the Follow activity and HTTP + -- delivery of the Accept activity + case maybeHttp of + Nothing -> + return "I already have this activity in my inbox, doing nothing" + Just (maybeHttpFwdFollow, deliverHttpAccept) -> do + for_ maybeHttpFwdFollow $ forkWorker "followF inbox-forwarding" + forkWorker "followF Accept HTTP delivery" deliverHttpAccept + return $ + case maybeHttpFwdFollow of + Nothing -> "Recorded follow, no inbox-forwarding to do" + Just _ -> + "Recorded follow and ran inbox-forwarding of the Follow" + + where + + prepareAccept followee = do + encodeRouteHome <- getEncodeRouteHome + + ra <- getJust $ remoteAuthorId author + + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audSender = + AudRemote hAuthor + [luAuthor] + (maybeToList $ remoteActorFollowers ra) + + audsRecip <- lift $ makeAudience followee + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ audSender : audsRecip + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hAuthor luFollow + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + {- followF :: (Route App -> Maybe a) @@ -419,61 +555,33 @@ followF return (obiid, doc) -} -sharerFollowF - :: KeyHashid Person - -> UTCTime +personFollowF + :: UTCTime + -> KeyHashid Person -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.Follow URIMode - -> ExceptT Text Handler Text -sharerFollowF recipHash = - error "sharerFollowF temporarily disabled" - + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +personFollowF now recipPersonHash = + followF + (\case + PersonR p | p == recipPersonHash -> pure () + _ -> throwE "Asking to follow someone else" + ) + personActor + True + (\ _recipPersonID recipPersonActor () -> + pure $ actorFollowers recipPersonActor + ) + (\ () -> pure $ makeRecipientSet [] []) + LocalActorPerson + (\ () -> pure []) + now + recipPersonHash {- - - - followF - objRoute - (SharerR shr) - getRecip - (personInbox . fst) - (personOutbox . fst) - followers - (SharerOutboxItemR shr) - where - objRoute (SharerR shr') - | shr == shr' = Just Nothing - objRoute (SharerTicketR shr' talkhid) - | shr == shr' = Just $ Just (talkhid, False) - objRoute (SharerProposalR shr' talkhid) - | shr == shr' = Just $ Just (talkhid, True) - objRoute _ = Nothing - - getRecip mtalkhid = do - sid <- getKeyBy404 $ UniqueSharer shr - p <- getValBy404 $ UniquePersonIdent sid - mmt <- for mtalkhid $ \ (talkhid, patch) -> runMaybeT $ do - talid <- decodeKeyHashidM talkhid - if patch - then do - (_, Entity _ lt, _, _, _, _) <- MaybeT $ getSharerProposal shr talid - return lt - else do - (_, Entity _ lt, _, _, _) <- MaybeT $ getSharerTicket shr talid - return lt - return $ - case mmt of - Nothing -> Just (p, Nothing) - Just Nothing -> Nothing - Just (Just t) -> Just (p, Just t) - - followers (p, Nothing) = personFollowers p - followers (_, Just lt) = localTicketFollowers lt --} - projectFollowF :: KeyHashid Project -> UTCTime @@ -486,7 +594,6 @@ projectFollowF projectFollowF deckHash = error "projectFollowF temporarily disabled" -{- followF @@ -522,6 +629,7 @@ projectFollowF deckHash = followers (_, Just lt) = localTicketFollowers lt -} +{- repoFollowF :: KeyHashid Repo -> UTCTime @@ -535,7 +643,6 @@ repoFollowF repoHash = error "repoFollowF temporarily disabled" -{- followF @@ -570,6 +677,7 @@ repoFollowF repoHash = followers (_, Just lt) = localTicketFollowers lt -} +{- getFollow (Left _) = return Nothing getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid @@ -658,7 +766,6 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do error "sharerUndoF temporarily disabled" -{- object <- parseActivity uObj @@ -744,6 +851,7 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do return ([ticketFollowers], [audAuthor, audTicket]) -} +{- projectUndoF :: KeyHashid Project -> UTCTime @@ -759,7 +867,6 @@ projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do -{- @@ -846,6 +953,7 @@ projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do return ([ticketFollowers], [audAuthor, audTicket]) -} +{- repoUndoF :: KeyHashid Repo -> UTCTime @@ -860,7 +968,6 @@ repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do -{- object <- parseActivity uObj diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 28c89f1..0161ac7 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -73,6 +73,7 @@ import Vervis.Data.Actor import Vervis.Federation.Auth import Vervis.Federation.Collab import Vervis.Federation.Discussion +import Vervis.Federation.Offer import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -210,10 +211,8 @@ postPersonInboxR recipPersonHash = postInbox handle AP.CreateNote _ note -> (,Nothing) <$> personCreateNoteF now recipPersonHash author body mfwd luActivity note _ -> return ("Unsupported create object type for people", Nothing) - {- - FollowActivity follow -> - (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow - -} + AP.FollowActivity follow -> + personFollowF now recipPersonHash author body mfwd luActivity follow AP.GrantActivity grant -> personGrantF now recipPersonHash author body mfwd luActivity grant AP.InviteActivity invite -> diff --git a/vervis.cabal b/vervis.cabal index 375c6fb..0887c8e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -150,7 +150,7 @@ library Vervis.Federation.Auth Vervis.Federation.Collab Vervis.Federation.Discussion - --Vervis.Federation.Offer + Vervis.Federation.Offer --Vervis.Federation.Push Vervis.Federation.Ticket Vervis.Federation.Util