Person: Port Undo{Follow} handler

src/Vervis/Actor/Person.hs

@@ -29,6 +29,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
@@ -217,6 +218,101 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
         (\ () -> pure [])
         now recipPersonID author body mfwd luFollow follow
 
+-- Meaning: A remote actor is undoing some previous action
+-- Behavior:
+--      * Insert to my inbox
+--      * If they're undoing their Following of me:
+--          * Record it in my DB
+--          * Publish and send an Accept only to the sender
+personUndo
+    :: UTCTime
+    -> PersonId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Undo URIMode
+    -> ActE (Text, Act (), Next)
+personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
+
+    -- Check input
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI' uObject
+
+    maybeUndo <- withDBExcept $ do
+
+        -- Grab recipient person from DB
+        (personRecip, actorRecip) <- lift $ do
+            p <- getJust recipPersonID
+            (p,) <$> getJust (personActor p)
+
+        -- Insert the Undo to person's inbox
+        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False
+        for mractid $ \ undoID -> do
+
+            maybeUndo <- runMaybeT $ do
+
+                -- Find the undone activity in our DB
+                undoneDB <- MaybeT $ getActivity undone
+
+                let followers = actorFollowers actorRecip
+                tryUnfollow followers undoneDB
+
+            for maybeUndo $ \ () -> do
+
+                -- Prepare an Accept activity and insert to person's outbox
+                acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                accept@(actionAccept, _, _, _) <- lift $ lift prepareAccept
+                _luAccept <- lift $ updateOutboxItem' (LocalActorPerson recipPersonID) acceptID actionAccept
+
+                return (personActor personRecip, acceptID, accept)
+
+    case maybeUndo of
+        Nothing -> done "I already have this activity in my inbox"
+        Just Nothing -> done "Unrelated to me, just inserted to inbox"
+        Just (Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept))) -> do
+            lift $ sendActivity
+                (LocalActorPerson recipPersonID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID
+                EventAcceptRemoteFollow actionAccept
+            done "Undid the Follow and published Accept"
+
+    where
+
+    tryUnfollow _                 (Left _)                 = mzero
+    tryUnfollow personFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        guard $ followerSetID == personFollowersID
+        unless (followerID == remoteAuthorId author) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete remoteFollowID
+
+    prepareAccept = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+            audSender = AudRemote hAuthor [luAuthor] []
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender]
+
+            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 luUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: A remote actor accepted something
 -- Behavior:
 --      * Insert to my inbox
@@ -620,10 +716,8 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
             personInvite now personID author body mfwd luActivity invite
         AP.JoinActivity join ->
             personJoin now personID author body mfwd luActivity join
-        {-
-        AP.UndoActivity undo ->
-            (,Nothing) <$> personUndoA now personID author body mfwd luActivity undo
-        -}
         AP.RejectActivity reject ->
             personReject now personID author body mfwd luActivity reject
+        AP.UndoActivity undo ->
+            personUndo now personID author body mfwd luActivity undo
         _ -> throwE "Unsupported activity type for Person"

src/Vervis/Federation/Offer.hs

@@ -25,8 +25,8 @@ module Vervis.Federation.Offer
     --, loomFollowF
     --, repoFollowF
 
-      personUndoF
+      --personUndoF
-    , deckUndoF
+      deckUndoF
     , loomUndoF
     , repoUndoF
     )
@@ -550,146 +550,6 @@ repoFollowF now recipRepoHash =
         recipRepoHash
 -}
 
