Deck: Port/write Accept, Reject, Follow, Undo

src/Vervis/Actor.hs

@@ -306,6 +306,29 @@ data Event
     | EventAcceptRemoteFollow
     -- ^ A local actor (that I'm following) has accepted a Follow from some
     --   remote actor
+    | EventRemoteUnresolveLocalResourceFwdToFollower RemoteActivityId
+    -- ^ A remote authorized actor unresolved a local ticket, and the local
+    --   deck/loom is forwarding to me because I'm following the deck/loom
+    --   and/or the specific ticket
+    | EventRemoteAcceptInviteLocalResourceFwdToFollower RemoteActivityId
+    -- ^ A remote actor accepted an Invite, and the local resource is
+    --   forwarding the Accept to me because I'm following the resource
+    | EventRemoteApproveJoinLocalResourceFwdToFollower RemoteActivityId
+    -- ^ An authorized remote actor approved a Join, and the local resource is
+    --   forwarding the Accept to me because I'm following the resource
+    | EventGrantAfterRemoteAccept OutboxItemId
+    -- ^ A local resource published a Grant, I'm receiving it because I'm
+    --   following the resource/target, or I'm the inviter/approver/target
+    | EventRemoteRejectInviteLocalResourceFwdToFollower RemoteActivityId
+    -- ^ A remote actor rejected an Invite, and the local resource is
+    --   forwarding the Reject to me because I'm following the resource
+    | EventRemoteForbidJoinLocalResourceFwdToFollower RemoteActivityId
+    -- ^ An authorized remote actor rejected a Join, and the local resource is
+    --   forwarding the Reject to me because I'm following the resource
+    | EventRejectAfterRemoteReject OutboxItemId
+    -- ^ A local resource published a Reject on an Invite/Join, I'm receiving
+    --   it because I'm following the resource/target, or I'm the
+    --   inviter/rejecter/target
     | EventUnknown
     deriving Show
 

src/Vervis/Actor/Common.hs

@@ -0,0 +1,669 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+{-# LANGUAGE RankNTypes #-}
+
+module Vervis.Actor.Common
+    ( actorFollow
+    , topicAccept
+    , topicReject
+    )
+where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
+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.Either
+import Data.Foldable
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
+import Optics.Core
+import Yesod.Persist.Core
+
+import qualified Data.Text as T
+
+import Control.Concurrent.Actor
+import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Database.Persist.Local
+
+import Vervis.Access
+import Vervis.ActivityPub
+import Vervis.Actor
+import Vervis.Actor2
+import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
+import Vervis.Data.Discussion
+import Vervis.FedURI
+import Vervis.Federation.Util
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
+import Vervis.Persist.Discussion
+import Vervis.Ticket
+
+actorFollow
+    :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
+    => (Route App -> ActE a)
+    -> (r -> ActorId)
+    -> Bool
+    -> (Actor -> a -> ActDBE FollowerSetId)
+    -> (a -> ActDB RecipientRoutes)
+    -> (forall f. f r -> LocalActorBy f)
+    -> (a -> Act [Aud URIMode])
+    -> UTCTime
+    -> Key r
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Follow URIMode
+    -> ActE (Text, Act (), Next)
+actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do
+
+    -- Check input
+    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"
+
+    maybeFollow <- withDBExcept $ do
+
+        -- Find recipient actor in DB
+        recip <- lift $ getJust 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 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"
+
+            -- 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
+            accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                lift $ prepareAccept followee
+            _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept
+
+            sieve <- lift $ getSieve followee
+            return (recipActorID, followID, acceptID, sieve, accept)
+
+    case maybeFollow of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            lift $ for_ mfwd $ \ (localRecips, sig) ->
+                forwardActivity
+                    (actbBL body) localRecips sig actorID
+                    (makeLocalActor recipID) sieve
+                    (EventRemoteFollowLocalRecipFwdToFollower followID)
+            lift $ sendActivity
+                (makeLocalActor recipID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID
+                EventAcceptRemoteFollow actionAccept
+            done "Recorded Follow and published Accept"
+
+    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)
+
+topicAccept
+    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> UTCTime
+    -> Key topic
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ActE (Text, Act (), Next)
+topicAccept topicActor topicResource now recipKey author body mfwd luAccept accept = do
+
+    -- Check input
+    acceptee <- parseAccept accept
+
+    -- Verify the capability URI is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCap <-
+        traverse
+            (nameExceptT "Accept capability" . parseActivityURI')
+            (AP.activityCapability $ actbActivity body)
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab recipient deck from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust recipKey
+            let actorID = topicActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the accepted activity in our DB
+        accepteeDB <- do
+            a <- getActivity acceptee
+            fromMaybeE a "Can't find acceptee in DB"
+
+        -- See if the accepted activity is an Invite or Join to a local
+        -- resource, grabbing the Collab record from our DB
+        collab <- do
+            maybeCollab <-
+                lift $ runMaybeT $
+                    Left <$> tryInvite accepteeDB <|>
+                    Right <$> tryJoin accepteeDB
+            fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
+
+        -- Find the local resource and verify it's me
+        collabID <-
+            lift $ case collab of
+                Left (fulfillsID, _) ->
+                    collabFulfillsInviteCollab <$> getJust fulfillsID
+                Right (fulfillsID, _) ->
+                    collabFulfillsJoinCollab <$> getJust fulfillsID
+        topic <- lift $ getCollabTopic collabID
+        unless (topicResource recipKey == topic) $
+            throwE "Accept object is an Invite/Join for some other resource"
+
+        idsForAccept <-
+            case collab of
+
+                -- If accepting an Invite, find the Collab recipient and verify
+                -- it's the sender of the Accept
+                Left (fulfillsID, _) -> Left <$> do
+                    recip <-
+                        lift $
+                        requireEitherAlt
+                            (getBy $ UniqueCollabRecipLocal collabID)
+                            (getBy $ UniqueCollabRecipRemote collabID)
+                            "Found Collab with no recip"
+                            "Found Collab with multiple recips"
+                    case recip of
+                        Right (Entity crrid crr)
+                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid)
+                        _ -> throwE "Accepting an Invite whose recipient is someone else"
+
+                -- If accepting a Join, verify accepter has permission
+                Right (fulfillsID, _) -> Right <$> do
+                    capID <- fromMaybeE maybeCap "No capability provided"
+                    capability <-
+                        case capID of
+                            Left (capActor, _, capItem) -> return (capActor, capItem)
+                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
+                    verifyCapability
+                        capability
+                        (Right $ remoteAuthorId author)
+                        (topicResource recipKey)
+                    return fulfillsID
+
+        -- Verify the Collab isn't already validated
+        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
+        verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
+
+        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
+        for mractid $ \ acceptID -> do
+
+            -- Record the Accept on the Collab
+            case idsForAccept of
+                Left (fulfillsID, recipID) -> do
+                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
+                    unless (isNothing maybeAccept) $ do
+                        lift $ delete acceptID
+                        throwE "This Invite already has an Accept by recip"
+                Right fulfillsID -> do
+                    maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
+                    unless (isNothing maybeAccept) $ do
+                        lift $ delete acceptID
+                        throwE "This Join already has an Accept"
+
+            -- Prepare forwarding of Accept to my followers
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            recipByHash <- hashLocalActor recipByID
+            let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+                isInvite = isLeft collab
+
+            grantInfo <- do
+
+                -- Enable the Collab in our DB
+                grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
+                lift $ insert_ $ CollabEnable collabID grantID
+
+                -- Prepare a Grant activity and insert to my outbox
+                let inviterOrJoiner = either snd snd collab
+                grant@(actionGrant, _, _, _) <-
+                    lift $ prepareGrant isInvite inviterOrJoiner
+                let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
+                return (grantID, grant)
+
+            return (recipActorID, isInvite, acceptID, sieve, grantInfo)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, isInvite, acceptID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+                forwardActivity
+                    (actbBL body) localRecips sig recipActorID recipByID sieve
+                    (if isInvite
+                        then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID
+                        else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID
+                    )
+            lift $ sendActivity
+                recipByID recipActorID localRecipsGrant
+                remoteRecipsGrant fwdHostsGrant grantID
+                (EventGrantAfterRemoteAccept grantID) actionGrant
+            done "Forwarded the Accept and published a Grant"
+
+    where
+
+    tryInvite (Left (actorByKey, _actorEntity, itemID)) =
+        (,Left actorByKey) . collabInviterLocalCollab <$>
+            MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
+    tryInvite (Right remoteActivityID) = do
+        CollabInviterRemote collab actorID _ <-
+            MaybeT $ getValBy $
+                UniqueCollabInviterRemoteInvite remoteActivityID
+        actor <- lift $ getJust actorID
+        sender <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (collab, Right sender)
+
+    tryJoin (Left (actorByKey, _actorEntity, itemID)) =
+        (,Left actorByKey) . collabRecipLocalJoinFulfills <$>
+            MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
+    tryJoin (Right remoteActivityID) = do
+        CollabRecipRemoteJoin recipID fulfillsID _ <-
+            MaybeT $ getValBy $
+                UniqueCollabRecipRemoteJoinJoin remoteActivityID
+        remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
+        actor <- lift $ getJust remoteActorID
+        joiner <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (fulfillsID, Right joiner)
+
+    prepareGrant isInvite sender = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        accepter <- getJust $ remoteAuthorId author
+        recipHash <- encodeKeyHashid recipKey
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+
+        senderHash <- bitraverse hashLocalActor pure sender
+
+        let audience =
+                if isInvite
+                    then
+                        let audInviter =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] []
+                                    Right (ObjURI h lu, _followers) ->
+                                        AudRemote h [lu] []
+                            audAccepter =
+                                let ObjURI h lu = remoteAuthorURI author
+                                in  AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audInviter, audAccepter, audTopic]
+                    else
+                        let audJoiner =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] [localActorFollowers actor]
+                                    Right (ObjURI h lu, followers) ->
+                                        AudRemote h [lu] (maybeToList followers)
+                            audApprover =
+                                let ObjURI h lu = remoteAuthorURI author
+                                in  AudRemote h [lu] []
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audJoiner, audApprover, audTopic]
+
+            (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.acceptObject accept]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = Left AP.RoleAdmin
+                    , AP.grantContext   =
+                        encodeRouteLocal $ renderLocalActor topicByHash
+                    , AP.grantTarget    =
+                        if isInvite
+                            then remoteAuthorURI author
+                            else case senderHash of
+                                Left actor ->
+                                    encodeRouteHome $ renderLocalActor actor
+                                Right (ObjURI h lu, _) -> ObjURI h lu
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
+topicReject
+    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> UTCTime
+    -> Key topic
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Reject URIMode
+    -> ActE (Text, Act (), Next)
+topicReject topicActor topicResource now recipKey author body mfwd luReject reject = do
+
+    -- Check input
+    rejectee <- parseReject reject
+
+    -- Verify the capability URI is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCap <-
+        traverse
+            (nameExceptT "Accept capability" . parseActivityURI')
+            (AP.activityCapability $ actbActivity body)
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab recipient deck from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust recipKey
+            let actorID = topicActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the rejected activity in our DB
+        rejecteeDB <- do
+            a <- getActivity rejectee
+            fromMaybeE a "Can't find rejectee in DB"
+
+        -- See if the rejected activity is an Invite or Join to a local
+        -- resource, grabbing the Collab record from our DB
+        collab <- do
+            maybeCollab <-
+                lift $ runMaybeT $
+                    Left <$> tryInvite rejecteeDB <|>
+                    Right <$> tryJoin rejecteeDB
+            fromMaybeE maybeCollab "Rejected activity isn't an Invite or Join I'm aware of"
+
+        -- Find the local resource and verify it's me
+        collabID <-
+            lift $ case collab of
+                Left (fulfillsID, _, _) ->
+                    collabFulfillsInviteCollab <$> getJust fulfillsID
+                Right (fulfillsID, _, _, _) ->
+                    collabFulfillsJoinCollab <$> getJust fulfillsID
+        (deleteTopic, topic) <- lift $ getCollabTopic' collabID
+        unless (topicResource recipKey == topic) $
+            throwE "Accept object is an Invite/Join for some other resource"
+
+        idsForReject <-
+            case collab of
+
+                -- If rejecting an Invite, find the Collab recipient and verify
+                -- it's the sender of the Reject
+                Left (fulfillsID, _, deleteInviter) -> Left <$> do
+                    recip <-
+                        lift $
+                        requireEitherAlt
+                            (getBy $ UniqueCollabRecipLocal collabID)
+                            (getBy $ UniqueCollabRecipRemote collabID)
+                            "Found Collab with no recip"
+                            "Found Collab with multiple recips"
+                    case recip of
+                        Right (Entity crrid crr)
+                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid, deleteInviter)
+                        _ -> throwE "Rejecting an Invite whose recipient is someone else"
+
+                -- If rejecting a Join, verify accepter has permission
+                Right (fulfillsID, _, deleteRecipJoin, deleteRecip) -> Right <$> do
+                    capID <- fromMaybeE maybeCap "No capability provided"
+                    capability <-
+                        case capID of
+                            Left (capActor, _, capItem) -> return (capActor, capItem)
+                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
+                    verifyCapability
+                        capability
+                        (Right $ remoteAuthorId author)
+                        (topicResource recipKey)
+                    return (fulfillsID, deleteRecipJoin, deleteRecip)
+
+        -- Verify the Collab isn't already validated
+        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
+        verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
+
+        -- Verify the Collab isn't already accepted/approved
+        case idsForReject of
+            Left (_fulfillsID, recipID, _) -> do
+                mval <-
+                    lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID
+                verifyNothingE mval "Invite is already accepted"
+            Right (fulfillsID, _, _) -> do
+                mval1 <- lift $ getBy $ UniqueCollabApproverLocal fulfillsID
+                mval2 <- lift $ getBy $ UniqueCollabApproverRemote fulfillsID
+                unless (isNothing mval1 && isNothing mval2) $
+                    throwE "Join is already approved"
+
+        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False
+        for mractid $ \ rejectID -> do
+
+            -- Delete the whole Collab record
+            case idsForReject of
+                Left (fulfillsID, recipID, deleteInviter) -> lift $ do
+                    delete recipID
+                    deleteTopic
+                    deleteInviter
+                    delete fulfillsID
+                Right (fulfillsID, deleteRecipJoin, deleteRecip) -> lift $ do
+                    deleteRecipJoin
+                    deleteRecip
+                    deleteTopic
+                    delete fulfillsID
+            lift $ delete collabID
+
+            -- Prepare forwarding of Reject to my followers
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            recipByHash <- hashLocalActor recipByID
+            let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+                isInvite = isLeft collab
+
+            newRejectInfo <- do
+
+                -- Prepare a Reject activity and insert to my outbox
+                newRejectID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
+                let inviterOrJoiner = either (view _2) (view _2) collab
+                newReject@(actionReject, _, _, _) <-
+                    lift $ prepareReject isInvite inviterOrJoiner
+                let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
+                return (newRejectID, newReject)
+
+            return (recipActorID, isInvite, rejectID, sieve, newRejectInfo)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, isInvite, rejectID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+                forwardActivity
+                    (actbBL body) localRecips sig recipActorID recipByID sieve
+                    (if isInvite
+                        then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID
+                        else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID
+                    )
+            lift $ sendActivity
+                recipByID recipActorID localRecips
+                remoteRecips fwdHosts newRejectID
+                (EventRejectAfterRemoteReject newRejectID) action
+            done "Forwarded the Reject and published my own Reject"
+
+    where
+
+    tryInvite (Left (actorByKey, _actorEntity, itemID)) = do
+        Entity k (CollabInviterLocal f _) <-
+            MaybeT $ getBy $ UniqueCollabInviterLocalInvite itemID
+        return (f, Left actorByKey, delete k)
+    tryInvite (Right remoteActivityID) = do
+        Entity k (CollabInviterRemote collab actorID _) <-
+            MaybeT $ getBy $
+                UniqueCollabInviterRemoteInvite remoteActivityID
+        actor <- lift $ getJust actorID
+        sender <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (collab, Right sender, delete k)
+
+    tryJoin (Left (actorByKey, _actorEntity, itemID)) = do
+        Entity k (CollabRecipLocalJoin recipID fulfillsID _) <-
+            MaybeT $ getBy $ UniqueCollabRecipLocalJoinJoin itemID
+        return (fulfillsID, Left actorByKey, delete k, delete recipID)
+    tryJoin (Right remoteActivityID) = do
+        Entity k (CollabRecipRemoteJoin recipID fulfillsID _) <-
+            MaybeT $ getBy $
+                UniqueCollabRecipRemoteJoinJoin remoteActivityID
+        remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
+        actor <- lift $ getJust remoteActorID
+        joiner <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (fulfillsID, Right joiner, delete k, delete recipID)
+
+    prepareReject isInvite sender = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        rejecter <- getJust $ remoteAuthorId author
+        recipHash <- encodeKeyHashid recipKey
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+
+        senderHash <- bitraverse hashLocalActor pure sender
+
+        let audience =
+                if isInvite
+                    then
+                        let audInviter =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] []
+                                    Right (ObjURI h lu, _followers) ->
+                                        AudRemote h [lu] []
+                            audRejecter =
+                                let ObjURI h lu = remoteAuthorURI author
+                                in  AudRemote h [lu] (maybeToList $ remoteActorFollowers rejecter)
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audInviter, audRejecter, audTopic]
+                    else
+                        let audJoiner =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] [localActorFollowers actor]
+                                    Right (ObjURI h lu, followers) ->
+                                        AudRemote h [lu] (maybeToList followers)
+                            audForbidder =
+                                let ObjURI h lu = remoteAuthorURI author
+                                in  AudRemote h [lu] []
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audJoiner, audForbidder, audTopic]
+
+            (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   =
+                    [ let ObjURI h _ = remoteAuthorURI author
+                      in  ObjURI h luReject
+                    ]
+                , AP.actionSpecific   = AP.RejectActivity AP.Reject
+                    { AP.rejectObject = AP.rejectObject reject
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)

src/Vervis/Actor/Deck.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -18,23 +18,32 @@ module Vervis.Actor.Deck
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 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
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
@@ -42,23 +51,349 @@ import qualified Web.ActivityPub as AP
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
+import Vervis.Access
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
+------------------------------------------------------------------------------
+-- Following
+------------------------------------------------------------------------------
+
+-- Meaning: A remote actor is following someone/something
+-- Behavior:
+--      * Verify the target is me or a ticket of mine
+--      * Record the follow in DB
+--      * Publish and send an Accept to the sender and its followers
+deckFollow
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Follow URIMode
+    -> ActE (Text, Act (), Next)
+deckFollow now recipDeckID author body mfwd luFollow follow = do
+    recipDeckHash <- encodeKeyHashid recipDeckID
+    actorFollow
+        (\case
+            DeckR d | d == recipDeckHash -> pure Nothing
+            TicketR d t | d == recipDeckHash ->
+                Just <$> decodeKeyHashidE t "Invalid task keyhashid"
+            _ -> throwE "Asking to follow someone else"
+        )
+        deckActor
+        False
+        (\ recipDeckActor maybeTaskID ->
+            case maybeTaskID of
+                Nothing -> pure $ actorFollowers recipDeckActor
+                Just taskID -> do
+                    maybeTicket <- lift $ getTicket recipDeckID taskID
+                    (_deck, _task, Entity _ ticket, _author, _resolve) <-
+                        fromMaybeE maybeTicket "I don't have this ticket in DB"
+                    return $ ticketFollowers ticket
+        )
+        (\ _ -> pure $ makeRecipientSet [] [])
+        LocalActorDeck
+        (\ _ -> pure [])
+        now recipDeckID author body mfwd luFollow follow
+
+------------------------------------------------------------------------------
+-- Access
+------------------------------------------------------------------------------
+
+-- Meaning: A remote actor accepted something
+-- Behavior:
+--     * If it's on an Invite where I'm the resource:
+--         * Verify the Accept is by the Invite target
+--         * Forward the Accept to my followers
+--         * Send a Grant:
+--             * To: Accepter (i.e. Invite target)
+--             * CC: Invite sender, Accepter's followers, my followers
+--     * If it's on a Join where I'm the resource:
+--         * Verify the Accept is authorized
+--         * Forward the Accept to my followers
+--         * Send a Grant:
+--             * To: Join sender
+--             * CC: Accept sender, Join sender's followers, my followers
+--     * Otherwise respond with error
+deckAccept
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ActE (Text, Act (), Next)
+deckAccept = topicAccept deckActor GrantResourceDeck
+
+-- Meaning: A remote actor rejected something
+-- Behavior:
+--     * If it's on an Invite where I'm the resource:
+--         * Verify the Reject is by the Invite target
+--         * Remove the relevant Collab record from DB
+--         * Forward the Reject to my followers
+--         * Send a Reject on the Invite:
+--             * To: Rejecter (i.e. Invite target)
+--             * CC: Invite sender, Rejecter's followers, my followers
+--     * If it's on a Join where I'm the resource:
+--         * Verify the Reject is authorized
+--         * Remove the relevant Collab record from DB
+--         * Forward the Reject to my followers
+--         * Send a Reject:
+--             * To: Join sender
+--             * CC: Reject sender, Join sender's followers, my followers
+--     * Otherwise respond with error
+deckReject
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Reject URIMode
+    -> ActE (Text, Act (), Next)
+deckReject = topicReject deckActor GrantResourceDeck
+
+------------------------------------------------------------------------------
+-- Ambiguous: Following/Resolving
+------------------------------------------------------------------------------
+
+-- Meaning: A remote actor is undoing some previous action
+-- Behavior:
+--      * If they're undoing their Following of me, or a ticket of mine:
+--          * Record it in my DB
+--          * Publish and send an Accept only to the sender
+--      * If they're unresolving a resolved ticket of mine:
+--          * Verify they're authorized via a Grant
+--          * Record it in my DB
+--          * Forward the Undo to my+ticket followers
+--          * Send an Accept to sender+followers and to my+ticket followers
+--      * Otherwise respond with an error
+deckUndo
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Undo URIMode
+    -> ActE (Text, Act (), Next)
+deckUndo now recipDeckID author body mfwd luUndo (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 recipient deck from DB
+        (deckRecip, actorRecip) <- lift $ do
+            p <- getJust recipDeckID
+            (p,) <$> getJust (deckActor p)
+
+        -- Insert the Undo to deck'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
+                asum
+                    [ tryUnfollow followers undoneDB
+                    , tryUnresolve maybeCapability undoneDB
+                    ]
+
+            (sieve, audience) <-
+                fromMaybeE
+                    maybeUndo
+                    "Undone activity isn't a Follow or Resolve related to me"
+
+            -- Prepare an Accept activity and insert to deck's outbox
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
+            _luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept
+
+            return (deckActor deckRecip, undoID, sieve, acceptID, accept)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, undoID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+                forwardActivity
+                    (actbBL body) localRecips sig actorID
+                    (LocalActorDeck recipDeckID) sieve
+                    (EventRemoteUnresolveLocalResourceFwdToFollower undoID)
+            lift $ sendActivity
+                (LocalActorDeck recipDeckID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID
+                EventAcceptRemoteFollow actionAccept
+            done
+                "Undid the Follow/Resolve, forwarded the Undo and published \
+                \Accept"
+
+    where
+
+    tryUnfollow _               (Left _)                 = mzero
+    tryUnfollow deckFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        verifyTargetMe followerSetID <|> verifyTargetTicket followerSetID
+        unless (followerID == remoteAuthorId author) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete remoteFollowID
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+            audSenderOnly = AudRemote hAuthor [luAuthor] []
+        return (makeRecipientSet [] [], [audSenderOnly])
+        where
+        verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID
+        verifyTargetTicket followerSetID = do
+            ticketID <-
+                MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
+            TicketDeck _ d <-
+                MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
+            guard $ d == recipDeckID
+
+    tryUnresolve maybeCapability undone = do
+        (deleteFromDB, ticketID) <- findTicket undone
+        Entity taskID (TicketDeck _ d) <-
+            MaybeT $ lift $ getBy $ UniqueTicketDeck ticketID
+        guard $ d == recipDeckID
+
+        -- Verify the sender is authorized by the deck to unresolve a ticket
+        capability <- lift $ do
+            cap <-
+                fromMaybeE
+                    maybeCapability
+                    "Asking to unresolve ticket but no capability provided"
+            case cap of
+                Left c -> pure c
+                Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
+        lift $
+            verifyCapability
+                capability
+                (Right $ remoteAuthorId author)
+                (GrantResourceDeck recipDeckID)
+
+        lift $ lift deleteFromDB
+
+        recipDeckHash <- encodeKeyHashid recipDeckID
+        taskHash <- encodeKeyHashid taskID
+        audSender <- lift $ do
+            ra <- lift $ getJust $ remoteAuthorId author
+            let ObjURI hAuthor luAuthor = remoteAuthorURI author
+            return $
+                AudRemote hAuthor
+                    [luAuthor]
+                    (maybeToList $ remoteActorFollowers ra)
+        return
+            ( makeRecipientSet
+                []
+                [ LocalStageDeckFollowers recipDeckHash
+                , LocalStageTicketFollowers recipDeckHash taskHash
+                ]
+            , [ AudLocal
+                    []
+                    [ LocalStageDeckFollowers recipDeckHash
+                    , LocalStageTicketFollowers recipDeckHash taskHash
+                    ]
+              , audSender
+              ]
+            )
+        where
+        findTicket (Left (_actorByKey, _actorEntity, itemID)) = do
+            Entity resolveLocalID resolveLocal <-
+                MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity itemID
+            let resolveID = ticketResolveLocalTicket resolveLocal
+            resolve <- lift $ lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveLocalID >> delete resolveID
+                , ticketID
+                )
+        findTicket (Right remoteActivityID) = do
+            Entity resolveRemoteID resolveRemote <-
+                MaybeT $ lift $ getBy $
+                    UniqueTicketResolveRemoteActivity remoteActivityID
+            let resolveID = ticketResolveRemoteTicket resolveRemote
+            resolve <- lift $ lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveRemoteID >> delete resolveID
+                , ticketID
+                )
+
+    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)
+
+------------------------------------------------------------------------------
+-- Main behavior function
+------------------------------------------------------------------------------
+
 deckBehavior
     :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next)
