S2S: Re-implement and re-enable personFollowF

src/Vervis/Federation/Offer.hs

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

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

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