Switch to converged handlers than handle both local and remote activities

I was writing a topicLocalInvite handler when I realized how cumbersome
it's becoming, to have separate handlers for local activities. While it
allows me to pick custom specific message names and parameters (which is
why I took that approach in the first place), it causes a lot of
duplication and complexity (because I have to write the remote-activity
handlers anyway; adding local ones doesn't reduce complexity).

So this commit switches the entire system to communicate only using
AP/FF activities, including between local actors.

migrations/531_2023-06-15_follow_request.model

@@ -0,0 +1,8 @@
+FollowRequest
+    actor  ActorId
+    target FollowerSetId
+    public Bool
+    follow OutboxItemId
+
+    UniqueFollowRequest actor target
+    UniqueFollowRequestFollow follow

src/Vervis/API.hs

@@ -1838,6 +1838,19 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 }
             }
 
+-- Meaning: The human wants to invite someone A to a resource R
+-- Behavior:
+--      * Some basic sanity checks
+--          * Parse the Invite
+--          * Make sure not inviting myself
+--          * Verify that a capability is specified
+--          * If resource is local, verify it exists in DB
+--      * Verify the target A and resource R are addressed in the Invite
+--      * Insert Invite to my inbox
+--      * Asynchrnously:
+--          * Deliver a request to the resource
+--          * Deliver a notification to the target
+--          * Deliver a notification to my followers
 inviteC
     :: Entity Person
     -> Actor
@@ -1853,11 +1866,11 @@ inviteC
     -> AP.Invite URIMode
     -> ExceptT Text Handler OutboxItemId
 inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do
-    error "Temporarily disabled due to switch to new actor system"
+    error "Disabled for actor refactoring"
 {-
     -- Check input
     (resource, recipient) <- parseInvite (Left senderPersonID) invite
-    capID <- fromMaybeE maybeCap "No capability provided"
+    _capID <- fromMaybeE maybeCap "No capability provided"
 
     -- If resource is remote, HTTP GET it and its managing actor, and insert to
     -- our DB. If resource is local, find it in our DB.
@@ -1866,7 +1879,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             (runDBExcept . flip getGrantResource "Grant context not found in DB")
             (\ u@(ObjURI h lu) -> do
                 instanceID <-
-                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                 result <-
                     ExceptT $ first (T.pack . show) <$>
                         fetchRemoteResource instanceID h lu
@@ -1888,7 +1901,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                     lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
                 result <-
                     ExceptT $ first (T.pack . displayException) <$>
-                        fetchRemoteActor instanceID h lu
+                        fetchRemoteActor' instanceID h lu
                 case result of
                     Left Nothing -> throwE "Recipient @id mismatch"
                     Left (Just err) -> throwE $ T.pack $ displayException err
@@ -1910,27 +1923,25 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
     now <- liftIO getCurrentTime
     senderHash <- encodeKeyHashid senderPersonID
 
+    ? <- withDBExcept $ do
+
+
+
+
+
+
+
+
+
+
+
+
+
+
     (obiidInvite, deliverHttpInvite) <- runDBExcept $ do
 
-        -- If resource is local, verify the specified capability gives relevant
+        -- Insert the Invite activity to author's outbox
-        -- access to it.
-        case resourceDB of
-            Left r -> do
-                capability <-
-                    case capID of
-                        Left (actor, _, item) -> return (actor, item)
-                        Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic"
-                verifyCapability capability (Left senderPersonID) (bmap entityKey r)
-            Right _ -> pure ()
-
-        -- Insert new Collab to DB
         inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        case resourceDB of
-            Left localResource ->
-                lift $ insertCollab localResource recipientDB inviteID
-            Right _ -> pure ()
-
-        -- Insert the Grant activity to author's outbox
         _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action
 
         -- Deliver the Invite activity to local recipients, and schedule
@@ -1986,6 +1997,22 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
         -- Return instructions for HTTP delivery to remote recipients
         return (inviteID, deliverHttpInvite)
 
+
+
+
+
+
+    -- Notify the resource
+
+
+
+
+
+
+
+
+
+
     -- Launch asynchronous HTTP delivery of the Grant activity
     lift $ do
         forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
@@ -1995,20 +2022,20 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
     where
 
     fetchRemoteResource instanceID host localURI = do
-        maybeActor <- runSiteDB $ runMaybeT $ do
+        maybeActor <- withDB $ runMaybeT $ do
             roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
             MaybeT $ getBy $ UniqueRemoteActor roid
         case maybeActor of
             Just actor -> return $ Right $ Left actor
             Nothing -> do
-                manager <- asksSite getHttpManager
+                manager <- asksEnv getHttpManager
                 errorOrResource <- fetchResource manager host localURI
                 case errorOrResource of
                     Left maybeError ->
                         return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
                     Right resource -> do
                         case resource of
-                            ResourceActor (AP.Actor local detail) -> runSiteDB $ do
+                            ResourceActor (AP.Actor local detail) -> withDB $ do
                                 roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
                                 let ra = RemoteActor
                                         { remoteActorIdent      = roid
@@ -2020,8 +2047,8 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                                         }
                                 Right . Left . either id id <$> insertByEntity' ra
                             ResourceChild luId luManager -> do
-                                roid <- runSiteDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
+                                roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
-                                result <- fetchRemoteActor instanceID host luManager
+                                result <- fetchRemoteActor' instanceID host luManager
                                 return $
                                     case result of
                                         Left e -> Left $ ResultSomeException e
@@ -2038,23 +2065,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             routes <- lookup p $ recipPeople localRecips
             guard $ routePerson routes
 
-    insertCollab resource recipient inviteID = do
-        collabID <- insert Collab
-        case resource of
-            GrantResourceRepo (Entity repoID _) ->
-                insert_ $ CollabTopicRepo collabID repoID
-            GrantResourceDeck (Entity deckID _) ->
-                insert_ $ CollabTopicDeck collabID deckID
-            GrantResourceLoom (Entity loomID _) ->
-                insert_ $ CollabTopicLoom collabID loomID
-        fulfillsID <- insert $ CollabFulfillsInvite collabID
-        insert_ $ CollabInviterLocal fulfillsID inviteID
-        case recipient of
-            Left (GrantRecipPerson (Entity personID _)) ->
-                insert_ $ CollabRecipLocal collabID personID
-            Right (remoteActorID, _) ->
-                insert_ $ CollabRecipRemote collabID remoteActorID
-
     hashGrantRecip (GrantRecipPerson k) =
         GrantRecipPerson <$> encodeKeyHashid k
 -}

src/Vervis/Access.hs

@@ -77,6 +77,7 @@ module Vervis.Access
     , grantResourceLocalActor
 
     , verifyCapability
+    , verifyCapability'
     )
 where
 
@@ -89,6 +90,8 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Barbie
 import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
 import Data.Maybe
 import Data.Text (Text)
 import Database.Persist
@@ -99,6 +102,7 @@ import Yesod.Core.Handler
 import qualified Database.Esqueleto as E
 
 import Control.Concurrent.Actor
+import Network.FedURI
 import Web.Actor.Persist (stageHashidsContext)
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -107,6 +111,7 @@ import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
 
+import Vervis.Actor
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Role
@@ -383,3 +388,23 @@ verifyCapability (capActor, capItem) actor resource = do
     -- Since there are currently no roles, and grants allow only the "Admin"
     -- role that supports every operation, we don't need to check role access
     return ()
+
+verifyCapability'
+    :: MonadIO m
+    => (LocalActorBy Key, OutboxItemId)
+    -> Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> GrantResourceBy Key
+    -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyCapability' cap actor resource = do
+    actorP <- processActor actor
+    verifyCapability cap actorP resource
+    where
+    processActor = bitraverse processLocal processRemote
+        where
+        processLocal (actorByKey, _, _) =
+            case actorByKey of
+                LocalActorPerson personID -> return personID
+                _ -> throwE "Non-person local actors can't get Grants at the moment"
+        processRemote (author, _, _) = pure $ remoteAuthorId author

src/Vervis/Actor.hs

@@ -55,11 +55,12 @@ module Vervis.Actor
       -- * AP system base types
     , RemoteAuthor (..)
     , ActivityBody (..)
-    , VerseRemote (..)
+    --, VerseRemote (..)
+    , Verse (..)
 
       -- * Behavior utility types
-    , Verse
+    --, Verse
-    , Event (..)
+    --, Event (..)
     , Env (..)
     , Act
     , ActE
@@ -87,6 +88,7 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
 import Data.Barbie
+import Data.Bifunctor
 import Data.ByteString (ByteString)
 import Data.Foldable
 import Data.Function
@@ -290,6 +292,27 @@ data ActivityBody = ActivityBody
     , actbActivity   :: AP.Activity URIMode
     }
 
+data Verse = Verse
+    { verseSource      :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString)
+    , verseBody        :: ActivityBody
+    --, verseLocalRecips :: RecipientRoutes
+    }
+
+instance Message Verse where
+    summarize (Verse (Left (actor, _, itemID)) body) =
+        let typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+        in  T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID]
+    summarize (Verse (Right (author, luAct, _)) body) =
+        let ObjURI h _ = remoteAuthorURI author
+            typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+        in  T.concat [typ, " ", renderObjURI $ ObjURI h luAct]
+    refer (Verse (Left (actor, _, itemID)) _body) =
+        T.concat [T.pack $ show actor, " ", T.pack $ show itemID]
+    refer (Verse (Right (author, luAct, _)) _body) =
+        let ObjURI h _ = remoteAuthorURI author
+        in  renderObjURI $ ObjURI h luAct
+
+{-
 data VerseRemote = VerseRemote
     { verseAuthor   :: RemoteAuthor
     , verseBody     :: ActivityBody
@@ -341,6 +364,14 @@ data Event
     | EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId
     -- ^ A remote actor asked to Join a local topic, and the local topic is
     --   forwarding the Join to me because I'm following the topic
+    | EventTopicHandleLocalInvite PersonId OutboxItemId BL.ByteString ByteString FedURI (Either (GrantRecipBy Key) FedURI)
+    -- ^ I'm a resource and a local Person has published an invite-for-me.
+    --   Params: Sender person, Invite ID, Invite activity body, forwarding
+    --   signature header, capability URI, invite target.
+    | EventLocalInviteLocalTopicFwdToFollower OutboxItemId
+    -- ^ An authorized local actor sent an Invite-to-a-local-topic, and the
+    --   local topic is forwarding the Invite to me because I'm following the
+    --   topic
     | EventUnknown
     deriving Show
 
@@ -356,6 +387,7 @@ instance Message Verse where
     refer (Right (VerseRemote author _body _fwd uri)) =
         let ObjURI h _ = remoteAuthorURI author
         in  renderObjURI $ ObjURI h uri
+-}
 
 type YesodRender y = Route y -> [(Text, Text)] -> Text
 
@@ -470,22 +502,24 @@ data RemoteRecipient = RemoteRecipient
 -- This function reads the follower sets and remote recipient data from the
 -- PostgreSQL database. Don't use it inside a database transaction.
 sendToLocalActors
-    :: Event
+    :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)
-    -- ^ Event to send to local live actors
+    -- ^ Author of the activity being sent
+    -> ActivityBody
+    -- ^ Activity to send
     -> Bool
     -- ^ Whether to deliver to collection only if owner actor is addressed
     -> Maybe (LocalActorBy Key)
     -- ^ An actor whose collections are excluded from requiring an owner, i.e.
     --   even if owner is required, this actor's collections will be delivered
     --   to, even if this actor isn't addressed. This is meant to be the
-    --   activity's author.
+    --   activity's sender.
     -> Maybe (LocalActorBy Key)
     -- ^ An actor whose inbox to exclude from delivery, even if this actor is
     --   listed in the recipient set. This is meant to be the activity's
-    --   author.
+    --   sender.
     -> RecipientRoutes
     -> Act [((InstanceId, Host), NonEmpty RemoteRecipient)]