-deckBehavior now deckID (Left event) =
+deckBehavior _now _deckID (Left event) =
     case event of
         EventRemoteFwdLocalActivity _ _ ->
             throwE "Got a forwarded local activity, I don't need those"
         _ -> throwE $ "Unsupported event for Deck: " <> T.pack (show event)
 deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.AcceptActivity accept ->
+            deckAccept now deckID author body mfwd luActivity accept
+        AP.FollowActivity follow ->
+            deckFollow now deckID author body mfwd luActivity follow
+        AP.RejectActivity reject ->
+            deckReject now deckID author body mfwd luActivity reject
+        AP.UndoActivity undo ->
+            deckUndo now deckID author body mfwd luActivity undo
         _ -> throwE "Unsupported activity type for Deck"

src/Vervis/Actor/Person.hs

@@ -14,9 +14,6 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
--- for actorFollow
-{-# LANGUAGE RankNTypes #-}
-
 module Vervis.Actor.Person
     ( personBehavior
     )
@@ -57,6 +54,7 @@ import Database.Persist.Local
 import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
 import Vervis.Actor2
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -76,117 +74,6 @@ import Vervis.Ticket
 -- Following
 ------------------------------------------------------------------------------
 
-actorFollow
-    :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
-    => (Route App -> ActE a)
-    -> (r -> ActorId)
-    -> Bool
-    -> (Key r -> Actor -> a -> ActDBE FollowerSetId)
-    -> (a -> ActDB RecipientRoutes)
-    -> (forall f. f r -> LocalActorBy f)
-    -> (a -> Act [Aud URIMode])
-    -> UTCTime
-    -> Key r
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Follow URIMode
-    -> ActE (Text, Act (), Next)
-actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do
-
-    -- Check input
-    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"
-
-    maybeFollow <- withDBExcept $ do
-
-        -- Find recipient actor in DB
-        recip <- lift $ getJust 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"
-
-            -- 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
-            accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                lift $ prepareAccept followee
-            _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept
-
-            sieve <- lift $ getSieve followee
-            return (recipActorID, followID, acceptID, sieve, accept)
-
-    case maybeFollow of
-        Nothing -> done "I already have this activity in my inbox"
-        Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
-            lift $ for_ mfwd $ \ (localRecips, sig) ->
-                forwardActivity
-                    (actbBL body) localRecips sig actorID
-                    (makeLocalActor recipID) sieve
-                    (EventRemoteFollowLocalRecipFwdToFollower followID)
-            lift $ sendActivity
-                (makeLocalActor recipID) actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID
-                EventAcceptRemoteFollow actionAccept
-            done "Recorded Follow and published Accept"
-
-    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)
-
 -- Meaning: Someone is following someone
 -- Behavior:
 --      * Verify I'm the target