-personUndoF
-    :: UTCTime
-    -> KeyHashid Person
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Undo URIMode
-    -> ExceptT Text Handler Text
-personUndoF now recipPersonHash author body mfwd luUndo (AP.Undo uObject) = do
-
-    -- Check input
-    recipPersonID <- decodeKeyHashid404 recipPersonHash
-    undone <-
-        first (\ (actor, _, item) -> (actor, item)) <$>
-            parseActivityURI uObject
-
-    -- Verify the capability URI, if provided, is one of:
-    --   * Outbox item URI of a local actor, i.e. a local activity
-    --   * A remote URI
-    maybeCapability <-
-        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
-            nameExceptT "Undo capability" $
-                first (\ (actor, _, item) -> (actor, item)) <$>
-                    parseActivityURI uCap
-
-    maybeHttp <- runDBExcept $ do
-
-        -- Find recipient person in DB, returning 404 if doesn't exist because we're
-        -- in the person's inbox post handler
-        (recipPersonActorID, recipPersonActor) <- lift $ do
-            person <- get404 recipPersonID
-            let actorID = personActor person
-            (actorID,) <$> getJust actorID
-
-        -- Insert the Undo to person's inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox recipPersonActor) luUndo False
-        for mractid $ \ undoID -> do
-
-            maybeUndo <- runMaybeT $ do
-
-                -- Find the undone activity in our DB
-                undoneDB <- MaybeT $ getActivity undone
-
-                let followers = actorFollowers recipPersonActor
-                MaybeT $ lift $ runMaybeT $ tryUnfollow followers undoneDB
-
-            for maybeUndo $ \ (remoteFollowID, followerID) -> do
-
-                (sieve, acceptAudience) <- do
-                    (audSenderOnly, _audSenderAndFollowers) <- do
-                        ra <- lift $ getJust $ remoteAuthorId author
-                        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-                        return
-                            ( AudRemote hAuthor [luAuthor] []
-                            , AudRemote hAuthor
-                                [luAuthor]
-                                (maybeToList $ remoteActorFollowers ra)
-                            )
-                    unless (followerID == remoteAuthorId author) $
-                        throwE "Trying to undo someone else's Follow"
-                    lift $ delete remoteFollowID
-                    return
-                        ( makeRecipientSet [] []
-                        , [audSenderOnly]
-                        )
-
-                -- Forward the Undo activity to relevant local stages, and
-                -- schedule delivery for unavailable remote members of them
-                maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
-                    forwardActivityDB
-                        (actbBL body) localRecips sig recipPersonActorID
-                        (LocalActorPerson recipPersonHash) sieve undoID
-
-
-                -- Prepare an Accept activity and insert to person's outbox
-                acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipPersonActor) now
-                (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                    lift . lift $ prepareAccept acceptAudience
-                _luAccept <- lift $ updateOutboxItem (LocalActorPerson recipPersonID) acceptID actionAccept
-
-                -- Deliver the Accept to local recipients, and schedule delivery
-                -- for unavailable remote recipients
-                deliverHttpAccept <-
-                    deliverActivityDB
-                        (LocalActorPerson recipPersonHash) recipPersonActorID
-                        localRecipsAccept remoteRecipsAccept fwdHostsAccept
-                        acceptID actionAccept
-
-                -- Return instructions for HTTP inbox-forwarding of the Undo
-                -- activity, and for HTTP delivery of the Accept activity to
-                -- remote recipients
-                return (maybeHttpFwdUndo, deliverHttpAccept)
-
-    -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
-    -- delivery of the Accept activity
-    case maybeHttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just Nothing -> return "Unrelated to me, just inserted to inbox"
-        Just (Just (maybeHttpFwdUndo, deliverHttpAccept)) -> do
-            forkWorker "personUndoF Accept HTTP delivery" deliverHttpAccept
-            case maybeHttpFwdUndo of
-                Nothing -> return "Undid, no inbox-forwarding to do"
-                Just forwardHttpUndo -> do
-                    forkWorker "personUndoF inbox-forwarding" forwardHttpUndo
-                    return "Undid and ran inbox-forwarding of the Undo"
-
-    where
-
-    tryUnfollow _               (Left _)                 = mzero
-    tryUnfollow personFollowersID (Right remoteActivityID) = do
-        Entity remoteFollowID remoteFollow <-
-            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
-        let followerID = remoteFollowActor remoteFollow
-            followerSetID = remoteFollowTarget remoteFollow
-        guard $ followerSetID == personFollowersID
-        return (remoteFollowID, followerID)
-
-    prepareAccept audience = do
-        encodeRouteHome <- getEncodeRouteHome
-
-        let ObjURI hAuthor _ = remoteAuthorURI author
-
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience audience
-
-            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 luUndo
-                    , AP.acceptResult   = Nothing
-                    }
-                }
-
-        return (action, recipientSet, remoteActors, fwdHosts)
-
 deckUndoF
     :: UTCTime
     -> KeyHashid Deck