-sendToLocalActors event requireOwner mauthor maidAuthor recips = do
+sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
 
     -- Unhash actor and work item hashids
     people <- unhashKeys $ recipPeople recips
@@ -608,7 +642,9 @@ sendToLocalActors event requireOwner mauthor maidAuthor recips = do
             in  case maidAuthor of
                     Nothing -> s
                     Just a -> HS.delete a s
-    sendMany liveRecips $ Left event
+        authorAndId' =
+            second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId
+    sendMany liveRecips $ Verse authorAndId' body
 
     -- Return remote followers, to whom we need to deliver via HTTP
     return remoteFollowers

src/Vervis/Actor/Common.hs

@@ -20,6 +20,7 @@ module Vervis.Actor.Common
     , topicAccept
     , topicReject
     , topicInvite
+    --, topicHandleLocalInvite
     , topicJoin
     )
 where
@@ -33,6 +34,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
@@ -92,13 +94,10 @@ actorFollow
     -> (a -> Act [Aud URIMode])
     -> UTCTime
     -> Key r
-    -> RemoteAuthor
+    -> Verse
-    -> 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
+actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do
 
     -- Check input
     followee <- nameExceptT "Follow object" $ do
@@ -107,6 +106,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
             case routeOrRemote of
                 Left route -> pure route
                 Right _ -> throwE "Remote, so definitely not me/mine"
+        -- Verify the followee is me or a subobject of mine
         parseFollowee route
     verifyNothingE
         (AP.activityCapability $ actbActivity body)
@@ -114,28 +114,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
 
     maybeFollow <- withDBExcept $ do
 
-        -- Find recipient actor in DB
+        -- Find me in DB
         recip <- lift $ getJust recipID
         let recipActorID = grabActor recip
         recipActor <- lift $ getJust recipActorID
 
-        -- Insert the Follow to actor's inbox
+        -- Insert the Follow to my inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread
+        maybeFollowDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) unread
-        for mractid $ \ followID -> do
+        for maybeFollowDB $ \ followDB -> do
 
             -- Find followee in DB
             followerSetID <- getFollowee recipActor followee
 
-            -- Verify not already following us
+            -- Verify not already following me
-            let followerID = remoteAuthorId author
+            case followDB of
-            maybeFollow <-
+                Left (_, followerID, followID) -> do
-                lift $ getBy $ UniqueRemoteFollow followerID followerSetID
+                    maybeFollow <- lift $ getBy $ UniqueFollow followerID followerSetID
-            verifyNothingE maybeFollow "You're already following this object"
+                    verifyNothingE maybeFollow "You're already following this object"
+                Right (author, _, followID) -> do
+                    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
+            lift $ case followDB of
+                Left (_actorByKey, actorID, followID) ->
+                    insert_ $ Follow actorID followerSetID (not hide) followID acceptID
+                Right (author, _luFollow, followID) -> do
+                    let authorID = remoteAuthorId author
+                    insert_ $ RemoteFollow authorID followerSetID (not hide) followID acceptID
 
             -- Prepare an Accept activity and insert to actor's outbox
             accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
@@ -143,20 +152,15 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
             _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept
 
             sieve <- lift $ getSieve followee