@@ -210,7 +97,7 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
         )
         personActor
         True
-        (\ _recipPersonID recipPersonActor () ->
+        (\ recipPersonActor () ->
             pure $ actorFollowers recipPersonActor
         )
         (\ () -> pure $ makeRecipientSet [] [])
@@ -711,7 +598,7 @@ personBehavior now personID (Left event) =
                 itemID <- insert $ InboxItem True now
                 insert_ $ InboxItemRemote inboxID inviteID itemID
             done "Inserted Invite to inbox"
-        -- Meaning: A remote actor has forwarded to me a remote activity
+        -- Meaning: A remote actor has forwarded to me a local activity
         -- Behavior: Insert it to my inbox
         EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do
                 recipPerson <- lift $ getJust personID
@@ -724,6 +611,92 @@ personBehavior now personID (Left event) =
                             if inserted
                                 then "Activity inserted to my inbox"
                                 else "Activity already exists in my inbox, ignoring"
+        -- Meaning: A deck/loom received an Undo{Resolve} and forwarded it to
+        --          me because I'm a follower of the deck/loom or the ticket
+        -- Behavior: Insert to my inbox
+        EventRemoteUnresolveLocalResourceFwdToFollower undoID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID undoID itemID
+            done "Inserted Undo{Resolve} to inbox"
+        -- Meaning: A remote actor accepted an Invite on a local resource, I'm
+        -- being forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Accept to my inbox
+        EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID acceptID itemID
+            done "Inserted Accept{Invite} to inbox"
+        -- Meaning: A remote actor approved a Join on a local resource, I'm
+        -- being forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Accept to my inbox
+        EventRemoteApproveJoinLocalResourceFwdToFollower acceptID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID acceptID itemID
+            done "Inserted Accept{Join} to inbox"
+        -- Meaning: Local resource sent a Grant, I'm the
+        -- inviter/approver/target/follower
+        --
+        -- Behavior: Insert the Grant to my inbox
+        EventGrantAfterRemoteAccept grantID -> do
+            _ <- lift $ withDB $ do
+                (personRecip, _actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                insertActivityToInbox now (personActor personRecip) grantID
+            done "Inserted Grant to my inbox"
+        -- Meaning: A remote actor rejected an Invite on a local resource, I'm
+        -- being forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Accept to my inbox
+        EventRemoteRejectInviteLocalResourceFwdToFollower rejectID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID rejectID itemID
+            done "Inserted Reject{Invite} to inbox"
+        -- Meaning: A remote actor disapproved a Join on a local resource, I'm
+        -- being forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Reject to my inbox
+        EventRemoteForbidJoinLocalResourceFwdToFollower rejectID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID rejectID itemID
+            done "Inserted Reject{Join} to inbox"
+        -- Meaning: Local resource sent a Reject on Invite/Join, I'm the
+        -- inviter/disapprover/target/follower
+        --
+        -- Behavior: Insert the Reject to my inbox
+        EventRejectAfterRemoteReject rejectID -> do
+            _ <- lift $ withDB $ do
+                (personRecip, _actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                insertActivityToInbox now (personActor personRecip) rejectID
+            done "Inserted Reject to my inbox"
         _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
 personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of

src/Vervis/Federation/Collab.hs

@@ -23,9 +23,9 @@ module Vervis.Federation.Collab
     , deckJoinF
     , loomJoinF
 
-    , repoAcceptF
+    --, repoAcceptF
-    , deckAcceptF
+    --, deckAcceptF
-    , loomAcceptF
+    --, loomAcceptF
 
     --, personGrantF
     )
@@ -344,229 +344,7 @@ loomJoinF
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomJoinF = topicJoinF loomActor GrantResourceLoom
 
-topicAcceptF
-    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
-    => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
-    -> UTCTime
-    -> KeyHashid topic
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Accept URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do
-    error "topicAcceptF temporarily disabled due to actor refactoring"
 {-
-    -- Check input
-    acceptee <- parseAccept accept
-
-    -- Verify the capability URI is one of:
-    --   * Outbox item URI of a local actor, i.e. a local activity
-    --   * A remote URI
-    maybeCap <-
-        traverse
-            (nameExceptT "Accept capability" . parseActivityURI)
-            (AP.activityCapability $ actbActivity body)
-
-    -- Find recipient topic in DB, returning 404 if doesn't exist because
-    -- we're in the topic's inbox post handler
-    recipKey <- decodeKeyHashid404 recipHash
-    mhttp <- runDBExcept $ do
-        (recipActorID, recipActor) <- lift $ do
-            recip <- get404 recipKey
-            let actorID = topicActor recip
-            (actorID,) <$> getJust actorID
-
-        -- Find the accepted activity in our DB
-        accepteeDB <- do
-            a <- getActivity acceptee
-            fromMaybeE a "Can't find acceptee in DB"
-
-        -- See if the accepted activity is an Invite or Join to a local
-        -- resource, grabbing the Collab record from our DB
-        collab <- do
-            maybeCollab <-
-                lift $ runMaybeT $
-                    Left <$> tryInvite accepteeDB <|>
-                    Right <$> tryJoin accepteeDB
-            fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
-
-        -- Find the local resource and verify it's me
-        collabID <-
-            lift $ case collab of
-                Left (fulfillsID, _) ->
-                    collabFulfillsInviteCollab <$> getJust fulfillsID
-                Right (fulfillsID, _) ->
-                    collabFulfillsJoinCollab <$> getJust fulfillsID
-        topic <- lift $ getCollabTopic collabID
-        unless (topicResource recipKey == topic) $
-            throwE "Accept object is an Invite for some other resource"
-
-        idsForAccept <-
-            case collab of
-
-                -- If accepting an Invite, find the Collab recipient and verify
-                -- it's the sender of the Accept
-                Left (fulfillsID, _) -> Left <$> do
-                    recip <-
-                        lift $
-                        requireEitherAlt
-                            (getBy $ UniqueCollabRecipLocal collabID)
-                            (getBy $ UniqueCollabRecipRemote collabID)
-                            "Found Collab with no recip"
-                            "Found Collab with multiple recips"
-                    case recip of
-                        Right (Entity crrid crr)
-                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid)
-                        _ -> throwE "Accepting an Invite whose recipient is someone else"
-
-                -- If accepting a Join, verify accepter has permission
-                Right (fulfillsID, _) -> Right <$> do
-                    capID <- fromMaybeE maybeCap "No capability provided"
-                    capability <-
-                        case capID of
-                            Left (capActor, _, capItem) -> return (capActor, capItem)
-                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
-                    verifyCapability
-                        capability
-                        (Right $ remoteAuthorId author)
-                        (topicResource recipKey)
-                    return fulfillsID
-
-        -- Verify the Collab isn't already validated
-        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
-        verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
-
-        -- Record the Accept on the Collab
-        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
-        for mractid $ \ acceptID -> do
-
-            case idsForAccept of
-                Left (fulfillsID, recipID) -> do
-                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
-                    unless (isNothing maybeAccept) $ do
-                        lift $ delete acceptID
-                        throwE "This Invite already has an Accept by recip"
-                Right fulfillsID -> do
-                    maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
-                    unless (isNothing maybeAccept) $ do
-                        lift $ delete acceptID
-                        throwE "This Join already has an Accept"
-
-            -- Forward the Accept activity to relevant local stages, and
-            -- schedule delivery for unavailable remote members of them
-            let recipByHash = grantResourceLocalActor $ topicResource recipHash
-            maybeHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do
-                let sieve =
-                        makeRecipientSet [] [localActorFollowers recipByHash]
-                forwardActivityDB
-                    (actbBL body) localRecips sig recipActorID recipByHash
-                    sieve acceptID
-
-            deliverHttpGrant <- do
-
-                -- Enable the Collab in our DB
-                grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
-                lift $ insert_ $ CollabEnable collabID grantID
-
-                -- Prepare a Grant activity and insert to topic's outbox
-                let inviterOrJoiner = either snd snd collab
-                (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
-                    lift $ prepareGrant inviterOrJoiner
-                let recipByKey = grantResourceLocalActor $ topicResource recipKey
-                _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant
-
-                -- Deliver the Grant to local recipients, and schedule delivery
-                -- for unavailable remote recipients
-                deliverActivityDB
-                    recipByHash recipActorID localRecipsGrant remoteRecipsGrant
-                    fwdHostsGrant grantID actionGrant
-
-            return (maybeHttpFwdAccept, deliverHttpGrant)
-
-    -- Launch asynchronous HTTP forwarding of the Accept activity
-    case mhttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just (mhttpFwd, deliverHttpGrant) -> do
-            forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant
-            case mhttpFwd of
-                Nothing -> return "Sent a Grant, no inbox-forwarding to do"
-                Just forwardHttpAccept -> do
-                    forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept
-                    return "Sent a Grant and ran inbox-forwarding of the Accept"
-
-    where
-
-    tryInvite (Left (actorByKey, _actorEntity, itemID)) =
-        (,Left actorByKey) . collabInviterLocalCollab <$>
-            MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
-    tryInvite (Right remoteActivityID) = do
-        CollabInviterRemote collab actorID _ <-
-            MaybeT $ getValBy $
-                UniqueCollabInviterRemoteInvite remoteActivityID
-        actor <- lift $ getJust actorID
-        sender <-
-            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
-        return (collab, Right sender)
-
-    tryJoin (Left (actorByKey, _actorEntity, itemID)) =
-        (,Left actorByKey) . collabRecipLocalJoinFulfills <$>
-            MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
-    tryJoin (Right remoteActivityID) = do
-        CollabRecipRemoteJoin recipID fulfillsID _ <-
-            MaybeT $ getValBy $
-                UniqueCollabRecipRemoteJoinJoin remoteActivityID
-        remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
-        actor <- lift $ getJust remoteActorID
-        joiner <-
-            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
-        return (fulfillsID, Right joiner)
-
-    prepareGrant sender = do
-        encodeRouteHome <- getEncodeRouteHome
-        encodeRouteLocal <- getEncodeRouteLocal
-
-        accepter <- getJust $ remoteAuthorId author
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
-
-        senderHash <- bitraverse hashLocalActor pure sender
-
-        let audSender =
-                case senderHash of
-                    Left actor -> AudLocal [actor] [localActorFollowers actor]
-                    Right (ObjURI h lu, followers) ->
-                        AudRemote h [lu] (maybeToList followers)
-            audRecip =
-                let ObjURI h lu = remoteAuthorURI author
-                in  AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
-            audTopic = AudLocal [] [localActorFollowers topicByHash]
-
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audSender, audRecip, audTopic]
-
-            recips = map encodeRouteHome audLocal ++ audRemote
-            action = AP.Action
-                { AP.actionCapability = Nothing
-                , AP.actionSummary    = Nothing
-                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
-                , AP.actionFulfills   = [AP.acceptObject accept]
-                , AP.actionSpecific   = AP.GrantActivity AP.Grant
-                    { AP.grantObject    = Left AP.RoleAdmin
-                    , AP.grantContext   = encodeRouteLocal $ renderLocalActor topicByHash
-                    , AP.grantTarget    = remoteAuthorURI author
-                    , AP.grantResult    = Nothing
-                    , AP.grantStart   = Nothing
-                    , AP.grantEnd     = Nothing
-                    , AP.grantAllows  = AP.Invoke
-                    , AP.grantDelegates = Nothing
-                    }
-                }
-
-        return (action, recipientSet, remoteActors, fwdHosts)
--}
-
 repoAcceptF
     :: UTCTime
     -> KeyHashid Repo
@@ -578,17 +356,6 @@ repoAcceptF
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 repoAcceptF = topicAcceptF repoActor GrantResourceRepo
 
-deckAcceptF
-    :: UTCTime
-    -> KeyHashid Deck
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Accept URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-deckAcceptF = topicAcceptF deckActor GrantResourceDeck
-
 loomAcceptF
     :: UTCTime
     -> KeyHashid Loom
@@ -599,3 +366,4 @@ loomAcceptF
     -> AP.Accept URIMode
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomAcceptF = topicAcceptF loomActor GrantResourceLoom
+-}

