forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Re-implement and re-enable personFollowF

Browse source
This commit is contained in:
fr33domlover 2022-10-25 18:02:06 +00:00
parent f76e80c028
commit 756c2952f2
3 changed files with 178 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

241
src/Vervis/Federation/Offer.hs
View file

@ -13,18 +13,20 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# 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

7
src/Vervis/Handler/Person.hs
View file

@ -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 ->

2
vervis.cabal
View file

@ -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