-            return (recipActorID, followID, acceptID, sieve, accept)
+            return (recipActorID, 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
+        Just (actorID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
-            lift $ for_ mfwd $ \ (localRecips, sig) ->
+            forwardActivity authorIdMsig body (makeLocalActor recipID) actorID sieve
-                forwardActivity
-                    (actbBL body) localRecips sig actorID
-                    (makeLocalActor recipID) sieve
-                    (EventRemoteFollowLocalRecipFwdToFollower followID)
             lift $ sendActivity
                 (makeLocalActor recipID) actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-                EventAcceptRemoteFollow actionAccept
             done "Recorded Follow and published Accept"
 
     where
@@ -164,14 +168,8 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
     prepareAccept followee = do
         encodeRouteHome <- getEncodeRouteHome
 
-        ra <- getJust $ remoteAuthorId author
+        audSender <- makeAudSenderWithFollowers authorIdMsig
-
+        uFollow <- lift $ getActivityURI authorIdMsig
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-
-            audSender =
-                AudRemote hAuthor
-                    [luAuthor]
-                    (maybeToList $ remoteActorFollowers ra)
 
         audsRecip <- lift $ makeAudience followee
 
@@ -185,7 +183,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
                 , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                 , AP.actionFulfills   = []
                 , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                    { AP.acceptObject   = ObjURI hAuthor luFollow
+                    { AP.acceptObject   = uFollow
                     , AP.acceptResult   = Nothing
                     }
                 }
@@ -198,13 +196,10 @@ topicAccept
     -> (forall f. f topic -> GrantResourceBy f)
     -> UTCTime
     -> Key topic
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-topicAccept topicActor topicResource now recipKey author body mfwd luAccept accept = do
+topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) accept = do
 
     -- Check input
     acceptee <- parseAccept accept
@@ -219,7 +214,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
 
     maybeNew <- withDBExcept $ do
 
-        -- Grab recipient deck from DB
+        -- Grab me from DB
         (recipActorID, recipActor) <- lift $ do
             recip <- getJust recipKey
             let actorID = topicActor recip
@@ -263,9 +258,13 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
                             (getBy $ UniqueCollabRecipRemote collabID)
                             "Found Collab with no recip"
                             "Found Collab with multiple recips"
-                    case recip of
+                    case (recip, authorIdMsig) of
-                        Right (Entity crrid crr)
+                        (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
-                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid)
+                            | collabRecipLocalPerson crl == personID ->
+                                return (fulfillsID, Left crlid)
+                        (Right (Entity crrid crr), Right (author, _, _))
+                            | collabRecipRemoteActor crr == remoteAuthorId author ->
+                                return (fulfillsID, Right crrid)
                         _ -> throwE "Accepting an Invite whose recipient is someone else"
 
                 -- If accepting a Join, verify accepter has permission
@@ -275,9 +274,9 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
                         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
+                    verifyCapability'
                         capability
-                        (Right $ remoteAuthorId author)
+                        authorIdMsig
                         (topicResource recipKey)
                     return fulfillsID
 
@@ -285,27 +284,33 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
         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
+        maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
-        for mractid $ \ acceptID -> do
+        for maybeAcceptDB $ \ acceptDB -> do
 
             -- Record the Accept on the Collab
-            case idsForAccept of
+            case (idsForAccept, acceptDB) of
-                Left (fulfillsID, recipID) -> do
+                (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
-                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
+                    maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
-                    unless (isNothing maybeAccept) $ do
+                    unless (isNothing maybeAccept) $
-                        lift $ delete acceptID
                         throwE "This Invite already has an Accept by recip"
-                Right fulfillsID -> do
+                (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
-                    maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
+                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
-                    unless (isNothing maybeAccept) $ do
+                    unless (isJust maybeAccept) $
-                        lift $ delete acceptID
+                        throwE "This Invite already has an Accept by recip"
+                (Right fulfillsID, Left (_, _, acceptID)) -> do
+                    maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
+                    unless (isJust maybeAccept) $
                         throwE "This Join already has an Accept"
+                (Right fulfillsID, Right (author, _, acceptID)) -> do
+                    maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
+                    unless (isJust maybeAccept) $
+                        throwE "This Join already has an Accept"
+                _ -> error "topicAccept impossible"
 
             -- 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
 
@@ -315,29 +320,23 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
 
                 -- Prepare a Grant activity and insert to my outbox
                 let inviterOrJoiner = either snd snd collab
+                    isInvite = isLeft 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)
+            return (recipActorID, 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
+        Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
             let recipByID = grantResourceLocalActor $ topicResource recipKey
-            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
-                forwardActivity
-                    (actbBL body) localRecips sig recipActorID recipByID sieve
-                    (if isInvite
-                        then EventRemoteAcceptInviteLocalResourceFwdToFollower acceptID
-                        else EventRemoteApproveJoinLocalResourceFwdToFollower acceptID
-                    )
             lift $ sendActivity
                 recipByID recipActorID localRecipsGrant
-                remoteRecipsGrant fwdHostsGrant grantID
+                remoteRecipsGrant fwdHostsGrant grantID actionGrant
-                (EventGrantAfterRemoteAccept grantID) actionGrant
             done "Forwarded the Accept and published a Grant"
 
     where
@@ -371,12 +370,15 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
         encodeRouteHome <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
 
-        accepter <- getJust $ remoteAuthorId author
+        audAccepter <- makeAudSenderWithFollowers authorIdMsig
+        audApprover <- lift $ makeAudSenderOnly authorIdMsig
         recipHash <- encodeKeyHashid recipKey
         let topicByHash = grantResourceLocalActor $ topicResource recipHash
 
         senderHash <- bitraverse hashLocalActor pure sender
 
+        uAccepter <- lift $ getActorURI authorIdMsig
+
         let audience =
                 if isInvite
                     then
@@ -385,9 +387,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
                                     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
@@ -396,9 +395,6 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
                                     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]
 
@@ -417,7 +413,7 @@ topicAccept topicActor topicResource now recipKey author body mfwd luAccept acce
                         encodeRouteLocal $ renderLocalActor topicByHash
                     , AP.grantTarget    =
                         if isInvite
-                            then remoteAuthorURI author
+                            then uAccepter
                             else case senderHash of
                                 Left actor ->
                                     encodeRouteHome $ renderLocalActor actor
@@ -438,13 +434,10 @@ topicReject
     -> (forall f. f topic -> GrantResourceBy f)
     -> UTCTime
     -> Key topic
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Reject URIMode
     -> ActE (Text, Act (), Next)
-topicReject topicActor topicResource now recipKey author body mfwd luReject reject = do
+topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reject = do
 
     -- Check input
     rejectee <- parseReject reject
@@ -459,7 +452,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
 
     maybeNew <- withDBExcept $ do
 
-        -- Grab recipient deck from DB
+        -- Grab me from DB
         (recipActorID, recipActor) <- lift $ do
             recip <- getJust recipKey
             let actorID = topicActor recip
@@ -503,9 +496,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                             (getBy $ UniqueCollabRecipRemote collabID)
                             "Found Collab with no recip"
                             "Found Collab with multiple recips"
-                    case recip of
+                    case (recip, authorIdMsig) of
-                        Right (Entity crrid crr)
+                        (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
-                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid, deleteInviter)
+                            | collabRecipLocalPerson crl == personID ->
+                                return (fulfillsID, Left crlid, deleteInviter)
+                        (Right (Entity crrid crr), Right (author, _, _))
+                            | collabRecipRemoteActor crr == remoteAuthorId author ->
+                                return (fulfillsID, Right crrid, deleteInviter)
                         _ -> throwE "Rejecting an Invite whose recipient is someone else"
 
                 -- If rejecting a Join, verify accepter has permission
@@ -515,9 +512,9 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                         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
+                    verifyCapability'
                         capability
-                        (Right $ remoteAuthorId author)
+                        authorIdMsig
                         (topicResource recipKey)
                     return (fulfillsID, deleteRecipJoin, deleteRecip)
 
@@ -527,7 +524,11 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
 
         -- Verify the Collab isn't already accepted/approved
         case idsForReject of
-            Left (_fulfillsID, recipID, _) -> do
+            Left (_fulfillsID, Left recipID, _) -> do
+                mval <-
+                    lift $ getBy $ UniqueCollabRecipLocalAcceptCollab recipID
+                verifyNothingE mval "Invite is already accepted"
+            Left (_fulfillsID, Right recipID, _) -> do
                 mval <-
                     lift $ getBy $ UniqueCollabRecipRemoteAcceptCollab recipID
                 verifyNothingE mval "Invite is already accepted"
@@ -537,13 +538,13 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                 unless (isNothing mval1 && isNothing mval2) $
                     throwE "Join is already approved"
 
-        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luReject False
+        maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
-        for mractid $ \ rejectID -> do
+        for maybeRejectDB $ \ rejectDB -> do
 
             -- Delete the whole Collab record
             case idsForReject of
                 Left (fulfillsID, recipID, deleteInviter) -> lift $ do
-                    delete recipID
+                    bitraverse_ delete delete recipID
                     deleteTopic
                     deleteInviter
                     delete fulfillsID
@@ -558,36 +559,29 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
             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
+                    isInvite = isLeft 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)
+            return (recipActorID, 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
+        Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
             let recipByID = grantResourceLocalActor $ topicResource recipKey
-            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
-                forwardActivity
-                    (actbBL body) localRecips sig recipActorID recipByID sieve
-                    (if isInvite
-                        then EventRemoteRejectInviteLocalResourceFwdToFollower rejectID
-                        else EventRemoteForbidJoinLocalResourceFwdToFollower rejectID
-                    )
             lift $ sendActivity
                 recipByID recipActorID localRecips
-                remoteRecips fwdHosts newRejectID
+                remoteRecips fwdHosts newRejectID action
-                (EventRejectAfterRemoteReject newRejectID) action
             done "Forwarded the Reject and published my own Reject"
 
     where
@@ -623,12 +617,15 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
         encodeRouteHome <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
 
-        rejecter <- getJust $ remoteAuthorId author
+        audRejecter <- makeAudSenderWithFollowers authorIdMsig
+        audForbidder <- lift $ makeAudSenderOnly authorIdMsig
         recipHash <- encodeKeyHashid recipKey
         let topicByHash = grantResourceLocalActor $ topicResource recipHash
 
         senderHash <- bitraverse hashLocalActor pure sender
 
+        uReject <- lift $ getActivityURI authorIdMsig
+
         let audience =
                 if isInvite
                     then
@@ -637,9 +634,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                                     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
@@ -648,9 +642,6 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                                     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]
 
@@ -662,10 +653,7 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                 { AP.actionCapability = Nothing
                 , AP.actionSummary    = Nothing
                 , AP.actionAudience   = AP.Audience recips [] [] [] [] []
-                , AP.actionFulfills   =
+                , AP.actionFulfills   = [uReject]
-                    [ let ObjURI h _ = remoteAuthorURI author
-                      in  ObjURI h luReject
-                    ]
                 , AP.actionSpecific   = AP.RejectActivity AP.Reject
                     { AP.rejectObject = AP.rejectObject reject
                     }
@@ -684,13 +672,10 @@ topicInvite
     -> (CollabId -> Key topic -> ct)
     -> UTCTime
     -> Key topic
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
-topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luInvite invite = do
+topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) invite = do
 
     -- Check capability
     capability <- do
@@ -713,8 +698,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
 
     -- Check invite
     targetByKey <- do
-        (resource, recipient) <-
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-            parseInvite (Right $ remoteAuthorURI author) invite
+        (resource, recipient) <- parseInvite author invite
         unless (Left (topicResource topicKey) == resource) $
             throwE "Invite topic isn't me"
         return recipient
@@ -747,17 +732,14 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
 
     maybeNew <- withDBExcept $ do
 
-        -- Grab topic from DB
+        -- Grab me from DB
         (topicActorID, topicActor) <- lift $ do
             recip <- getJust topicKey
             let actorID = grabActor recip
             (actorID,) <$> getJust actorID
 
         -- Verify the specified capability gives relevant access
-        verifyCapability
+        verifyCapability' capability authorIdMsig (topicResource topicKey)
-            capability
-            (Right $ remoteAuthorId author)
-            (topicResource topicKey)
 
         -- Verify that target doesn't already have a Collab for me
         existingCollabIDs <-
@@ -785,11 +767,11 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             [_] -> throwE "I already have a Collab for the target"
             _ -> error "Multiple collabs found for target"
 
-        mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luInvite False
+        maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
-        lift $ for mractid $ \ inviteID -> do
+        lift $ for maybeInviteDB $ \ inviteDB -> do
 
             -- Insert Collab record to DB
-            insertCollab targetDB inviteID
+            insertCollab targetDB inviteDB
 
             -- Prepare forwarding Invite to my followers
             sieve <- do
@@ -797,26 +779,27 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                 let topicByHash =
                         grantResourceLocalActor $ topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
-            return (topicActorID, inviteID, sieve)
+            return (topicActorID, sieve)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just (topicActorID, inviteID, sieve) -> do
+        Just (topicActorID, sieve) -> do
             let topicByID = grantResourceLocalActor $ topicResource topicKey
-            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+            forwardActivity authorIdMsig body topicByID topicActorID sieve
-                forwardActivity
-                    (actbBL body) localRecips sig topicActorID topicByID sieve
-                    (EventRemoteInviteLocalTopicFwdToFollower inviteID)
             done "Recorded and forwarded the Invite"
 
     where
 
-    insertCollab recipient inviteID = do
+    insertCollab recipient inviteDB = do
         collabID <- insert Collab
         fulfillsID <- insert $ CollabFulfillsInvite collabID
         insert_ $ collabTopicCtor collabID topicKey
-        let authorID = remoteAuthorId author
+        case inviteDB of
-        insert_ $ CollabInviterRemote fulfillsID authorID inviteID
+            Left (_, _, inviteID) ->
+                insert_ $ CollabInviterLocal fulfillsID inviteID
+            Right (author, _, inviteID) -> do
+                let authorID = remoteAuthorId author
+                insert_ $ CollabInviterRemote fulfillsID authorID inviteID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
                 insert_ $ CollabRecipLocal collabID personID
@@ -834,13 +817,10 @@ topicJoin
     -> (CollabId -> Key topic -> ct)
     -> UTCTime
     -> Key topic
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Join URIMode
     -> ActE (Text, Act (), Next)
-topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luJoin join = do
+topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do
 
     -- Check input
     resource <- parseJoin join
@@ -849,58 +829,81 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
 
     maybeNew <- withDBExcept $ do
 
-        -- Grab topic from DB
+        -- Grab me from DB
         (topicActorID, topicActor) <- lift $ do
             recip <- getJust topicKey
             let actorID = grabActor recip
             (actorID,) <$> getJust actorID
 
         -- Verify that target doesn't already have a Collab for me
-        existingCollabIDs <- lift $ do
+        existingCollabIDs <- lift $
-            let targetID = remoteAuthorId author
+            case authorIdMsig of
-            E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
+                Left (LocalActorPerson personID, _, _) ->
-                E.on $
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
-                    topic E.^. topicCollabField E.==.
+                        E.on $
-                    recipr E.^. CollabRecipRemoteCollab
+                            topic E.^. topicCollabField E.==.
-                E.where_ $
+                            recipl E.^. CollabRecipLocalCollab
-                    topic E.^. topicField E.==. E.val topicKey E.&&.
+                        E.where_ $
-                    recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
+                            topic E.^. topicField E.==. E.val topicKey E.&&.
-                return $ recipr E.^. CollabRecipRemoteCollab
+                            recipl E.^. CollabRecipLocalPerson E.==. E.val personID
+                        return $ recipl E.^. CollabRecipLocalCollab
+                Left (_, _, _) -> pure []
+                Right (author, _, _) -> do
+                    let targetID = remoteAuthorId author
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
+                        E.on $
+                            topic E.^. topicCollabField E.==.
+                            recipr E.^. CollabRecipRemoteCollab
+                        E.where_ $
+                            topic E.^. topicField E.==. E.val topicKey E.&&.
+                            recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
+                        return $ recipr E.^. CollabRecipRemoteCollab
         case existingCollabIDs of
             [] -> pure ()
             [_] -> throwE "I already have a Collab for the target"
             _ -> error "Multiple collabs found for target"
 
-        mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luJoin False
+        maybeJoinDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
-        lift $ for mractid $ \ joinID -> do
+        for maybeJoinDB $ \ joinDB -> do
 
             -- Insert Collab record to DB
-            insertCollab joinID
+            joinDB' <-
+                bitraverse
+                    (\ (authorByKey, _, joinID) ->
+                        case authorByKey of
+                            LocalActorPerson personID -> pure (personID, joinID)
+                            _ -> throwE "Non-person local actors can't get Grants currently"
+                    )
+                    pure
+                    joinDB
+            lift $ insertCollab joinDB'
 
             -- Prepare forwarding Join to my followers
-            sieve <- do
+            sieve <- lift $ do
                 topicHash <- encodeKeyHashid topicKey
                 let topicByHash =
                         grantResourceLocalActor $ topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
-            return (topicActorID, joinID, sieve)
+            return (topicActorID, sieve)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just (topicActorID, joinID, sieve) -> do
+        Just (topicActorID, sieve) -> do
             let topicByID = grantResourceLocalActor $ topicResource topicKey
-            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+            forwardActivity authorIdMsig body topicByID topicActorID sieve
-                forwardActivity
-                    (actbBL body) localRecips sig topicActorID topicByID sieve
-                    (EventRemoteJoinLocalTopicFwdToFollower joinID)
             done "Recorded and forwarded the Join"
 
     where
 
-    insertCollab joinID = do
+    insertCollab joinDB = do
         collabID <- insert Collab
         fulfillsID <- insert $ CollabFulfillsJoin collabID
         insert_ $ collabTopicCtor collabID topicKey
-        let authorID = remoteAuthorId author
+        case joinDB of
-        recipID <- insert $ CollabRecipRemote collabID authorID
+            Left (personID, joinID) -> do
-        insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
+                recipID <- insert $ CollabRecipLocal collabID personID
+                insert_ $ CollabRecipLocalJoin recipID fulfillsID joinID
+            Right (author, _, joinID) -> do
+                let authorID = remoteAuthorId author
+                recipID <- insert $ CollabRecipRemote collabID authorID
+                insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID

src/Vervis/Actor/Deck.hs

@@ -82,13 +82,10 @@ import Vervis.Ticket
 deckFollow
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Follow URIMode
     -> ActE (Text, Act (), Next)
-deckFollow now recipDeckID author body mfwd luFollow follow = do
+deckFollow now recipDeckID verse follow = do
     recipDeckHash <- encodeKeyHashid recipDeckID
     actorFollow
         (\case
@@ -111,13 +108,13 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
         (\ _ -> pure $ makeRecipientSet [] [])
         LocalActorDeck
         (\ _ -> pure [])
-        now recipDeckID author body mfwd luFollow follow
+        now recipDeckID verse follow
 
 ------------------------------------------------------------------------------
 -- Access
 ------------------------------------------------------------------------------
 
--- Meaning: A remote actor accepted something
+-- Meaning: An actor accepted something
 -- Behavior:
 --     * If it's on an Invite where I'm the resource:
 --         * Verify the Accept is by the Invite target
@@ -135,15 +132,12 @@ deckFollow now recipDeckID author body mfwd luFollow follow = do
 deckAccept
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
 deckAccept = topicAccept deckActor GrantResourceDeck
 
--- Meaning: A remote actor rejected something
+-- Meaning: An actor rejected something
 -- Behavior:
 --     * If it's on an Invite where I'm the resource:
 --         * Verify the Reject is by the Invite target
@@ -163,15 +157,12 @@ deckAccept = topicAccept deckActor GrantResourceDeck
 deckReject
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Reject URIMode
     -> ActE (Text, Act (), Next)
 deckReject = topicReject deckActor GrantResourceDeck
 
--- Meaning: A remote actor A invited someone B to a resource
+-- Meaning: An actor A invited actor B to a resource
 -- Behavior:
 --      * Verify the resource is me
 --      * Verify A isn't inviting themselves
@@ -182,10 +173,7 @@ deckReject = topicReject deckActor GrantResourceDeck
 deckInvite
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
 deckInvite =
@@ -193,7 +181,7 @@ deckInvite =
         deckActor GrantResourceDeck
         CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
 
--- Meaning: A remote actor A asked to join a resource
+-- Meaning: An actor A asked to join a resource
 -- Behavior:
 --      * Verify the resource is me
 --      * Verify A doesn't already have an invite/join/grant for me
@@ -202,10 +190,7 @@ deckInvite =
 deckJoin
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Join URIMode
     -> ActE (Text, Act (), Next)
 deckJoin =
@@ -217,7 +202,7 @@ deckJoin =
 -- Ambiguous: Following/Resolving
 ------------------------------------------------------------------------------
 
--- Meaning: A remote actor is undoing some previous action
+-- Meaning: An 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
@@ -231,13 +216,10 @@ deckJoin =
 deckUndo
     :: UTCTime
     -> DeckId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Undo URIMode
     -> ActE (Text, Act (), Next)
-deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
+deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
 
     -- Check input
     undone <-
@@ -255,14 +237,14 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
 
     maybeNew <- withDBExcept $ do
 
-        -- Grab recipient deck from DB
+        -- Grab me from DB
         (deckRecip, actorRecip) <- lift $ do
             p <- getJust recipDeckID
             (p,) <$> getJust (deckActor p)
 
-        -- Insert the Undo to deck's inbox
+        -- Insert the Undo to my inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luUndo False
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
-        for mractid $ \ undoID -> do
+        for mractid $ \ _undoDB -> do
 
             maybeUndo <- runMaybeT $ do
 
@@ -271,7 +253,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
 
                 let followers = actorFollowers actorRecip
                 asum
-                    [ tryUnfollow followers undoneDB
+                    [ tryUnfollow followers undoneDB authorIdMsig
                     , tryUnresolve maybeCapability undoneDB
                     ]
 
@@ -285,28 +267,43 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
             accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
             _luAccept <- lift $ updateOutboxItem' (LocalActorDeck recipDeckID) acceptID actionAccept
 
-            return (deckActor deckRecip, undoID, sieve, acceptID, accept)
+            return (deckActor deckRecip, 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
+        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
-            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+            forwardActivity
-                forwardActivity
+                authorIdMsig body (LocalActorDeck recipDeckID) actorID sieve
-                    (actbBL body) localRecips sig actorID
-                    (LocalActorDeck recipDeckID) sieve
-                    (EventRemoteUnresolveLocalResourceFwdToFollower undoID)
             lift $ sendActivity
                 (LocalActorDeck recipDeckID) actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-                EventAcceptRemoteFollow actionAccept
             done
                 "Undid the Follow/Resolve, forwarded the Undo and published \
                 \Accept"
 
     where
 
-    tryUnfollow _               (Left _)                 = mzero
+    verifyTargetTicket followerSetID = do
-    tryUnfollow deckFollowersID (Right remoteActivityID) = do
+        ticketID <-
+            MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
+        TicketDeck _ d <-
+            MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
+        guard $ d == recipDeckID
+
+    tryUnfollow deckFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do
+        Entity followID follow <-
+            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
+        let followerID = followActor follow
+            followerSetID = followTarget follow
+        verifyTargetMe followerSetID <|> verifyTargetTicket 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 == deckFollowersID
+    tryUnfollow deckFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
         Entity remoteFollowID remoteFollow <-
             MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
         let followerID = remoteFollowActor remoteFollow
@@ -315,17 +312,11 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
         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 <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
-            audSenderOnly = AudRemote hAuthor [luAuthor] []
         return (makeRecipientSet [] [], [audSenderOnly])
         where
         verifyTargetMe followerSetID = guard $ followerSetID == deckFollowersID
-        verifyTargetTicket followerSetID = do
+    tryUnfollow _ _ _ = mzero
-            ticketID <-
-                MaybeT $ lift $ getKeyBy $ UniqueTicketFollowers followerSetID
-            TicketDeck _ d <-
-                MaybeT $ lift $ getValBy $ UniqueTicketDeck ticketID
-            guard $ d == recipDeckID
 
     tryUnresolve maybeCapability undone = do
         (deleteFromDB, ticketID) <- findTicket undone
@@ -343,22 +334,16 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
                 Left c -> pure c
                 Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
         lift $
-            verifyCapability
+            verifyCapability'
                 capability
-                (Right $ remoteAuthorId author)
+                authorIdMsig
                 (GrantResourceDeck recipDeckID)
 
         lift $ lift deleteFromDB
 
         recipDeckHash <- encodeKeyHashid recipDeckID
         taskHash <- encodeKeyHashid taskID
-        audSender <- lift $ do
+        audSender <- lift $ lift $ makeAudSenderWithFollowers authorIdMsig
-            ra <- lift $ getJust $ remoteAuthorId author
-            let ObjURI hAuthor luAuthor = remoteAuthorURI author
-            return $
-                AudRemote hAuthor
-                    [luAuthor]
-                    (maybeToList $ remoteActorFollowers ra)
         return
             ( makeRecipientSet
                 []
@@ -399,8 +384,8 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
     prepareAccept audience = do
         encodeRouteHome <- getEncodeRouteHome
 
-        let ObjURI hAuthor _ = remoteAuthorURI author
+        uUndo <- getActivityURI authorIdMsig
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                 collectAudience audience
 
             recips = map encodeRouteHome audLocal ++ audRemote
@@ -410,7 +395,7 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
                 , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                 , AP.actionFulfills   = []
                 , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                    { AP.acceptObject   = ObjURI hAuthor luUndo
+                    { AP.acceptObject   = uUndo
                     , AP.acceptResult   = Nothing
                     }
                 }
@@ -421,27 +406,15 @@ deckUndo now recipDeckID author body mfwd luUndo (AP.Undo uObject) = do
 -- Main behavior function
 ------------------------------------------------------------------------------
 
-deckBehavior
+deckBehavior :: UTCTime -> DeckId -> Verse -> ActE (Text, Act (), Next)
-    :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+deckBehavior now deckID verse@(Verse _authorIdMsig body) =
-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 ->
+        AP.AcceptActivity accept -> deckAccept now deckID verse accept
-            deckAccept now deckID author body mfwd luActivity accept
+        AP.FollowActivity follow -> deckFollow now deckID verse follow
-        AP.FollowActivity follow ->
+        AP.InviteActivity invite -> deckInvite now deckID verse invite
-            deckFollow now deckID author body mfwd luActivity follow
+        AP.JoinActivity join     -> deckJoin now deckID verse join
-        AP.InviteActivity invite ->
+        AP.RejectActivity reject -> deckReject now deckID verse reject
-            deckInvite now deckID author body mfwd luActivity invite
+        AP.UndoActivity undo     -> deckUndo now deckID verse undo
-        AP.JoinActivity join ->
-            deckJoin now deckID author body mfwd luActivity join
-        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"
 
 instance VervisActor Deck where

src/Vervis/Actor/Group.hs

@@ -52,14 +52,8 @@ import Vervis.Model
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
-groupBehavior
+groupBehavior :: UTCTime -> GroupId -> Verse -> ActE (Text, Act (), Next)
-    :: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+groupBehavior now groupID _verse@(Verse _authorIdMsig body) =
-groupBehavior now groupID (Left event) =
-    case event of
-        EventRemoteFwdLocalActivity _ _ ->
-            throwE "Got a forwarded local activity, I don't need those"
-        _ -> throwE $ "Unsupported event for Group: " <> T.pack (show event)
-groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of
         _ -> throwE "Unsupported activity type for Group"
 

src/Vervis/Actor/Loom.hs

@@ -52,14 +52,8 @@ import Vervis.Model
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
-loomBehavior
+loomBehavior :: UTCTime -> LoomId -> Verse -> ActE (Text, Act (), Next)
-    :: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+loomBehavior now loomID _verse@(Verse _authorIdMsig body) =
-loomBehavior now loomID (Left event) =
-    case event of
-        EventRemoteFwdLocalActivity _ _ ->
-            throwE "Got a forwarded local activity, I don't need those"
-        _ -> throwE $ "Unsupported event for Loom: " <> T.pack (show event)
-loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of
         _ -> throwE "Unsupported activity type for Loom"
 

src/Vervis/Actor/Person.hs

@@ -36,6 +36,7 @@ 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
@@ -60,6 +61,7 @@ import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Discussion
+import Vervis.Data.Follow
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
@@ -68,6 +70,7 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.Persist.Follow
 import Vervis.Ticket
 
 ------------------------------------------------------------------------------
@@ -82,13 +85,10 @@ import Vervis.Ticket
 personFollow
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Follow URIMode
     -> ActE (Text, Act (), Next)
-personFollow now recipPersonID author body mfwd luFollow follow = do
+personFollow now recipPersonID verse follow = do
     recipPersonHash <- encodeKeyHashid recipPersonID
     actorFollow
         (\case
@@ -103,9 +103,9 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
         (\ () -> pure $ makeRecipientSet [] [])
         LocalActorPerson
         (\ () -> pure [])
-        now recipPersonID author body mfwd luFollow follow
+        now recipPersonID verse follow
 
--- Meaning: A remote actor is undoing some previous action
+-- Meaning: Someone is undoing some previous action
 -- Behavior:
 --      * Insert to my inbox
 --      * If they're undoing their Following of me:
@@ -114,13 +114,10 @@ personFollow now recipPersonID author body mfwd luFollow follow = do
 personUndo
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Undo URIMode
     -> ActE (Text, Act (), Next)
-personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
+personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
 
     -- Check input
     undone <-
@@ -129,14 +126,14 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
 
     maybeUndo <- withDBExcept $ do
 
-        -- Grab recipient person from DB
+        -- Grab me 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
+        maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
-        for mractid $ \ undoID -> do
+        for maybeUndoDB $ \ undoDB -> do
 
             maybeUndo <- runMaybeT $ do
 
@@ -144,7 +141,7 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
                 undoneDB <- MaybeT $ getActivity undone
 
                 let followers = actorFollowers actorRecip
-                tryUnfollow followers undoneDB
+                tryUnfollow followers undoneDB undoDB
 
             for maybeUndo $ \ () -> do
 
@@ -161,14 +158,12 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
         Just (Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept))) -> do
             lift $ sendActivity
                 (LocalActorPerson recipPersonID) actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-                EventAcceptRemoteFollow actionAccept
             done "Undid the Follow and published Accept"
 
     where
 
-    tryUnfollow _                 (Left _)                 = mzero
+    tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
-    tryUnfollow personFollowersID (Right remoteActivityID) = do
         Entity remoteFollowID remoteFollow <-
             MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
         let followerID = remoteFollowActor remoteFollow
@@ -177,13 +172,23 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
         unless (followerID == remoteAuthorId author) $
             lift $ throwE "You're trying to Undo someone else's Follow"
         lift $ lift $ delete remoteFollowID
+    tryUnfollow personFollowersID (Left (_, _, outboxItemID)) (Left (_, actorID, _)) = do
+        Entity followID follow <-
+            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
+        let followerID = followActor follow
+            followerSetID = followTarget follow
+        guard $ followerSetID == personFollowersID
+        unless (followerID == actorID) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete followID
+    tryUnfollow _ _ _ = mzero
 
     prepareAccept = do
         encodeRouteHome <- getEncodeRouteHome
 
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+        audSender <- makeAudSenderOnly authorIdMsig
-            audSender = AudRemote hAuthor [luAuthor] []
+        uUndo <- getActivityURI authorIdMsig
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                 collectAudience [audSender]
 
             recips = map encodeRouteHome audLocal ++ audRemote
@@ -193,47 +198,44 @@ personUndo now recipPersonID author body _mfwd luUndo (AP.Undo uObject) = do
                 , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                 , AP.actionFulfills   = []
                 , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                    { AP.acceptObject   = ObjURI hAuthor luUndo
+                    { AP.acceptObject   = uUndo
                     , AP.acceptResult   = Nothing
                     }
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
--- Meaning: A remote actor accepted something
+-- Meaning: An actor accepted something
 -- Behavior:
 --      * Insert to my inbox
 --      * If it's a Follow I sent to them, add to my following list in DB
 personAccept
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-personAccept now recipPersonID author body _mfwd luAccept accept = do
+personAccept now recipPersonID (Verse authorIdMsig body) accept = do
 
     -- Check input
     acceptee <- parseAccept accept
 
-    maybeAccept <- withDBExcept $ do
+    maybeNew <- withDBExcept $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luAccept True
+        maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for mractid $ \ acceptID -> runMaybeT $ do
+        for maybeAcceptDB $ \ acceptDB -> runMaybeT $ do
 
             -- Find the accepted activity in our DB
             accepteeDB <- MaybeT $ getActivity acceptee
 
-            tryFollow (personActor personRecip) accepteeDB acceptID
+            tryFollow (personActor personRecip) accepteeDB acceptDB
 
-    case maybeAccept of
+    case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just Nothing -> done "Not my Follow; Just inserted to my inbox"
         Just (Just ()) ->
@@ -241,7 +243,7 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
 
     where
 
-    tryFollow actorID (Left (_, _, outboxItemID)) acceptID = do
+    tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
         Entity key val <-
             MaybeT $ lift $
                 getBy $ UniqueFollowRemoteRequestActivity outboxItemID
@@ -261,42 +263,55 @@ personAccept now recipPersonID author body _mfwd luAccept accept = do
             , followRemoteFollow = outboxItemID
             , followRemoteAccept = acceptID
             }
+    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, acceptID)) = do
+        Entity key val <-
+            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
+        guard $ followRequestActor val == actorID
+        targetByKey <-
+            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
+        unless (authorByKey == targetByKey) $
+            lift $ throwE "You're Accepting a Follow I sent to someone else"
+        lift $ lift $ delete key
+        lift $ lift $ insert_ Follow
+            { followActor  = actorID
+            , followTarget = followRequestTarget val
+            , followPublic = followRequestPublic val
+            , followFollow = outboxItemID
+            , followAccept = acceptID
+            }
     tryFollow _ (Right _) _ = mzero
 
--- Meaning: A remote actor rejected something
+-- Meaning: An actor rejected something
 -- Behavior:
 --      * Insert to my inbox
 --      * If it's a Follow I sent to them, remove record from my DB
 personReject
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Reject URIMode
     -> ActE (Text, Act (), Next)
-personReject now recipPersonID author body _mfwd luReject reject = do
+personReject now recipPersonID (Verse authorIdMsig body) reject = do
 
     -- Check input
     rejectee <- parseReject reject
 
-    maybeReject <- withDBExcept $ do
+    maybeNew <- withDBExcept $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luReject True
+        maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for mractid $ \ rejectID -> runMaybeT $ do
+        for maybeRejectDB $ \ _rejectDB -> runMaybeT $ do
 
             -- Find the rejected activity in our DB
             rejecteeDB <- MaybeT $ getActivity rejectee
 
-            tryFollow rejecteeDB
+            tryFollow (personActor personRecip) rejecteeDB authorIdMsig
 
-    case maybeReject of
+    case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just Nothing -> done "Not my Follow; Just inserted to my inbox"
         Just (Just ()) ->
@@ -304,7 +319,7 @@ personReject now recipPersonID author body _mfwd luReject reject = do
 
     where
 
-    tryFollow (Left (_, _, outboxItemID)) = do
+    tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do
         Entity key val <-
             MaybeT $ lift $
                 getBy $ UniqueFollowRemoteRequestActivity outboxItemID
@@ -316,7 +331,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
         unless (remoteAuthorURI author == uRecip) $
             lift $ throwE "You're Rejecting a Follow I sent to someone else"
         lift $ lift $ delete key
-    tryFollow (Right _) = mzero
+    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, _)) = do
+        Entity key val <-
+            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
+        guard $ followRequestActor val == actorID
+        targetByKey <-
+            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
+        unless (authorByKey == targetByKey) $
+            lift $ throwE "You're Rejecting a Follow I sent to someone else"
+        lift $ lift $ delete key
+    tryFollow _ (Right _) _ = mzero
 
 ------------------------------------------------------------------------------
 -- Commenting