src/Vervis/Federation/Offer.hs

@@ -26,8 +26,8 @@ module Vervis.Federation.Offer
     --, repoFollowF
 
       --personUndoF
-      deckUndoF
+      --deckUndoF
-    , loomUndoF
+      loomUndoF
     , repoUndoF
     )
 where
@@ -429,66 +429,6 @@ followF
 -}
 
 {-
-personFollowF
-    :: UTCTime
-    -> KeyHashid Person
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Follow URIMode
-    -> 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
-
-deckFollowF
-    :: UTCTime
-    -> KeyHashid Deck
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Follow URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-deckFollowF now recipDeckHash =
-    followF
-        (\case
-            DeckR d | d == recipDeckHash -> pure Nothing
-            TicketR d t | d == recipDeckHash ->
-                Just <$> decodeKeyHashidE t "Invalid task keyhashid"
-            _ -> throwE "Asking to follow someone else"
-        )
-        deckActor
-        False
-        (\ recipDeckID recipDeckActor maybeTaskID ->
-            case maybeTaskID of
-                Nothing -> pure $ actorFollowers recipDeckActor
-                Just taskID -> do
-                    maybeTicket <- lift $ getTicket recipDeckID taskID
-                    (_deck, _task, Entity _ ticket, _author, _resolve) <-
-                        fromMaybeE maybeTicket "I don't have this ticket in DB"
-                    return $ ticketFollowers ticket
-        )
-        (\ _ -> pure $ makeRecipientSet [] [])
-        LocalActorDeck
-        (\ _ -> pure [])
-        now
-        recipDeckHash
-
 loomFollowF
     :: UTCTime
     -> KeyHashid Loom
@@ -550,217 +490,6 @@ repoFollowF now recipRepoHash =
         recipRepoHash
 -}
 
