S2S: Group: Implement Follow & Undo handlers, adapted from Project

src/Vervis/Actor/Group.hs

@@ -117,10 +117,161 @@ groupCreate now groupID verse (AP.Create obj _muTarget) =
 
         _ -> throwE "Unsupported Create object for Group"
 
+-- Meaning: An actor is following someone/something
+-- Behavior:
+--      * Verify the target is me
+--      * Record the follow in DB
+--      * Publish and send an Accept to the sender and its followers
+groupFollow
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Follow URIMode
+    -> ActE (Text, Act (), Next)
+groupFollow now recipGroupID verse follow = do
+    recipGroupHash <- encodeKeyHashid recipGroupID
+    actorFollow
+        (\case
+            GroupR d | d == recipGroupHash -> pure ()
+            _ -> throwE "Asking to follow someone else"
+        )
+        groupActor
+        False
+        (\ recipGroupActor () -> pure $ actorFollowers recipGroupActor)
+        (\ _ -> pure $ makeRecipientSet [] [])
+        LocalActorGroup
+        (\ _ -> pure [])
+        now recipGroupID verse follow
+
+-- Meaning: An actor is undoing some previous action
+-- Behavior:
+--      * If they're undoing their Following of me:
+--          * Record it in my DB
+--          * Publish and send an Accept only to the sender
+--      * Otherwise respond with an error
+groupUndo
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Undo URIMode
+    -> ActE (Text, Act (), Next)
+groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
+
+    -- Check input
+    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
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (groupRecip, actorRecip) <- lift $ do
+            p <- getJust recipGroupID
+            (p,) <$> getJust (groupActor p)
+
+        -- Insert the Undo to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+        for mractid $ \ _undoDB -> do
+
+            maybeUndo <- runMaybeT $ do
+
+                -- Find the undone activity in our DB
+                undoneDB <- MaybeT $ getActivity undone
+
+                let followers = actorFollowers actorRecip
+                asum
+                    [ tryUnfollow followers undoneDB authorIdMsig
+                    ]
+
+            (sieve, audience) <-
+                fromMaybeE
+                    maybeUndo
+                    "Undone activity isn't a Follow related to me"
+
+            -- Prepare an Accept activity and insert to group's outbox
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
+            _luAccept <- lift $ updateOutboxItem' (LocalActorGroup recipGroupID) acceptID actionAccept
+
+            return (groupActor groupRecip, sieve, acceptID, accept)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorGroup recipGroupID) actorID sieve
+            lift $ sendActivity
+                (LocalActorGroup recipGroupID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            done
+                "Undid the Follow, forwarded the Undo and published Accept"
+
+    where
+
+    tryUnfollow groupFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do
+        Entity followID follow <-
+            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
+        let followerID = followActor follow
+            followerSetID = followTarget follow
+        verifyTargetMe followerSetID
+        unless (followerID == actorID) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete followID
+        audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
+        return (makeRecipientSet [] [], [audSenderOnly])
+        where
+        verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID
+    tryUnfollow groupFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        verifyTargetMe followerSetID
+        unless (followerID == remoteAuthorId author) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete remoteFollowID
+        audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
+        return (makeRecipientSet [] [], [audSenderOnly])
+        where
+        verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID
+    tryUnfollow _ _ _ = mzero
+
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        uUndo <- getActivityURI authorIdMsig
+        let (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   = uUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
 groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.CreateActivity create -> groupCreate now groupID verse create
+        AP.FollowActivity follow -> groupFollow now groupID verse follow
+        AP.UndoActivity undo     -> groupUndo now groupID verse undo
         _ -> throwE "Unsupported activity type for Group"
 groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"