@@ -327,18 +351,16 @@ personReject now recipPersonID author body _mfwd luReject reject = do
 personCreateNote
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Note URIMode
     -> ActE (Text, Act (), Next)
-personCreateNote now recipPersonID author body mfwd luCreate note = do
+personCreateNote now recipPersonID (Verse authorIdMsig body) note = do
 
     -- Check input
     (luNote, published, Comment maybeParent topic source content) <- do
         (luId, luAuthor, published, comment) <- parseRemoteComment note
-        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
+        uCreateAuthor <- lift $ getActorURI authorIdMsig
+        unless (luAuthor == objUriLocal uCreateAuthor) $
             throwE "Create author != note author"
         return (luId, published, comment)
 
@@ -352,7 +374,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
 
             Right uContext -> do
                 checkContextParent uContext maybeParent
-                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
 
             Left (CommentTopicTicket deckID taskID) -> do
                 (_, _, Entity _ ticket, _, _) <- do
@@ -360,7 +382,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
                     fromMaybeE mticket "Context: No such deck-ticket"
                 let did = ticketDiscuss ticket
                 _ <- traverse (getMessageParent did) maybeParent
-                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
 
             Left (CommentTopicCloth loomID clothID) -> do
                 (_, _, Entity _ ticket, _, _, _) <- do