-deckUndoF
-    :: UTCTime
-    -> KeyHashid Deck
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Undo URIMode
-    -> ExceptT Text Handler Text
-deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do
-
-    -- Check input
-    recipDeckID <- decodeKeyHashid404 recipDeckHash
-    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 deck in DB, returning 404 if doesn't exist because we're
-        -- in the deck's inbox post handler
-        (recipDeckActorID, recipDeckActor) <- lift $ do
-            deck <- get404 recipDeckID
-            let actorID = deckActor deck
-            (actorID,) <$> getJust actorID
-
-        -- Insert the Undo to deck's inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luUndo False
-        for mractid $ \ undoID -> do
-
-            -- Find the undone activity in our DB
-            undoneDB <- do
-                a <- getActivity undone
-                fromMaybeE a "Can't find undone in DB"
-
-            (sieve, acceptAudience) <- do
-                maybeUndo <- do
-                    let followers = actorFollowers recipDeckActor
-                    lift $ runMaybeT $
-                        Left <$> tryUnfollow recipDeckID followers undoneDB <|>
-                        Right <$> tryUnresolve recipDeckID undoneDB
-                undo <- fromMaybeE maybeUndo "Undone activity isn't a Follow or Resolve related to me"
-                (audSenderOnly, audSenderAndFollowers) <- do
-                    ra <- lift $ getJust $ remoteAuthorId author
-                    let ObjURI hAuthor luAuthor = remoteAuthorURI author
-                    return
-                        ( AudRemote hAuthor [luAuthor] []
-                        , AudRemote hAuthor
-                            [luAuthor]
-                            (maybeToList $ remoteActorFollowers ra)
-                        )
-                case undo of
-                    Left (remoteFollowID, followerID) -> do
-                        unless (followerID == remoteAuthorId author) $
-                            throwE "Trying to undo someone else's Follow"
-                        lift $ delete remoteFollowID
-                        return
-                            ( makeRecipientSet [] []
-                            , [audSenderOnly]
-                            )
-                    Right (deleteFromDB, taskID) -> do
-
-                        -- Verify the sender is authorized by the deck to unresolve a ticket
-                        capability <- do
-                            cap <-
-                                fromMaybeE
-                                    maybeCapability
-                                    "Asking to unresolve ticket but no capability provided"
-                            case cap of
-                                Left c -> pure c
-                                Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
-                        verifyCapability
-                            capability
-                            (Right $ remoteAuthorId author)
-                            (GrantResourceDeck recipDeckID)
-
-                        lift deleteFromDB
-
-                        taskHash <- encodeKeyHashid taskID
-                        return
-                            ( makeRecipientSet
-                                [LocalActorDeck recipDeckHash]
-                                [ LocalStageDeckFollowers recipDeckHash
-                                , LocalStageTicketFollowers recipDeckHash taskHash
-                                ]
-                            , [ AudLocal
-                                    []
-                                    [ LocalStageDeckFollowers recipDeckHash
-                                    , LocalStageTicketFollowers recipDeckHash taskHash
-                                    ]
-                              , audSenderAndFollowers
-                              ]
-                            )
-
-            -- 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 recipDeckActorID
-                    (LocalActorDeck recipDeckHash) sieve undoID
-
-
-            -- Prepare an Accept activity and insert to deck's outbox
-            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
-            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                lift . lift $ prepareAccept acceptAudience
-            _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
-
-            -- Deliver the Accept to local recipients, and schedule delivery
-            -- for unavailable remote recipients
-            deliverHttpAccept <-
-                deliverActivityDB
-                    (LocalActorDeck recipDeckHash) recipDeckActorID
-                    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 (maybeHttpFwdUndo, deliverHttpAccept) -> do
-            forkWorker "deckUndoF Accept HTTP delivery" deliverHttpAccept
-            case maybeHttpFwdUndo of
-                Nothing -> return "Undid, no inbox-forwarding to do"
-                Just forwardHttpUndo -> do
-                    forkWorker "deckUndoF inbox-forwarding" forwardHttpUndo
-                    return "Undid and ran inbox-forwarding of the Undo"
-
-    where
-
-    tryUnfollow _      _               (Left _)                 = mzero
-    tryUnfollow deckID deckFollowersID (Right remoteActivityID) = do
-        Entity remoteFollowID remoteFollow <-
-            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
-        let followerID = remoteFollowActor remoteFollow
-            followerSetID = remoteFollowTarget remoteFollow
-        if followerSetID == deckFollowersID
-            then pure ()
-            else do
-                ticketID <-
-                    MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID
-                TicketDeck _ d <-
-                    MaybeT $ getValBy $ UniqueTicketDeck ticketID
-                guard $ d == deckID
-        return (remoteFollowID, followerID)
-
-    tryUnresolve deckID undone = do
-        (deleteFromDB, ticketID) <- findTicket undone
-        Entity taskID (TicketDeck _ d) <-
-            MaybeT $ getBy $ UniqueTicketDeck ticketID
-        guard $ d == deckID
-        return (deleteFromDB, taskID)
-        where
-        findTicket (Left (_actorByKey, _actorEntity, itemID)) = do
-            Entity resolveLocalID resolveLocal <-
-                MaybeT $ getBy $ UniqueTicketResolveLocalActivity itemID
-            let resolveID = ticketResolveLocalTicket resolveLocal
-            resolve <- lift $ getJust resolveID
-            let ticketID = ticketResolveTicket resolve
-            return
-                ( delete resolveLocalID >> delete resolveID
-                , ticketID
-                )
-        findTicket (Right remoteActivityID) = do
-            Entity resolveRemoteID resolveRemote <-
-                MaybeT $ getBy $
-                    UniqueTicketResolveRemoteActivity remoteActivityID
-            let resolveID = ticketResolveRemoteTicket resolveRemote
-            resolve <- lift $ getJust resolveID
-            let ticketID = ticketResolveTicket resolve
-            return
-                ( delete resolveRemoteID >> delete resolveID
-                , ticketID
-                )
-
-    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)
-
 loomUndoF
     :: UTCTime
     -> KeyHashid Loom