@@ -368,7 +390,7 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
                     fromMaybeE mticket "Context: No such loom-cloth"
                 let did = ticketDiscuss ticket
                 _ <- traverse (getMessageParent did) maybeParent
-                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) True
 
     done $
         case mractid of
@@ -409,344 +431,165 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
 personInvite
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
-personInvite now recipPersonID author body mfwd luInvite invite = do
+personInvite now recipPersonID (Verse authorIdMsig body) invite = do
 
     -- Check input
     recipient <- do
-        (_resource, target) <-
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-            parseInvite (Right $ remoteAuthorURI author) invite
+        (_resource, target) <- parseInvite author invite
         return target
 
-    maybeInvite <- withDBExcept $ do
+    maybeNew <- withDBExcept $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True
+        maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for mractid $ \ inviteID ->
+        for maybeInviteDB $ \ _inviteDB ->
-            return (personActor personRecip, inviteID)
+            return $ personActor personRecip
 
-    case maybeInvite of
+    case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just (actorID, inviteID) -> do
+        Just actorID -> do
             let targetIsRecip =
                     case recipient of
                         Left (GrantRecipPerson p) -> p == recipPersonID
                         _ -> False
             if not targetIsRecip
                 then done "I'm not the target; Inserted to inbox"
-                else case mfwd of
+                else do
-                    Nothing ->
+                    recipHash <- encodeKeyHashid recipPersonID
-                        done
+                    let sieve =
-                            "I'm the target; Inserted to inbox; \
+                            makeRecipientSet
-                            \Forwarding not approved"
+                                []
-                    Just (localRecips, sig) -> do
+                                [LocalStagePersonFollowers recipHash]
-                        recipHash <- encodeKeyHashid recipPersonID
+                    forwardActivity
-                        let sieve =
+                        authorIdMsig body (LocalActorPerson recipPersonID)
-                                makeRecipientSet
+                        actorID sieve
-                                    []
+                    done
-                                    [LocalStagePersonFollowers recipHash]
+                        "I'm the target; Inserted to inbox; \
-                        lift $ forwardActivity
+                        \Forwarded to followers if addressed"
-                            (actbBL body) localRecips sig
-                            actorID
-                            (LocalActorPerson recipPersonID) sieve
-                            (EventRemoteInviteLocalRecipFwdToFollower inviteID)
-                        done
-                            "I'm the target; Inserted to inbox; \
-                            \Forwarded to followers if addressed"
 
 -- Meaning: Someone asked to join a resource
 -- Behavior: Insert to my inbox
 personJoin
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Join URIMode
     -> ActE (Text, Act (), Next)
-personJoin now recipPersonID author body mfwd luJoin join = do
+personJoin now recipPersonID (Verse authorIdMsig body) join = do
 
     -- Check input
     _resource <- parseJoin join
 
     maybeJoinID <- lift $ withDB $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (_personRecip, actorRecip) <- do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        insertToInbox now author body (actorInbox actorRecip) luJoin True
+        insertToInbox now authorIdMsig body (actorInbox actorRecip) True
 
     case maybeJoinID of
         Nothing -> done "I already have this activity in my inbox"
         Just _joinID -> done "Inserted to my inbox"
 
--- Meaning: A remote actor published a Grant
+-- Meaning: An actor published a Grant
 -- Behavior:
 --      * Insert to my inbox
 personGrant
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Grant URIMode
     -> ActE (Text, Act (), Next)
-personGrant now recipPersonID author body mfwd luGrant grant = do
+personGrant now recipPersonID (Verse authorIdMsig body) grant = do
 
     -- Check input
-    (_remoteResource, recipient) <- do
+    target <- do
-        let u@(ObjURI h _) = remoteAuthorURI author
+        h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
         (resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant
-        resourceURI <-
+        case (recip, authorIdMsig) of
-            case resource of
+            (Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _))
-                Right r -> return (u, r)
+                | p == p' ->
-                _ -> error "Remote Grant but parseGrant identified local resource"
+                    throwE "Grant sender and target are the same local Person"
-        when (recip == Right u) $
+            (Right uRecip, Right (author, _, _))
-            throwE "Grant sender and target are the same remote actor"
+                | uRecip == remoteAuthorURI author ->
-        return (resourceURI, recip)
+                    throwE "Grant sender and target are the same remote actor"
+            _ -> pure ()
+        return recip
 
     maybeGrant <- withDBExcept $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for mractid $ \ grantID ->
+        for mractid $ \ _grantDB -> return $ personActor personRecip
-            return (personActor personRecip, grantID)
 
     case maybeGrant of
         Nothing -> done "I already have this activity in my inbox"
-        Just (_actorID, _grantID) -> do
+        Just _actorID -> do
             let targetIsRecip =
-                    case recipient of
+                    case target of
                         Left (GrantRecipPerson p) -> p == recipPersonID
                         _ -> False
             if not targetIsRecip
                 then done "I'm not the target; Inserted to inbox"
                 else done "I'm the target; Inserted to inbox"
 
--- Meaning: A remote actor has revoked some previously published Grants
+-- Meaning: An actor has revoked some previously published Grants
 -- Behavior: Insert to my inbox
 personRevoke
     :: UTCTime
     -> PersonId
-    -> RemoteAuthor
+    -> Verse
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
     -> AP.Revoke URIMode
     -> ActE (Text, Act (), Next)
-personRevoke now recipPersonID author body _mfwd luRevoke (AP.Revoke _lus) = do
+personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do
 
     maybeRevoke <- lift $ withDB $ do
 
-        -- Grab recipient person from DB
+        -- Grab me from DB
         (_personRecip, actorRecip) <- do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        insertToInbox now author body (actorInbox actorRecip) luRevoke True
+        insertToInbox now authorIdMsig body (actorInbox actorRecip) True
 
     case maybeRevoke of
         Nothing -> done "I already have this activity in my inbox"
-        Just _revokeID -> done "Inserted to my inbox"
+        Just _revokeDB -> done "Inserted to my inbox"
 
 ------------------------------------------------------------------------------
 -- Main behavior function
 ------------------------------------------------------------------------------
 
-insertActivityToInbox
-    :: MonadIO m
-    => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
-insertActivityToInbox now recipActorID outboxItemID = do
-    inboxID <- actorInbox <$> getJust recipActorID
-    inboxItemID <- insert $ InboxItem True now
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return False
-        Just _ -> return True
-
 personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
-personBehavior now personID (Left event) =
+personBehavior now personID verse@(Verse _authorIdMsig body) =
-    case event of
-        -- Meaning: Someone X received an Invite and forwarded it to me because
-        --          I'm a follower of X
-        -- Behavior: Insert to my inbox
-        EventRemoteInviteLocalRecipFwdToFollower inviteID -> 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 inviteID itemID
-            done "Inserted Invite to inbox"
-        -- 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
-                verifyLocalActivityExistsInDB authorByKey outboxItemID
-                if LocalActorPerson personID == authorByKey
-                    then done "Received activity authored by self, ignoring"
-                    else do
-                        inserted <- lift $ insertActivityToInbox now (personActor recipPerson) outboxItemID
-                        done $
-                            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"
-        -- Meaning: An authorized remote actor sent an Invite on a local
-        -- resource, I'm being forwarded as a follower of the resource
-        --
-        -- Behavior: Insert the Invite to my inbox
-        EventRemoteInviteLocalTopicFwdToFollower inviteID -> 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 inviteID itemID
-            done "Inserted Invite to inbox"
-        -- Meaning: A remote actor sent a Join on a local resource, I'm being
-        -- forwarded as a follower of the resource
-        --
-        -- Behavior: Insert the Join to my inbox
-        EventRemoteJoinLocalTopicFwdToFollower joinID -> 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 joinID itemID
-            done "Inserted Invite to 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
-        AP.AcceptActivity accept ->
+        AP.AcceptActivity accept -> personAccept now personID verse accept
-            personAccept now personID author body mfwd luActivity accept
         AP.CreateActivity (AP.Create obj mtarget) ->
             case obj of
                 AP.CreateNote _ note ->
-                    personCreateNote now personID author body mfwd luActivity note
+                    personCreateNote now personID verse note
                 _ -> throwE "Unsupported create object type for people"
-        AP.FollowActivity follow ->
+        AP.FollowActivity follow -> personFollow now personID verse follow
-            personFollow now personID author body mfwd luActivity follow
+        AP.GrantActivity grant   -> personGrant now personID verse grant
-        AP.GrantActivity grant ->
+        AP.InviteActivity invite -> personInvite now personID verse invite
-            personGrant now personID author body mfwd luActivity grant
+        AP.JoinActivity join     -> personJoin now personID verse join
-        AP.InviteActivity invite ->
+        AP.RejectActivity reject -> personReject now personID verse reject
-            personInvite now personID author body mfwd luActivity invite
+        AP.RevokeActivity revoke -> personRevoke now personID verse revoke
-        AP.JoinActivity join ->
+        AP.UndoActivity undo     -> personUndo now personID verse undo
-            personJoin now personID author body mfwd luActivity join
-        AP.RejectActivity reject ->
-            personReject now personID author body mfwd luActivity reject
-        AP.RevokeActivity revoke ->
-            personRevoke now personID author body mfwd luActivity revoke
-        AP.UndoActivity undo ->
-            personUndo now personID author body mfwd luActivity undo
         _ -> throwE "Unsupported activity type for Person"
 
 instance VervisActor Person where

src/Vervis/Actor/Repo.hs

@@ -52,14 +52,8 @@ import Vervis.Model
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
-repoBehavior
+repoBehavior :: UTCTime -> RepoId -> Verse -> ActE (Text, Act (), Next)
-    :: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+repoBehavior now repoID _verse@(Verse _authorIdMsig body) =
-repoBehavior now repoID (Left event) =
-    case event of
-        EventRemoteFwdLocalActivity _ _ ->
-            throwE "Got a forwarded local activity, I don't need those"
-        _ -> throwE $ "Unsupported event for Repo: " <> T.pack (show event)
-repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) =
     case AP.activitySpecific $ actbActivity body of
         _ -> throwE "Unsupported activity type for Repo"
 

src/Vervis/Actor2.hs

@@ -23,6 +23,11 @@ module Vervis.Actor2
     ( -- * Sending messages to actors
       sendActivity
     , forwardActivity
+      -- * Preparing a new activity
+    , makeAudSenderOnly
+    , makeAudSenderWithFollowers
+    , getActivityURI
+    , getActorURI
     )
 where
 
@@ -31,10 +36,13 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Data.Barbie
+import Data.Bifunctor
 import Data.ByteString (ByteString)
 import Data.Either
+import Data.Foldable
 import Data.Hashable
 import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
@@ -58,23 +66,16 @@ import Web.Actor.Persist
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
+
 import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model hiding (Actor, Message)
-import Vervis.Recipient (renderLocalActor, localRecipSieve')
+import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience')
 import Vervis.Settings
 
-instance StageWebRoute Env where
-    type StageRoute Env = Route App
-    askUrlRenderParams = do
-        Env _ _ _ _ _ render _ _ <- askEnv
-        case cast render of
-            Nothing -> error "Env site isn't App"
-            Just r -> pure r
-    pageParamName _ = "page"
-
 askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
 askLatestInstanceKey = do
     maybeTVar <- asksEnv envActorKeys
@@ -173,15 +174,28 @@ sendActivity
     -- ^ Instances for which the sender is approving to forward this activity
     -> OutboxItemId
     -- ^ DB ID of the item in the author's outbox
-    -> Event
-    -- ^ Event to send to local live actors
     -> AP.Action URIMode
     -- ^ Activity to send to remote actors
     -> Act ()
-sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do
+sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID action = do
-    moreRemoteRecips <-
+    moreRemoteRecips <- do
         let justSender = Just senderByKey
-        in  sendToLocalActors event True justSender justSender localRecips
+            author = (senderByKey, senderActorID, itemID)
+        encodeRouteLocal <- getEncodeRouteLocal
+        itemHash <- encodeKeyHashid itemID
+        senderByHash <- hashLocalActor senderByKey
+        hLocal <- asksEnv stageInstanceHost
+        let act =
+                let luId = encodeRouteLocal $ activityRoute senderByHash itemHash
+                    luActor = encodeRouteLocal $ renderLocalActor senderByHash
+                in  AP.makeActivity luId luActor action
+            bodyBL = A.encode $ AP.Doc hLocal act
+        bodyO <-
+            case A.eitherDecode' bodyBL of
+                Left s -> error $ "Parsing encoded activity failed: " ++ s
+                Right o -> return o
+        let body = ActivityBody bodyBL bodyO act
+        sendToLocalActors (Left author) body True justSender justSender localRecips
     envelope <- do
         senderByHash <- hashLocalActor senderByKey
         prepareSendH senderActorID senderByHash itemID action
@@ -210,20 +224,20 @@ prepareForwardIK
     :: (Route App, ActorKey)
     -> LocalActorBy KeyHashid
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> Act (AP.Errand URIMode)
-prepareForwardIK (keyR, akey) fwderByHash body proof = do
+prepareForwardIK (keyR, akey) fwderByHash body mproof = do
     let sign = actorKeySign akey
         fwderR = renderLocalActor fwderByHash
-    prepareToForward keyR sign True fwderR body proof
+    prepareToForward keyR sign True fwderR body mproof
 
 prepareForwardAK
     :: ActorId
     -> LocalActorBy KeyHashid
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> ActDB (AP.Errand URIMode)
-prepareForwardAK actorID fwderByHash body proof = do
+prepareForwardAK actorID fwderByHash body mproof = do
     Entity keyID key <- do
         mk <- getBy $ UniqueSigKey actorID
         case mk of
@@ -233,31 +247,31 @@ prepareForwardAK actorID fwderByHash body proof = do
     let keyR = stampRoute fwderByHash keyHash
         sign = actorKeySign $ sigKeyMaterial key
         fwderR = renderLocalActor fwderByHash
-    prepareToForward keyR sign False fwderR body proof
+    prepareToForward keyR sign False fwderR body mproof
 
 prepareForwardP
     :: ActorId
     -> LocalActorBy KeyHashid
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> ActDB (AP.Errand URIMode)
-prepareForwardP actorID fwderByHash body proof = do
+prepareForwardP actorID fwderByHash body mproof = do
     maybeKey <- lift askLatestInstanceKey
     case maybeKey of
-        Nothing -> prepareForwardAK actorID fwderByHash body proof
+        Nothing -> prepareForwardAK actorID fwderByHash body mproof
-        Just key -> lift $ prepareForwardIK key fwderByHash body proof
+        Just key -> lift $ prepareForwardIK key fwderByHash body mproof
 
 prepareForwardH
     :: ActorId
     -> LocalActorBy KeyHashid
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> Act (AP.Errand URIMode)
-prepareForwardH actorID fwderByHash body proof = do
+prepareForwardH actorID fwderByHash body mproof = do
     maybeKey <- askLatestInstanceKey
     case maybeKey of
-        Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof
+        Nothing -> withDB $ prepareForwardAK actorID fwderByHash body mproof
-        Just key -> prepareForwardIK key fwderByHash body proof
+        Just key -> prepareForwardIK key fwderByHash body mproof
 
 -- | Given a list of local recipients, which may include actors and
 -- collections,
@@ -269,26 +283,92 @@ prepareForwardH actorID fwderByHash body proof = do
 --
 -- This function reads remote recipient data and the sender's signing key from
 -- the PostgreSQL database. Don't use it inside a database transaction.
+--
+-- For a remote author, no forwarding is done if a signature isn't provided.
 forwardActivity
-    :: BL.ByteString
+    :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString)
-    -> RecipientRoutes
+    -> ActivityBody
-    -> ByteString
-    -> ActorId
     -> LocalActorBy Key
+    -> ActorId
     -> RecipientRoutes