src/Vervis/Persist/Collab.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,6 +15,7 @@
 
 module Vervis.Persist.Collab
     ( getCollabTopic
+    , getCollabTopic'
     , getGrantRecip
     , getTopicGrants
     , getTopicInvites
@@ -52,6 +53,23 @@ getCollabTopic collabID = do
                 GrantResourceLoom $ collabTopicLoomLoom l
             _ -> error "Found Collab with multiple topics"
 
+getCollabTopic'
+    :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key)
+getCollabTopic' collabID = do
+    maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
+    maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
+    maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
+    return $
+        case (maybeRepo, maybeDeck, maybeLoom) of
+            (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
+            (Just (Entity k r), Nothing, Nothing) ->
+                (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
+            (Nothing, Just (Entity k d), Nothing) ->
+                (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
+            (Nothing, Nothing, Just (Entity k l)) ->
+                (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
+            _ -> error "Found Collab with multiple topics"
+
 getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
 
 getTopicGrants

stack.yaml

@@ -57,6 +57,9 @@ extra-deps:
   - annotated-exception-0.2.0.4
   - retry-0.9.3.1
   - base58-bytestring-0.1.0
+  - indexed-profunctors-0.1.1
+  - indexed-traversable-0.1.2.1
+  - optics-core-0.4.1
 
 # Override default flag values for local packages and extra-deps
 flags:

vervis.cabal

@@ -143,6 +143,7 @@ library
                        Vervis.ActivityPub
                        Vervis.Actor
                        Vervis.Actor2
+                       Vervis.Actor.Common
                        Vervis.Actor.Deck
                        Vervis.Actor.Group
                        Vervis.Actor.Loom
@@ -383,6 +384,7 @@ library
                      , mtl
                      , network
                      , network-uri
+                     , optics-core
                      , pandoc
                      , pandoc-types
                        -- for PathPiece instance for CI, Web.PathPieces.Local