-    -> Event
+    -> ActE ()
-    -> Act ()
+forwardActivity sourceMaybeForward body fwderByKey fwderActorID sieve = do
-forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = do
+    let maybeForward =
-    remoteRecips <-
+            case sourceMaybeForward of
-        let localRecipsFinal = localRecipSieve' sieve False False localRecips
+                Left l -> Just $ Left l
-            justSender = Just fwderByKey
+                Right (author, luAct, msig) ->
-        in  sendToLocalActors event False justSender justSender localRecipsFinal
+                    Right . (author,luAct,) <$> msig
-    errand <- do
+    for_ maybeForward $ \ source -> do
-        fwderByHash <- hashLocalActor fwderByKey
+        localRecips <- do
-        prepareForwardH fwderActorID fwderByHash body sig
+            mrecips <- parseAudience' $ AP.activityAudience $ actbActivity body
-    let remoteRecipsList =
+            paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
-            concatMap
+        remoteRecips <-
-                (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
+            let localRecipsFinal = localRecipSieve' sieve False False localRecips
-                remoteRecips
+                justSender = Just fwderByKey
-    dt <- asksEnv stageDeliveryTheater
+                authorAndId =
-    liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList
+                    second (\ (author, luAct, _sig) -> (author, luAct)) source
+            in  lift $ sendToLocalActors authorAndId body False justSender justSender localRecipsFinal
+        errand <- lift $ do
+            fwderByHash <- hashLocalActor fwderByKey
+            let msig =
+                    case source of
+                        Left _ -> Nothing
+                        Right (_, _, b) -> Just b
+            prepareForwardH fwderActorID fwderByHash (actbBL body) msig
+        let remoteRecipsList =
+                concatMap
+                    (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
+                    remoteRecips
+        dt <- lift $ asksEnv stageDeliveryTheater
+        lift $  liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList
+
+makeAudSenderOnly
+    :: Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> Act (Aud URIMode)
+makeAudSenderOnly (Left (actorByKey, _, _)) = do
+    actorByHash <- hashLocalActor actorByKey
+    return $ AudLocal [actorByHash] []
+makeAudSenderOnly (Right (author, _, _)) = do
+    let ObjURI hAuthor luAuthor = remoteAuthorURI author
+    pure $ AudRemote hAuthor [luAuthor] []
+
+makeAudSenderWithFollowers
+    :: Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> ActDB (Aud URIMode)
+makeAudSenderWithFollowers (Left (actorByKey, _, _)) = do
+    actorByHash <- hashLocalActor actorByKey
+    return $ AudLocal [actorByHash] [localActorFollowers actorByHash]
+makeAudSenderWithFollowers (Right (author, _, _)) = do
+    let ObjURI hAuthor luAuthor = remoteAuthorURI author
+    ra <- getJust $ remoteAuthorId author
+    return $
+        AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+
+getActivityURI
+    :: Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> Act FedURI
+getActivityURI (Left (actorByKey, _, outboxItemID)) = do
+    encodeRouteHome <- getEncodeRouteHome
+    actorByHash <- hashLocalActor actorByKey
+    outboxItemHash <- encodeKeyHashid outboxItemID
+    return $ encodeRouteHome $ activityRoute actorByHash outboxItemHash
+getActivityURI (Right (author, luAct, _)) = do
+    let ObjURI hAuthor _ = remoteAuthorURI author
+    pure $ ObjURI hAuthor luAct
+
+getActorURI
+    :: Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> Act FedURI
+getActorURI (Left (actorByKey, _, _)) = do
+    encodeRouteHome <- getEncodeRouteHome
+    actorByHash <- hashLocalActor actorByKey
+    return $ encodeRouteHome $ renderLocalActor actorByHash
+getActorURI (Right (author, _, _)) = pure $ remoteAuthorURI author

src/Vervis/Data/Collab.hs

@@ -120,7 +120,7 @@ parseTopic u = do
 
 parseInvite
     :: StageRoute Env ~ Route App
-    => Either PersonId FedURI
+    => Either (LocalActorBy Key) FedURI
     -> AP.Invite URIMode
     -> ActE
         ( Either (GrantResourceBy Key) FedURI
@@ -144,7 +144,7 @@ parseInvite sender (AP.Invite instrument object target) = do
                         recipHash
                         "Contains invalid hashid"
                 case recipKey of
-                    GrantRecipPerson p | Left p == sender ->
+                    GrantRecipPerson p | Left (LocalActorPerson p) == sender ->
                         throwE "Invite local sender and recipient are the same Person"
                     _ -> return recipKey
             )

src/Vervis/Federation/Auth.hs

@@ -404,12 +404,12 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
         else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
 
 authenticateActivity
-    :: UTCTime
+    :: UTCTime -> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
-    -- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
-    -> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
 authenticateActivity now = do
     (ra, wv, body) <- do
         verifyContentTypeAP_E
+
+        -- Compute input for HTTP Signature verification
         proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
             timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
             let requires = [hRequestTarget, hHost, hDigest]
@@ -419,6 +419,7 @@ authenticateActivity now = do
                         toSeconds = toTimeUnit
                     in  fromIntegral $ toSeconds timeLimit
             prepareToVerifyHttpSig requires wants seconds now
+
         (remoteAuthor, body) <-
             withExceptT T.pack $
                 (,) <$> verifyActorSig proof
@@ -429,21 +430,13 @@ authenticateActivity now = do
                 Right wv -> return wv
         return (remoteAuthor, wvdoc, body)
     let WithValue raw (Doc hActivity activity) = wv
-        uSender = remoteAuthorURI ra
+        uSender@(ObjURI hSender luSender) = remoteAuthorURI ra
-        ObjURI hSender luSender = uSender
+        luAuthor = activityActor activity
     auth <-
-        if hSender == hActivity
+        case (hSender == hActivity, luSender == luAuthor) of
-            then do
+            (False, _) -> do
-                unless (activityActor activity == luSender) $
+                -- Sender and author are on different hosts, therefore require
-                    throwE $ T.concat
+                -- a valid forwarded signature that approves the forwarding
-                        [ "Activity's actor <"
-                        , renderObjURI $
-                            ObjURI hActivity $ activityActor activity
-                        , "> != Signature key's actor <", renderObjURI uSender
-                        , ">"
-                        ]
-                return $ ActivityAuthRemote ra
-            else do
                 ma <- checkForward uSender hActivity (activityActor activity)
                 case ma of
                     Nothing -> throwE $ T.concat
@@ -452,6 +445,28 @@ authenticateActivity now = do
                         , renderAuthority hSender, ">"
                         ]
                     Just a -> return a
+            (True, False) -> do
+                -- Sender and author are different actors on the same host,
+                -- therefore we approve the forwarding without a signature
+                hl <- hostIsLocalOld hActivity
+                if hl
+                    then ActivityAuthLocal <$> do
+                        route <- parseLocalURI luAuthor
+                        parseLocalActorE route
+                    else ActivityAuthRemote <$> do
+                        let uAuthor = ObjURI hActivity luAuthor
+                            instanceID = remoteAuthorInstance ra
+                        remoteActorID <- do
+                            result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hActivity luAuthor
+                            case result of
+                                Left Nothing -> throwE "Author @id mismatch"
+                                Left (Just err) -> throwE $ T.pack $ displayException err
+                                Right Nothing -> throwE "Author isn't an actor"
+                                Right (Just actor) -> return $ entityKey actor
+                        return $ RemoteAuthor uAuthor instanceID remoteActorID
+            (True, True) ->
+                -- Sender and author are the same actor
+                pure $ ActivityAuthRemote ra
 
     -- Verify FEP-8b32 jcs-eddsa-2022 VC data integrity proof
     for_ (AP.activityProof activity) $ \ proof -> do

src/Vervis/Federation/Discussion.hs

@@ -176,7 +176,8 @@ personCreateNoteF
     -> AP.Note URIMode
     -> ExceptT Text Handler Text
 personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
-
+    error "personCreateNoteF disabled for refactoring"
+{-
     -- Check input
     recipPersonID <- decodeKeyHashid404 recipPersonHash
     (luNote, published, Comment maybeParent topic source content) <- do
@@ -240,6 +241,7 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
                         did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
                         unless (messageRoot m == did) $
                             throwE "Remote parent belongs to a different discussion"
+-}
 
 deckCreateNoteF
     :: UTCTime
@@ -251,7 +253,8 @@ deckCreateNoteF
     -> AP.Note URIMode
     -> ExceptT Text Handler Text
 deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
-
+    error "deckCreateNoteF disabled for refactoring"
+{-
     recipDeckID <- decodeKeyHashid404 recipDeckHash
     (luNote, published, Comment maybeParent topic source content) <- do
         (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
@@ -309,6 +312,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
                     Right forwardHttp -> do
                         forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                         return "Stored to inbox, cached comment, and did inbox forwarding"
+-}
 
 loomCreateNoteF
     :: UTCTime
@@ -320,7 +324,8 @@ loomCreateNoteF
     -> AP.Note URIMode
     -> ExceptT Text Handler Text
 loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
-
+    error "loomCreateNoteF disabled for refactoring"
+{-
     recipLoomID <- decodeKeyHashid404 recipLoomHash
     (luNote, published, Comment maybeParent topic source content) <- do
         (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
@@ -378,3 +383,4 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
                     Right forwardHttp -> do
                         forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                         return "Stored to inbox, cached comment, and did inbox forwarding"
+-}

src/Vervis/Federation/Offer.hs

@@ -500,7 +500,8 @@ loomUndoF
     -> AP.Undo URIMode
     -> ExceptT Text Handler Text
 loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
-
+    error "loomUndoF disabled for refactoring"
+{-
     -- Check input
     recipLoomID <- decodeKeyHashid404 recipLoomHash
     undone <-
@@ -700,6 +701,7 @@ loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 repoUndoF
     :: UTCTime
@@ -711,7 +713,8 @@ repoUndoF
     -> AP.Undo URIMode
     -> ExceptT Text Handler Text
 repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
-
+    error "repoUndoF disabled for refactoring"
+{-
     -- Check input
     recipRepoID <- decodeKeyHashid404 recipRepoHash
     undone <-
@@ -839,3 +842,4 @@ repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}

src/Vervis/Federation/Ticket.hs

@@ -335,7 +335,8 @@ deckOfferTicketF
     -> FedURI
     -> ExceptT Text Handler Text
 deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
-
+    error "deckOfferTicketF disabled for refactoring"
+{-
     -- Check input
     recipDeckID <- decodeKeyHashid404 recipDeckHash
     (title, desc, source) <- do
@@ -474,6 +475,7 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
     instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
@@ -492,7 +494,8 @@ loomOfferTicketF
     -> FedURI
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
-
+    error "loomOfferTicketF disabled for refactoring"
+{-
     -- Check input
     recipLoomID <- decodeKeyHashid404 recipLoomHash
     (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
@@ -808,6 +811,7 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 repoOfferTicketF
     :: UTCTime
@@ -1130,7 +1134,8 @@ loomApplyF
     -> AP.Apply URIMode
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
-
+    error "loomApplyF disabled for refactoring"
+{-
     -- Check input
     recipLoomID <- decodeKeyHashid404 recipLoomHash
     (repoID, maybeBranch, clothID, bundleID) <- do
@@ -1295,6 +1300,7 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 personOfferDepF
     :: UTCTime
@@ -1899,7 +1905,8 @@ trackerResolveF
     -> AP.Resolve URIMode
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
-
+    error "trackerResolveF disabled for refactoring"
+{-
     -- Check input
     recipID <- decodeKeyHashid404 recipHash
     wiID <- nameExceptT "Resolve object" $ do
@@ -2053,6 +2060,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+-}
 
 deckResolveF
     :: UTCTime

src/Vervis/Federation/Util.hs

@@ -15,12 +15,12 @@
 
 module Vervis.Federation.Util
     ( insertToInbox
-    , insertToInbox'
     )
 where
 
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
+import Data.ByteString (ByteString)
 import Data.Either
 import Data.Time.Clock
 import Database.Persist
@@ -36,30 +36,32 @@ import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
 
--- | Insert a remote activity delivered to us into our inbox. Return its
+-- | Insert an activity delivered to us into our inbox. Return its
 -- database ID if the activity wasn't already in our inbox.
 insertToInbox
-    :: MonadIO m
+    :: UTCTime
-    => UTCTime
+    -> Either
-    -> RemoteAuthor
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
     -> ActivityBody
     -> InboxId
-    -> LocalURI
     -> Bool
-    -> ReaderT SqlBackend m (Maybe RemoteActivityId)
+    -> ActDB
-insertToInbox now author body ibid luAct unread =
+        (Maybe
-    fmap fst <$> insertToInbox' now author body ibid luAct unread
+            (Either
-
+                (LocalActorBy Key, ActorId, OutboxItemId)
-insertToInbox'
+                (RemoteAuthor, LocalURI, RemoteActivityId)
-    :: MonadIO m
+            )
-    => UTCTime
+        )
-    -> RemoteAuthor
+insertToInbox now (Left a@(_, _, outboxItemID)) body inboxID unread = do
-    -> ActivityBody
+    inboxItemID <- insert $ InboxItem unread now
-    -> InboxId
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    -> LocalURI
+    case maybeItem of
-    -> Bool
+        Nothing -> do
-    -> ReaderT SqlBackend m (Maybe (RemoteActivityId, InboxItemId))
+            delete inboxItemID
-insertToInbox' now author body ibid luAct unread = do
+            return Nothing
+        Just _ -> return $ Just $ Left a
+insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
     let iidAuthor = remoteAuthorInstance author
     roid <-
         either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
@@ -69,9 +71,9 @@ insertToInbox' now author body ibid luAct unread = do
         , remoteActivityReceived = now
         }
     ibiid <- insert $ InboxItem unread now
-    mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
+    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
     case mibrid of
         Nothing -> do
             delete ibiid
             return Nothing
-        Just _ -> return $ Just (ractid, ibiid)
+        Just _ -> return $ Just $ Right (author, luAct, ractid)

src/Vervis/Migration.hs

@@ -2936,6 +2936,8 @@ changes hLocal ctx =
     , removeField "Ticket" "status"
       -- 530
     , addEntities model_530_join
+      -- 531
+    , addEntities model_531_follow_request
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2018, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2019, 2020, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -60,6 +61,7 @@ module Vervis.Migration.Entities
     , model_497_sigkey
     , model_508_invite
     , model_530_join
+    , model_531_follow_request
     )
 where
 
@@ -235,3 +237,6 @@ model_508_invite = $(schema "508_2022-10-19_invite")
 
 model_530_join :: [Entity SqlBackend]
 model_530_join = $(schema "530_2022-11-01_join")
+
+model_531_follow_request :: [Entity SqlBackend]
+model_531_follow_request = $(schema "531_2023-06-15_follow_request")

src/Vervis/Recipient.hs

@@ -85,6 +85,7 @@ module Vervis.Recipient
     , ParsedAudience (..)
     , concatRecipients
     , parseAudience
+    , parseAudience'
 
       -- * Creating a recipient set, supporting both local and remote recips
     , Aud (..)
@@ -93,6 +94,7 @@ module Vervis.Recipient
 where
 
 import Control.Applicative
+import Control.Concurrent.Actor
 import Control.Monad
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
@@ -108,6 +110,7 @@ import Data.Semigroup
 import Data.Text (Text)
 import Data.These
 import Data.Traversable
+import Data.Typeable
 import Database.Persist
 import Database.Persist.Sql
 import GHC.Generics
@@ -127,6 +130,7 @@ import Yesod.Hashids
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
+import qualified Web.Actor as WA
 
 import Data.List.Local
 import Data.List.NonEmpty.Local
@@ -143,6 +147,15 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 
+instance WA.StageWebRoute Env where
+    type StageRoute Env = Route App
+    askUrlRenderParams = do
+        Env _ _ _ _ _ render _ _ <- askEnv
+        case cast render of
+            Nothing -> error "Env site isn't App"
+            Just r -> pure r
+    pageParamName _ = "page"
+
 -------------------------------------------------------------------------------
 -- Actor and collection-of-actors types
 --
@@ -785,6 +798,48 @@ parseRecipients recips = do
                 Nothing -> Left route
                 Just recip -> Right recip
 
+parseRecipients'
+    :: WA.StageRoute Env ~ Route App
+    => NonEmpty FedURI -> ActE (RecipientRoutes, [FedURI])
+parseRecipients' recips = do
+    hLocal <- asksEnv WA.stageInstanceHost
+    let (locals, remotes) = splitRecipients hLocal recips
+        (lusInvalid, routesInvalid, localsSet) = parseLocalRecipients locals
+    unless (null lusInvalid) $
+        throwE $
+            "Local recipients are invalid routes: " <>
+            T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid)
+    unless (null routesInvalid) $ do
+        renderUrl <- WA.askUrlRender
+        throwE $
+            "Local recipients are non-recipient routes: " <>
+            T.pack (show $ map renderUrl routesInvalid)
+    return (localsSet, remotes)
+    where
+    splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI])
+    splitRecipients home recips =
+        let (local, remote) = NE.partition ((== home) . objUriAuthority) recips
+        in  (map objUriLocal local, remote)
+
+    parseLocalRecipients
+        :: [LocalURI] -> ([LocalURI], [Route App], RecipientRoutes)
+    parseLocalRecipients lus =
+        let (lusInvalid, routes) = partitionEithers $ map parseRoute lus
+            (routesInvalid, recips) = partitionEithers $ map parseRecip routes
+            (actors, stages) = partitionEithers recips
+            grouped =
+                map recipientFromActor actors ++ map recipientFromStage stages
+        in  (lusInvalid, routesInvalid, groupLocalRecipients grouped)
+        where
+        parseRoute lu =
+            case decodeRouteLocal lu of
+                Nothing -> Left lu
+                Just route -> Right route
+        parseRecip route =
+            case parseLocalRecipient route of
+                Nothing -> Left route
+                Just recip -> Right recip
+
 parseAudience
     :: (MonadSite m, SiteEnv m ~ App)
     => AP.Audience URIMode
@@ -811,6 +866,31 @@ parseAudience audience = do
     groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
     groupByHost = groupAllExtract objUriAuthority objUriLocal
 
+parseAudience'
+    :: WA.StageRoute Env ~ Route App
+    => AP.Audience URIMode -> ActE (Maybe (ParsedAudience URIMode))
+parseAudience' audience = do
+    let recips = concatRecipients audience
+    for (nonEmpty recips) $ \ recipsNE -> do
+        (localsSet, remotes) <- parseRecipients' recipsNE
+        let remotesGrouped =
+                groupByHost $ remotes \\ AP.audienceNonActors audience
+            hosts = map fst remotesGrouped
+        return ParsedAudience
+            { paudLocalRecips  = localsSet
+            , paudRemoteActors = remotesGrouped
+            , paudBlinded      =
+                audience { AP.audienceBto = [], AP.audienceBcc = [] }
+            , paudFwdHosts     =
+                let nonActorHosts =
+                        LO.nubSort $
+                            map objUriAuthority $ AP.audienceNonActors audience
+                in  LO.isect hosts nonActorHosts
+            }
+    where
+    groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
+    groupByHost = groupAllExtract objUriAuthority objUriLocal
+
 data Aud u
     = AudLocal [LocalActor] [LocalStage]
     | AudRemote (Authority u) [LocalURI] [LocalURI]

src/Vervis/Web/Actor.hs

@@ -95,7 +95,7 @@ import Yesod.Persist.Local
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
 import qualified Web.ActivityPub as AP
 
-import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..))
+import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
 import Vervis.ActivityPub
 import Vervis.API
 import Vervis.Data.Actor
@@ -106,6 +106,7 @@ import Vervis.Foundation
 import Vervis.Model hiding (Ticket)
 import Vervis.Model.Ident
 import Vervis.Paginate
+import Vervis.Persist.Actor
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
@@ -236,26 +237,27 @@ postInbox recipByKey = do
     now <- liftIO getCurrentTime
     result <- runExceptT $ do
         (auth, body) <- authenticateActivity now
-        verse <-
+        authorIdMsig <-
             case auth of
                 ActivityAuthLocal authorByKey -> Left <$> do
                     outboxItemID <-
                         parseAuthenticatedLocalActivityURI
                             authorByKey
                             (AP.activityId $ actbActivity body)
-                    return $ EventRemoteFwdLocalActivity authorByKey outboxItemID
+                    actorID <- do
+                        ment <- lift $ runDB $ getLocalActorEntity authorByKey
+                        case ment of
+                            Nothing -> throwE "Author not found in DB"
+                            Just ent -> return $ localActorID ent
+                    return (authorByKey, actorID, outboxItemID)
                 ActivityAuthRemote author -> Right <$> do
                     luActivity <-
                         fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
-                    localRecips <- do
-                        mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
-                        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
                     recipByHash <- hashLocalActor recipByKey
                     msig <- checkForwarding recipByHash
-                    let mfwd = (localRecips,) <$> msig
+                    return (author, luActivity, msig)
-                    return $ VerseRemote author body mfwd luActivity
         theater <- getsYesod appTheater
-        r <- liftIO $ callIO theater recipByKey verse
+        r <- liftIO $ callIO theater recipByKey $ Verse authorIdMsig body
         case r of
             Nothing -> notFound
             Just (Left e) -> throwE e

src/Vervis/Web/Delivery.hs

@@ -83,7 +83,7 @@ import Data.Maybe.Local
 import Data.Tuple.Local
 import Database.Persist.Local
 
-import Vervis.Actor (Event)
+--import Vervis.Actor
 import Vervis.ActivityPub
 import Vervis.Data.Actor
 import Vervis.FedURI

src/Web/ActivityPub.hs

@@ -106,6 +106,7 @@ module Web.ActivityPub
     , hForwardedSignature
     , Envelope ()
     , Errand ()
+    , encodeForwardingSigHeader
     , sending
     , retrying
     , deliver
@@ -2223,7 +2224,7 @@ httpPostAP manager headers keyid sign uSender value =
 data ForwardMode u
     = SendNoForward
     | SendAllowForward LocalURI
-    | ForwardBy (ObjURI u) ByteString
+    | ForwardBy (ObjURI u) (Maybe ByteString)
 
 data Envelope u = Envelope
     { envelopeKey    :: RefURI u
@@ -2238,9 +2239,30 @@ data Errand u = Errand
     , errandHolder :: Bool
     , errandFwder  :: LocalURI
     , errandBody   :: BL.ByteString
-    , errandProof  :: ByteString
+    , errandProof  :: Maybe ByteString
     }
 
+-- | Produce a 'hForwardingSignature' header value for use when forwarding a
+-- local activity, i.e. an activity of another local actor.
+encodeForwardingSigHeader
+    :: UriMode u
+    => UTCTime
+    -> RefURI u
+    -> (ByteString -> S.Signature)
+    -> BL.ByteString
+    -> ObjURI u
+    -> Either S.HttpSigGenError ByteString
+encodeForwardingSigHeader now ruKey sign body uRecipActor =
+    let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
+        fwder = encodeUtf8 $ renderObjURI uRecipActor
+        req =
+            consHeader hActivityPubForwarder fwder $
+            consHeader hDigest digest defaultRequest
+        keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey
+    in  signRequestBytes (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now req
+    where
+    consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
+
 -- | Like 'httpPostAP', except it takes the object as a raw lazy
 -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
 httpPostAPBytes
@@ -2276,9 +2298,9 @@ httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uI
                     except $ first APPostErrorSig $
                         signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
                             consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
-                ForwardBy uSender sig ->
+                ForwardBy uSender msig ->
                     return $
-                        consHeader hForwardedSignature sig $
+                        maybe id (consHeader hForwardedSignature) msig $
                         consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
                             req''
         tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
@@ -2331,16 +2353,16 @@ forwarding
     -> Bool
     -> ObjURI u
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> Errand u
-forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig =
+forwarding lruKey sign holder (ObjURI hFwder luFwder) body msig =
     Errand
         { errandKey    = RefURI hFwder lruKey
         , errandSign   = sign
         , errandHolder = holder
         , errandFwder  = luFwder
         , errandBody   = body
-        , errandProof  = sig
+        , errandProof  = msig
         }
 
 deliver
@@ -2369,7 +2391,7 @@ forward
     -> Errand u
     -> ObjURI u
     -> m (Either APPostError (Response ()))
-forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox =
+forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body msig) uInbox =
     httpPostAPBytes
         manager
         headers
@@ -2377,7 +2399,7 @@ forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body s
         sign
         (guard holder >> Just luFwder)
         body
-        (ForwardBy (ObjURI hKey luFwder) sig)
+        (ForwardBy (ObjURI hKey luFwder) msig)
         uInbox
 
 -- | Result of GETing the keyId URI and processing the JSON document.

src/Web/Actor.hs

@@ -193,11 +193,11 @@ prepareToForward
     -> Bool
     -> StageRoute s
     -> BL.ByteString
-    -> ByteString
+    -> Maybe ByteString
     -> m (AP.Errand u)
-prepareToForward keyR sign holder fwderR body sig = do
+prepareToForward keyR sign holder fwderR body msig = do
     encodeRouteLocal <- getEncodeRouteLocal
     encodeRouteHome <- getEncodeRouteHome
     let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
         uFwder = encodeRouteHome fwderR
-    return $ AP.forwarding lruKey sign holder uFwder body sig
+    return $ AP.forwarding lruKey sign holder uFwder body msig

src/Yesod/ActivityPub.hs

@@ -163,6 +163,7 @@ deliverActivityThrow envelope mluFwd uInbox = do
         Left e -> liftIO $ throwIO e
         Right response -> return response
 
+{-
 prepareToForward
     :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
     => Route site
@@ -178,6 +179,7 @@ prepareToForward keyR sign holder fwderR body sig = do
     let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
         uFwder = encodeRouteHome fwderR
     return $ AP.forwarding lruKey sign holder uFwder body sig
+-}
 
 forwardActivity
     :: ( MonadSite m, SiteEnv m ~ site

th/models

@@ -228,11 +228,14 @@ FollowRemote
     UniqueFollowRemoteFollow follow
     UniqueFollowRemoteAccept accept
 
---FollowRequest
+FollowRequest
---    person PersonId
+    actor  ActorId
---    target FollowerSetId
+    target FollowerSetId
---
+    public Bool
---    UniqueFollowRequest person target
+    follow OutboxItemId
+
+    UniqueFollowRequest actor target
+    UniqueFollowRequestFollow follow
 
 Follow
     actor  ActorId