S2S: Switch from Grant->Accept->Enable to Invite->Accept->Grant

Giving access now starts with an Invite activity, followed by Accept from the
Invite's recipient. Finally, the resource sends a Grant, which is the actual
OCap.

migrations/466_2022-09-04_collab_topic_repo.model

@@ -0,0 +1,15 @@
+Repo
+
+Collab
+
+CollabTopicLocal
+    collab CollabId
+
+    UniqueCollabTopicLocal collab
+
+CollabTopicLocalRepo
+    collab CollabTopicLocalId
+    collabNew CollabId
+    repo   RepoId
+
+    UniqueCollabTopicLocalRepo collab

migrations/467_2022-09-04_collab_topic_deck.model

@@ -0,0 +1,15 @@
+Deck
+
+Collab
+
+CollabTopicLocal
+    collab CollabId
+
+    UniqueCollabTopicLocal collab
+
+CollabTopicLocalDeck
+    collab CollabTopicLocalId
+    collabNew CollabId
+    deck   DeckId
+
+    UniqueCollabTopicLocalDeck collab

migrations/468_2022-09-04_collab_topic_loom.model

@@ -0,0 +1,15 @@
+Loom
+
+Collab
+
+CollabTopicLocal
+    collab CollabId
+
+    UniqueCollabTopicLocal collab
+
+CollabTopicLocalLoom
+    collab CollabTopicLocalId
+    collabNew CollabId
+    loom   LoomId
+
+    UniqueCollabTopicLocalLoom collab

migrations/486_2022-09-04_collab_enable.model

@@ -0,0 +1,16 @@
+OutboxItem
+
+Collab
+
+CollabTopicLocal
+    collab CollabId
+
+    UniqueCollabTopicLocal collab
+
+CollabEnable
+    collab CollabTopicLocalId
+    collabNew CollabId
+    grant  OutboxItemId
+
+    UniqueCollabTopicLocalAcceptCollab collab
+    UniqueCollabTopicLocalAcceptAccept grant

src/Control/Monad/Trans/Except/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,10 +16,12 @@
 module Control.Monad.Trans.Except.Local
     ( fromMaybeE
     , verifyNothingE
+    , nameExceptT
     )
 where
 
 import Control.Monad.Trans.Except
+import Data.Text (Text)
 
 fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
 fromMaybeE Nothing  t = throwE t
@@ -28,3 +30,6 @@ fromMaybeE (Just x) _ = return x
 verifyNothingE :: Monad m => Maybe a -> e -> ExceptT e m ()
 verifyNothingE Nothing  _ = return ()
 verifyNothingE (Just _) e = throwE e
+
+nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a
+nameExceptT title = withExceptT $ \ e -> title <> ": " <> e

src/Vervis/API.hs

@@ -24,7 +24,7 @@ module Vervis.API
     , createNoteC
     , createTicketTrackerC
     , followC
-    , grantC
+    , inviteC
     , offerTicketC
     , offerDepC
     , resolveC
@@ -118,6 +118,7 @@ import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.Cloth
 import Vervis.Darcs
+import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Delivery
 import Vervis.Discussion
@@ -169,7 +170,7 @@ acceptC
     -> Audience URIMode
     -> Accept URIMode
     -> ExceptT Text Handler OutboxItemId
-acceptC (Entity pidUser personUser) senderActor summary audience accept = do
+acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept = do
 
     -- Check input
     acceptee <- parseAccept accept
@@ -180,71 +181,70 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
         return recips
 
     now <- liftIO getCurrentTime
-    senderHash <- encodeKeyHashid pidUser
+    senderHash <- encodeKeyHashid senderPersonID
 
-    (obiidAccept, deliverHttpAccept, deliverHttpTopicAccept) <- runDBExcept $ do
+    (obiidAccept, deliverHttpAccept, deliverHttpGrant) <- runDBExcept $ do
 
-        -- Find a Collab record for the accepted activity
+        -- Find the accepted activity in our DB
         accepteeDB <- do
             a <- getActivity acceptee
             fromMaybeE a "Can't find acceptee in DB"
-        (collabID, collabSender) <-
+
+        -- See if the accepted activity is an Invite to a local resource
+        maybeCollab <-
+        --(collabID, collabSender) <-
             case accepteeDB of
-                Left (actor, itemID) -> do
+                Left (actorByKey, actorEntity, itemID) -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabSenderLocalActivity itemID
+                        lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID
-                    (,Left actor) . collabSenderLocalCollab <$>
+                    return $
-                        fromMaybeE maybeSender "No Collab for this local activity"
+                        (,Left (actorByKey, actorEntity)) . collabFulfillsInviteLocalCollab <$> maybeSender
                 Right remoteActivityID -> do
                     maybeSender <-
-                        lift $ getValBy $ UniqueCollabSenderRemoteActivity remoteActivityID
+                        lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
-                    CollabSenderRemote collab actorID _ <-
+                    for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do
-                        fromMaybeE maybeSender "No Collab for this remote activity"
+                        actor <- lift $ getJust actorID
-                    actor <- lift $ getJust actorID
+                        lift $
-                    lift $
+                            (collab,) . Right . (,remoteActorFollowers actor) <$>
-                        (collab,) . Right . (,remoteActorFollowers actor) <$>
+                                getRemoteActorURI actor
-                            getRemoteActorURI' actor
 
-        -- Verify that Accept sender is the Collab recipient
+        maybeCollabMore <- for maybeCollab $ \ (collabID, collabSender) -> do
-        recip <-
-            lift $
-            requireEitherAlt
-                (getBy $ UniqueCollabRecipLocal collabID)
-                (getBy $ UniqueCollabRecipRemote collabID)
-                "Found Collab with no recip"
-                "Found Collab with multiple recips"
-        recipID <-
-            case recip of
-                Left (Entity crlid crl)
-                    | collabRecipLocalPerson crl == pidUser -> return crlid
-                _ -> throwE "Accepting a Collab whose recipient is someone else"
 
-        -- Verify the Collab isn't already validated
+            -- Verify that Accept sender is the Collab recipient
-        topicActor <- lift $ getCollabTopic collabID
+            recip <-
-        case topicActor of
+                lift $
-            Left (localID, _) -> do
+                requireEitherAlt
-                maybeValid <- lift $ getBy $ UniqueCollabTopicLocalAcceptCollab localID
+                    (getBy $ UniqueCollabRecipLocal collabID)
-                verifyNothingE maybeValid "Collab already Accepted by the local topic"
+                    (getBy $ UniqueCollabRecipRemote collabID)
-            Right (remoteID, _) -> do
+                    "Found Collab with no recip"
-                maybeValid <- lift $ getBy $ UniqueCollabTopicRemoteAcceptCollab remoteID
+                    "Found Collab with multiple recips"
-                verifyNothingE maybeValid "Collab already Accepted by the remote topic"
+            recipID <-
+                case recip of
+                    Left (Entity crlid crl)
+                        | collabRecipLocalPerson crl == senderPersonID -> return crlid
+                    _ -> throwE "Accepting an Invite whose recipient is someone else"
 
-        -- Verify that Grant sender and resource are addressed by the Accept
+            -- Verify the Collab isn't already validated
-        bitraverse_
+            maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
-            (verifyResourceAddressed localRecips . snd)
+            verifyNothingE maybeEnabled "Collab already enabled by the local topic"
-            (verifyRemoteAddressed remoteRecips . snd)
+
-            topicActor
+            -- Verify that Grant sender and resource are addressed by the Accept
-        bitraverse_
+            topic <- lift $ getCollabTopic collabID
-            (verifySenderAddressed localRecips)
+            verifyResourceAddressed localRecips topic
-            (verifyRemoteAddressed remoteRecips . fst)
+            bitraverse_
-            collabSender
+                (verifySenderAddressed localRecips . fst)
+                (verifyRemoteAddressed remoteRecips . fst)
+                collabSender
+
+            return (collabID, recipID, topic, collabSender)
 
         -- Record the Accept on the Collab
         acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
+        for_ maybeCollabMore $ \ (_, recipID, _, _) -> do
-        unless (isNothing maybeAccept) $ do
+            maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
-            lift $ delete acceptID
+            unless (isNothing maybeAccept) $ do
-            throwE "This Collab already has an Accept by recip"
+                lift $ delete acceptID
+                throwE "This Collab already has an Accept by recip"
 
         -- Insert the Accept activity to author's outbox
         docAccept <- lift $ insertAcceptToOutbox senderHash now blinded acceptID
@@ -252,93 +252,77 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
         -- Deliver the Accept activity to local recipients, and schedule
         -- delivery for unavailable remote recipients
         remoteRecipsHttpAccept <- do
-            topicHash <- bitraverse (hashGrantResource . snd) (pure . snd) topicActor
+            let maybeTopicActor = (\ (_, _, t, _) -> t) <$> maybeCollabMore
+                maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore
+            maybeTopicHash <- traverse hashGrantResource maybeTopicActor
+            maybeSenderHash <-
+                case maybeCollabSender of
+                    Just (Left (actor, _)) -> Just <$> hashLocalActor actor
+                    _ -> pure Nothing
             let sieveActors = catMaybes
-                    [ case topicHash of
+                    [ grantResourceLocalActor <$> maybeTopicHash
-                        Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+                    , maybeSenderHash
-                        Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
-                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
-                        Right _                    -> Nothing
-                    , case collabSender of
-                        Left actor -> Just actor
-                        Right _    -> Nothing
                     ]
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
-                    , case topicHash of
+                    , localActorFollowers . grantResourceLocalActor <$> maybeTopicHash
-                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+                    , localActorFollowers <$> maybeSenderHash
-                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
-                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
-                        Right _                    -> Nothing
-                    , case collabSender of
-                        Left actor -> Just $ localActorFollowers actor
-                        Right _    -> Nothing
                     ]
                 sieve = makeRecipientSet sieveActors sieveStages
             moreRemoteRecips <-
-                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) acceptID $
+                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) acceptID $
                     localRecipSieve sieve False localRecips
             checkFederation moreRemoteRecips
             lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips
 
-        -- If resource is local, verify it has received the Accept
+        -- If resource is local, approve the Collab and deliver a Grant
-        topicActorLocal <-
+        deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, resource, sender) -> do
-            case topicActor of
+
-                Left (localID, resource) ->
+            -- If resource is local, verify it has received the Accept
-                    Just . (localID,) <$> getGrantResource resource "getGrantResource"
+            resourceByEntity <- getGrantResource resource "getGrantResource"
-                Right _ -> pure Nothing
+            let resourceActorID = grantResourceActor resourceByEntity
-        for_ topicActorLocal $ \ (_, resource) -> do
-            let resourceActorID = grantResourceActor resource
             verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept"
 
-        -- If Collab sender is local, verify it has received the Accept
+            -- If Collab sender is local, verify it has received the Accept
-        case collabSender of
+            case sender of
-            Left actorHash -> do
+                Left (_, (Entity actorID _)) ->
-                actor <- unhashLocalActorE actorHash "Can't unhash collab sender"
+                    verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept"
-                actorID <- do
+                Right _ -> pure ()
-                    maybeID <- lift $ getLocalActorID actor
-                    fromMaybeE maybeID "Suddenly can't find collab sender in DB"
-                verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept"
-            Right _ -> pure ()
-
-        -- If resource is local, approve the Collab and deliver an Accept
-        -- We'll refer to the resource's Accept as the "Enable" activity
-        deliverHttpEnable <- for topicActorLocal $ \ (topicLocalID, resource) -> do
 
             -- Approve the Collab in the DB
             resourceOutbox <-
-                lift $ actorOutbox <$> getJust (grantResourceActor resource)
+                lift $ actorOutbox <$> getJust resourceActorID
-            enableID <- lift $ insertEmptyOutboxItem resourceOutbox now
+            grantID <- lift $ insertEmptyOutboxItem resourceOutbox now
-            lift $ insert_ $ CollabTopicLocalAccept topicLocalID enableID
+            lift $ insert_ $ CollabEnable collabID grantID
 
-            -- Insert the Enable to resource's outbox
+            -- Insert the Grant to resource's outbox
-            (docEnable, localRecipsEnable, remoteRecipsEnable, fwdHostsEnable) <-
+            (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
-                lift $ insertEnableToOutbox senderHash collabSender resource enableID
+                lift $ insertGrantToOutbox senderHash sender resource grantID
 
-            -- Deliver the Enable to local recipients, and schedule delivery
+            -- Deliver the Grant to local recipients, and schedule delivery
             -- for unavailable remote recipients
-            remoteRecipsHttpEnable <- do
+            remoteRecipsHttpGrant <- do
                 moreRemoteRecips <- do
-                    resourceHash <- hashGrantResource $ bmap entityKey resource
+                    resourceHash <- hashGrantResource resource
-                    lift $ deliverLocal' True (grantResourceLocalActor resourceHash) (grantResourceActor resource) enableID localRecipsEnable
+                    lift $ deliverLocal' True (grantResourceLocalActor resourceHash) resourceActorID grantID localRecipsGrant
                 checkFederation moreRemoteRecips
-                lift $ deliverRemoteDB'' fwdHostsEnable enableID remoteRecipsEnable moreRemoteRecips
+                lift $ deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant moreRemoteRecips
 
             -- Return instructions for HTTP delivery to remote recipients
-            return $ deliverRemoteHttp' fwdHostsEnable enableID docEnable remoteRecipsHttpEnable
+            return $ deliverRemoteHttp' fwdHostsGrant grantID docGrant remoteRecipsHttpGrant
 
         -- Return instructions for HTTP delivery to remote recipients
         return
             ( acceptID
             , deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept
-            , deliverHttpEnable
+            , deliverHttpGrant
             )
 
-    -- Launch asynchronous HTTP delivery of the Grant activity
+    -- Launch asynchronous HTTP delivery of Accept and Grant
     lift $ do
         forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept
-        for_ deliverHttpTopicAccept $
+        for_ deliverHttpGrant $
-            forkWorker "acceptC: async HTTP Topic Accept delivery"
+            forkWorker "acceptC: async HTTP Grant delivery"
 
     return obiidAccept
 
@@ -346,11 +330,10 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
 
     parseAccept (Accept object mresult) = do
         verifyNothingE mresult "Accept must not contain 'result'"
-        parseActivityURI "Accept object" object
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            nameExceptT "Accept object" (parseActivityURI object)
 
-    getRemoteActorURI = getRemoteActorURI' <=< getJust
+    getRemoteActorURI actor = do
-
-    getRemoteActorURI' actor = do
         object <- getJust $ remoteActorIdent actor
         inztance <- getJust $ remoteObjectInstance object
         return $
@@ -359,37 +342,23 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
                 (remoteObjectIdent object)
 
     getCollabTopic collabID = do
-        maybeLocal <- do
+        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-            maybeLocalID <- getKeyBy $ UniqueCollabTopicLocal collabID
+        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-            for maybeLocalID $ \ localID -> do
+        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-                resourceID <- do
+        return $
-                    maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo localID
+            case (maybeRepo, maybeDeck, maybeLoom) of
-                    maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck localID
+                (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-                    maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom localID
+                (Just r, Nothing, Nothing) ->
-                    return $
+                    GrantResourceRepo $ collabTopicRepoRepo r
-                        case (maybeRepo, maybeDeck, maybeLoom) of
+                (Nothing, Just d, Nothing) ->
-                            (Nothing, Nothing, Nothing) -> error "Found Collab with no specific local topic"
+                    GrantResourceDeck $ collabTopicDeckDeck d
-                            (Just r, Nothing, Nothing) ->
+                (Nothing, Nothing, Just l) ->
-                                GrantResourceRepo $ collabTopicLocalRepoRepo r
+                    GrantResourceLoom $ collabTopicLoomLoom l
-                            (Nothing, Just d, Nothing) ->
+                _ -> error "Found Collab with multiple topics"
-                                GrantResourceDeck $ collabTopicLocalDeckDeck d
-                            (Nothing, Nothing, Just l) ->
-                                GrantResourceLoom $ collabTopicLocalLoomLoom l
-                            _ -> error "Found Collab with multiple local topics"
-                return (localID, resourceID)
-        maybeRemote <- do
-            mr <- getBy $ UniqueCollabTopicRemote collabID
-            for mr $ \ (Entity remoteID remote) -> do
-                u <- getRemoteActorURI $ collabTopicRemoteActor remote
-                return (remoteID, u)
-        requireEitherM
-            maybeLocal
-            maybeRemote
-            "Found Collab without topic"
-            "Found Collab with both local and remote topics"
 
     verifySenderAddressed localRecips actor = do
-        unless (actorIsAddressed localRecips actor) $
+        actorByHash <- hashLocalActor actor
+        unless (actorIsAddressed localRecips actorByHash) $
             throwE "Collab sender not addressed"
 
     insertAcceptToOutbox senderHash now blinded acceptID = do
@@ -415,22 +384,29 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
     grantResourceActor (GrantResourceDeck (Entity _ d)) = deckActor d
     grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l
 
-    grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
+    insertGrantToOutbox
-    grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
+        :: KeyHashid Person
-    grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
+        -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI)
-    grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
+        -> GrantResourceBy Key
-
+        -> OutboxItemId
-    insertEnableToOutbox recipHash sender topic enableID = do
+        -> ReaderT SqlBackend Handler
+            ( Doc Activity URIMode
+            , RecipientRoutes
+            , [(Host, NonEmpty LocalURI)]
+            , [Host]
+            )
+    insertGrantToOutbox recipHash sender topic grantID = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
         hLocal <- asksSite siteInstanceHost
 
         topicHash <-
-            grantResourceLocalActor <$> hashGrantResource (bmap entityKey topic)
+            grantResourceLocalActor <$> hashGrantResource topic
-        enableHash <- encodeKeyHashid enableID
+        grantHash <- encodeKeyHashid grantID
+        senderHash <- bitraverse (hashLocalActor . fst) pure sender
 
         let audSender =
-                case sender of
+                case senderHash of
                     Left actor -> AudLocal [actor] [localActorFollowers actor]
                     Right (ObjURI h lu, followers) ->
                         AudRemote h [lu] (maybeToList followers)
@@ -444,19 +420,20 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
 
             recips = map encodeRouteHome audLocal ++ audRemote
             doc = Doc hLocal Activity
-                { activityId         = Just $ encodeRouteLocal $ outboxItemRoute topicHash enableHash
+                { activityId         = Just $ encodeRouteLocal $ activityRoute topicHash grantHash
                 , activityActor      = encodeRouteLocal $ renderLocalActor topicHash
                 , activityCapability = Nothing
                 , activitySummary    = Nothing
                 , activityAudience   = Audience recips [] [] [] [] []
                 , activityFulfills   = []
-                , activitySpecific   = AcceptActivity Accept
+                , activitySpecific   = GrantActivity Grant
-                    { acceptObject   = acceptObject accept
+                    { grantObject  = Left RoleAdmin
-                    , acceptResult   = Nothing
+                    , grantContext = encodeRouteHome $ renderLocalActor topicHash
+                    , grantTarget  = encodeRouteHome $ PersonR recipHash
                     }
                 }
 
-        update enableID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
 
 addBundleC
@@ -1530,10 +1507,8 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr
 
     insertCollab did obiidGrant = do
         cid <- insert Collab
-        ctlid <- insert $ CollabTopicLocal cid
+        insert_ $ CollabTopicDeck cid did
-        insert_ $ CollabTopicLocalDeck ctlid did
+        insert_ $ CollabEnable cid obiidGrant
-        insert_ $ CollabTopicLocalAccept ctlid obiidGrant
-        insert_ $ CollabSenderLocal cid obiidGrant
         insert_ $ CollabRecipLocal cid pidUser
         insert_ $ CollabFulfillsLocalTopicCreation cid
 
@@ -1808,21 +1783,21 @@ data Result
     | ResultNotActor
     deriving Show
 
-grantC
+inviteC
     :: Entity Person
     -> Actor
     -> Maybe FedURI
     -> Maybe TextHtml
     -> Audience URIMode
-    -> Grant URIMode
+    -> Invite URIMode
     -> ExceptT Text Handler OutboxItemId
-grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
+inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience invite = do
 
     -- Check input
-    (resource, recipient) <- parseGrant (Just pidUser) grant
+    (resource, recipient) <- parseInvite (Just senderPersonID) invite
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
-        recips <- fromMaybeE mrecips "Grant with no recipients"
+        recips <- fromMaybeE mrecips "Invite with no recipients"
         checkFederation $ paudRemoteActors recips
         return recips
 
@@ -1830,7 +1805,7 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
     --   * Outbox item URI of a local actor, i.e. a local activity
     --   * A remote URI
     uCap <- fromMaybeE muCap "No capability provided"
-    capID <- parseActivityURI "Grant capability" uCap
+    capID <- nameExceptT "Invite capability" $ parseActivityURI uCap
 
     -- 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.
@@ -1870,7 +1845,7 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
             )
             recipient
 
-    -- Verify that resource and recipient are addressed by the Grant
+    -- Verify that resource and recipient are addressed by the Invite
     bitraverse_
         (verifyResourceAddressed localRecips . bmap entityKey)
         (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
@@ -1881,28 +1856,34 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
         recipientDB
 
     now <- liftIO getCurrentTime
-    senderHash <- encodeKeyHashid pidUser
+    senderHash <- encodeKeyHashid senderPersonID
 
-    (obiidGrant, deliverHttpGrant) <- runDBExcept $ do
+    (obiidInvite, deliverHttpInvite) <- runDBExcept $ do
 
         -- If resource is local, verify the specified capability gives relevant
-        -- access. If resource is remote, check the specified capability as
+        -- access to it.
-        -- much as we can, letting the remote resource say the final word.
+        case resourceDB of
-        bitraverse_
+            Left r -> do
-            (verifyCapability capID pidUser . bmap entityKey)
+                capability <-
-            (verifyCapabilityRemote capID pidUser . (\ (o, _, _) -> o))
+                    case capID of
-            resourceDB
+                        Left (actor, _, item) -> return (actor, item)
+                        Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic"
+                verifyCapability capability senderPersonID $ bmap entityKey r
+            Right _ -> pure ()
 
         -- Insert new Collab to DB
-        grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        lift $ insertCollab resourceDB recipientDB grantID
+        case resourceDB of
+            Left localResource ->
+                lift $ insertCollab localResource recipientDB inviteID
+            Right _ -> pure ()
 
         -- Insert the Grant activity to author's outbox
-        docGrant <- lift $ insertGrantToOutbox senderHash now uCap blinded grantID
+        docInvite <- lift $ insertInviteToOutbox senderHash now uCap blinded inviteID
 
-        -- Deliver the Grant activity to local recipients, and schedule
+        -- Deliver the Invite activity to local recipients, and schedule
         -- delivery for unavailable remote recipients
-        remoteRecipsHttpGrant <- do
+        remoteRecipsHttpInvite <- do
             resourceHash <- bitraverse hashGrantResource pure resource
             recipientHash <- bitraverse hashGrantRecip pure recipient
             let sieveActors = catMaybes
@@ -1928,10 +1909,10 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                     ]
                 sieve = makeRecipientSet sieveActors sieveStages
             moreRemoteRecips <-
-                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $
+                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) inviteID $
                     localRecipSieve sieve False localRecips
             checkFederation moreRemoteRecips
-            lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips
+            lift $ deliverRemoteDB'' fwdHosts inviteID remoteRecips moreRemoteRecips
 
         -- If resource is local, verify it has received the Grant
         case resourceDB of
@@ -1941,26 +1922,26 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                             GrantResourceRepo (Entity _ r) -> repoActor r
                             GrantResourceDeck (Entity _ d) -> deckActor d
                             GrantResourceLoom (Entity _ l) -> loomActor l
-                verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant"
+                verifyActorHasItem resourceActorID inviteID "Local topic didn't receive the Invite"
             Right _ -> pure ()
 
-        -- If recipient is local, verify it has received the grant
+        -- If recipient is local, verify it has received the invite
         case recipientDB of
             Left (GrantRecipPerson (Entity _ p)) ->
-                verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant"
+                verifyActorHasItem (personActor p) inviteID "Local recipient didn't receive the Invite"
             Right _ -> pure ()
 
         -- Return instructions for HTTP delivery to remote recipients
         return
-            ( grantID
+            ( inviteID
-            , deliverRemoteHttp' fwdHosts grantID docGrant remoteRecipsHttpGrant
+            , deliverRemoteHttp' fwdHosts inviteID docInvite remoteRecipsHttpInvite
             )
 
     -- Launch asynchronous HTTP delivery of the Grant activity
     lift $ do
-        forkWorker "grantC: async HTTP Grant delivery" deliverHttpGrant
+        forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
 
-    return obiidGrant
+    return obiidInvite
 
     where
 
@@ -2017,48 +1998,43 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
             lus <- lookup h remoteRecips
             guard $ lu `elem` lus
 
-    insertCollab resource recipient grantID = do
+    insertCollab resource recipient inviteID = do
         collabID <- insert Collab
         case resource of
-            Left local -> do
+            GrantResourceRepo (Entity repoID _) ->
-                topicID <- insert $ CollabTopicLocal collabID
+                insert_ $ CollabTopicRepo collabID repoID
-                case local of
+            GrantResourceDeck (Entity deckID _) ->
-                    GrantResourceRepo (Entity repoID _) ->
+                insert_ $ CollabTopicDeck collabID deckID
-                        insert_ $ CollabTopicLocalRepo topicID repoID
+            GrantResourceLoom (Entity loomID _) ->
-                    GrantResourceDeck (Entity deckID _) ->
+                insert_ $ CollabTopicLoom collabID loomID
-                        insert_ $ CollabTopicLocalDeck topicID deckID
+        insert_ $ CollabFulfillsInviteLocal collabID inviteID
-                    GrantResourceLoom (Entity loomID _) ->
-                        insert_ $ CollabTopicLocalLoom topicID loomID
-            Right (remoteID, actorID, _) ->
-                insert_ $ CollabTopicRemote collabID remoteID actorID Nothing
-        insert_ $ CollabSenderLocal collabID grantID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
                 insert_ $ CollabRecipLocal collabID personID
             Right (remoteActorID, _) ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
-    hashGrantRecip (GrantRecipPerson k) =
+    insertInviteToOutbox senderHash now uCap blinded inviteID = do
-        GrantRecipPerson <$> encodeKeyHashid k
-
-    insertGrantToOutbox senderHash now uCap blinded grantID = do
         encodeRouteLocal <- getEncodeRouteLocal
         hLocal <- asksSite siteInstanceHost
-        grantHash <- encodeKeyHashid grantID
+        inviteHash <- encodeKeyHashid inviteID
         let doc = Doc hLocal Activity
                 { activityId         =
                     Just $ encodeRouteLocal $
-                        PersonOutboxItemR senderHash grantHash
+                        PersonOutboxItemR senderHash inviteHash
                 , activityActor      = encodeRouteLocal $ PersonR senderHash
                 , activityCapability = Just uCap
                 , activitySummary    = summary
                 , activityAudience   = blinded
                 , activityFulfills   = []
-                , activitySpecific   = GrantActivity grant
+                , activitySpecific   = InviteActivity invite
                 }
-        update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        update inviteID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return doc
 
+    hashGrantRecip (GrantRecipPerson k) =
+        GrantRecipPerson <$> encodeKeyHashid k
+
 offerTicketC
     :: Entity Person
     -> Maybe TextHtml

src/Vervis/Access.hs

@@ -70,8 +70,9 @@ module Vervis.Access
     , hashGrantResource
     , getGrantResource
 
+    , grantResourceLocalActor
+
     , verifyCapability
-    , verifyCapabilityRemote
     )
 where
 
@@ -103,6 +104,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Role
+import Vervis.Persist.Actor
 import Vervis.Query
 import Vervis.Recipient
 
@@ -112,6 +114,16 @@ data ObjectAccessStatus =
 
 data PersonRole = Developer | User | Guest | RoleID RoleId
 
+{-
+data RepoAuthorization
+    = RepoAuthorizationLocal PersonId
+    | RepoAuthorizationRemote RepoRemoteCollabId
+
+data ProjectAuthorization
+    = ProjectAuthorizationLocal PersonId
+    | ProjectAuthorizationRemote ProjectRemoteCollabId
+-}
+
 roleHasAccess
     :: MonadIO m
     => PersonRole
@@ -167,15 +179,14 @@ checkRepoAccess' mpid op repoID = do
     where
     asCollab rid pid = do
         fmap (const Developer) . listToMaybe <$> do
-            E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do
+            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
-                E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab
+                E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
-                E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab
+                E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
-                E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId
                 E.where_ $
-                    repo E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&.
+                    topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
-                return $ topic E.^. CollabTopicLocalCollab
+                return $ topic E.^. CollabTopicRepoCollab
     asUser = fmap RoleID . repoCollabUser
     asAnon = fmap RoleID . repoCollabAnon
 
@@ -202,15 +213,14 @@ checkRepoAccess mpid op repoHash = do
     where
     asCollab rid pid = do
         fmap (const Developer) . listToMaybe <$> do
-            E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do
+            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
-                E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab
+                E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
-                E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab
+                E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
-                E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId
                 E.where_ $
-                    repo E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&.
+                    topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
-                return $ topic E.^. CollabTopicLocalCollab
+                return $ topic E.^. CollabTopicRepoCollab
     asUser = fmap RoleID . repoCollabUser
     asAnon = fmap RoleID . repoCollabAnon
 
@@ -238,15 +248,14 @@ checkProjectAccess mpid op deckHash = do
     where
     asCollab jid pid = do
         fmap (const Developer) . listToMaybe <$> do
-            E.select $ E.from $ \ (deck `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do
+            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
-                E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab
+                E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
-                E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab
+                E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab
-                E.on $ deck E.^. CollabTopicLocalDeckCollab E.==. topic E.^. CollabTopicLocalId
                 E.where_ $
-                    deck E.^. CollabTopicLocalDeckDeck E.==. E.val jid E.&&.
+                    topic E.^. CollabTopicDeckDeck E.==. E.val jid E.&&.
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
-                return $ topic E.^. CollabTopicLocalCollab
+                return $ topic E.^. CollabTopicDeckCollab
     asUser = fmap RoleID . deckCollabUser
     asAnon = fmap RoleID . deckCollabAnon
 
@@ -288,34 +297,33 @@ getGrantResource (GrantResourceDeck k) e =
 getGrantResource (GrantResourceLoom k) e =
     GrantResourceLoom <$> getEntityE k e
 
+grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
+grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
+grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
+grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
+
 verifyCapability
-    :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
+    :: (LocalActorBy Key, OutboxItemId)
     -> PersonId
     -> GrantResourceBy Key
     -> ExceptT Text (ReaderT SqlBackend Handler) ()
-verifyCapability capability personID resource = do
+verifyCapability (capActor, capItem) personID resource = do
+
     -- Find the activity itself by URI in the DB
-    grant <- do
+    nameExceptT "Capability activity not found" $
-        mact <- getActivity capability
+        verifyLocalActivityExistsInDB capActor capItem
-        fromMaybeE mact "Capability activity not known to me"
 
     -- Find the Collab record for that activity
-    cid <-
+    collabID <- do
-        case grant of
+        maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
-            Left (_actor, obiid) -> do
+        collabEnableCollab <$>
-                mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
+            fromMaybeE maybeEnable "No CollabEnable for this activity"
-                collabSenderLocalCollab <$>
-                    fromMaybeE mcsl "Capability is a local activity but no matching capability"
-            Right ractid -> do
-                mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
-                collabSenderRemoteCollab <$>
-                    fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
 
     -- Find the recipient of that Collab
     recipID <- do
-        mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
+        mcrl <- lift $ getValBy $ UniqueCollabRecipLocal collabID
         crl <- fromMaybeE mcrl "No local recip for capability"
-        mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
+        mcrr <- lift $ getBy $ UniqueCollabRecipRemote collabID
         for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
         return $ collabRecipLocalPerson crl
 
@@ -323,98 +331,29 @@ verifyCapability capability personID resource = do
     unless (recipID == personID) $
         throwE "Collab recipient is some other Person"
 
-    -- Verify the topic isn't remote
-    maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid
-    verifyNothingE maybeRemote "Collab is for some other, remote topic"
-
     -- Find the local topic, on which this Collab gives access
-    (topic, topicLocalID) <- lift $ do
+    topic <- lift $ do
-        localID <- do
+        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-            maybeLocal <- getKeyBy $ UniqueCollabTopicLocal cid
+        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-            case maybeLocal of
+        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-                Nothing -> error "Collab without topic"
+        case (maybeRepo, maybeDeck, maybeLoom) of
-                Just l -> return l
+            (Nothing, Nothing, Nothing) -> error "Collab without topic"
-        maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo localID
+            (Just r, Nothing, Nothing) ->
-        maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck localID
+                return $ GrantResourceRepo $ collabTopicRepoRepo r
-        maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom localID
+            (Nothing, Just d, Nothing) ->
-        (,localID) <$>
+                return $ GrantResourceDeck $ collabTopicDeckDeck d
-            case (maybeRepo, maybeDeck, maybeLoom) of
+            (Nothing, Nothing, Just l) ->
-                (Nothing, Nothing, Nothing) -> error "Collab without local topic"
+                return $ GrantResourceLoom $ collabTopicLoomLoom l
-                (Just r, Nothing, Nothing) ->
+            _ -> error "Collab with multiple topics"
-                    return $ GrantResourceRepo $ collabTopicLocalRepoRepo r
+
-                (Nothing, Just d, Nothing) ->
+    -- Verify that topic is indeed the sender of the Grant
-                    return $ GrantResourceDeck $ collabTopicLocalDeckDeck d
+    unless (grantResourceLocalActor topic == capActor) $
-                (Nothing, Nothing, Just l) ->
+        error "Grant sender isn't the topic"
-                    return $ GrantResourceLoom $ collabTopicLocalLoomLoom l
-                _ -> error "Collab with multiple topics"
 
     -- Verify the topic matches the resource specified
     unless (topic == resource) $
         throwE "Capability topic is some other local resource"
 
-    -- Verify that the resource has accepted the grant, making it valid
-    maybeAccept <- lift $ getBy $ UniqueCollabTopicLocalAcceptCollab topicLocalID
-    _ <- fromMaybeE maybeAccept "Collab not approved by the resource"
-
-    -- 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 ()
-
-verifyCapabilityRemote
-    :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
-    -> PersonId
-    -> RemoteObjectId
-    -> ExceptT Text (ReaderT SqlBackend Handler) ()
-verifyCapabilityRemote capability personID resourceID = do
-    -- Find the activity itself by URI in the DB
-    grant <- do
-        mact <- getActivity capability
-        fromMaybeE mact "Capability activity not known to me"
-
-    -- Find the Collab record for that activity
-    cid <-
-        case grant of
-            Left (_actor, obiid) -> do
-                mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
-                collabSenderLocalCollab <$>
-                    fromMaybeE mcsl "Capability is a local activity but no matching capability"
-            Right ractid -> do
-                mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
-                collabSenderRemoteCollab <$>
-                    fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
-
-    -- Find the recipient of that Collab
-    recipID <- do
-        mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
-        crl <- fromMaybeE mcrl "No local recip for capability"
-        mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
-        for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
-        return $ collabRecipLocalPerson crl
-
-    -- Verify the recipient is the expected one
-    unless (recipID == personID) $
-        throwE "Collab recipient is some other Person"
-
-    -- Verify the topic isn't local
-    maybeLocalTopic <- lift $ getBy $ UniqueCollabTopicLocal cid
-    verifyNothingE maybeLocalTopic "Collab is for some other, local topic"
-
-    -- Find the remote topic, on which this Collab gives access
-    (topicRemoteID, topicObjectID) <- do
-        maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid
-        case maybeRemote of
-            Nothing -> error "Collab without topic"
-            Just (Entity remoteID remote) ->
-                return (remoteID, collabTopicRemoteTopic remote)
-
-    -- Verify the topic matches the resource specified
-    unless (topicObjectID == resourceID) $
-        throwE "Capability topic is some other remote resource"
-
-    -- Verify that the resource has accepted the grant, making it valid
-    maybeAccept <- lift $ getBy $ UniqueCollabTopicRemoteAcceptCollab topicRemoteID
-    _ <- fromMaybeE maybeAccept "Collab not approved by the resource"
-
     -- 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 ()

src/Vervis/ActivityPub.hs

@@ -28,15 +28,10 @@ module Vervis.ActivityPub
     , insertEmptyOutboxItem
     , verifyContentTypeAP
     , verifyContentTypeAP_E
-    , parseActivity
-    , parseActivityURI
     , getActivity
     --, ActorEntity (..)
-    , getLocalActor'
-    , getLocalActor
     --, getOutboxActorEntity
     --, actorEntityPath
-    , outboxItemRoute
 
     , verifyActorHasItem
     )
@@ -272,54 +267,18 @@ verifyContentTypeAP_E = do
         "application/ld+json; \
         \profile=\"https://www.w3.org/ns/activitystreams\""
 
--- | If the given URI is remote, return as is. If the URI is local, verify that
--- it parses as an activity URI, i.e. an outbox item route, and return the
--- parsed route.
-parseActivityURI name u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
-    if hl
-        then Left <$> do
-            route <-
-                fromMaybeE
-                    (decodeRouteLocal lu)
-                    (name <> " is local but isn't a valid route")
-            (actor, outboxItemHash) <-
-                fromMaybeE
-                    (parseOutboxItemRoute route)
-                    (name <> " is a valid local route, but isn't an outbox item route")
-            outboxItemID <-
-                decodeKeyHashidE outboxItemHash (name <> ": Invalid obikhid")
-            return (actor, outboxItemID)
-        else return $ Right u
-    where
-    parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
-    parseOutboxItemRoute (GroupOutboxItemR g i)  = Just (LocalActorGroup g, i)
-    parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
-    parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
-    parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
-    parseOutboxItemRoute _                       = Nothing
-
-parseActivity = parseActivityURI "Activity URI"
-
 getActivity (Left (actor, obiid)) = Just . Left <$> do
-    obid <- actorOutbox <$> getActor' actor
+    actorID <- do
+        maybeActorID <- lift $ getLocalActorID actor
+        fromMaybeE maybeActorID "No such actor entity in DB"
+    actorDB <- lift $ getJust actorID
+    let obid = actorOutbox actorDB
     obi <- do
         mobi <- lift $ get obiid
         fromMaybeE mobi "No such obiid"
     unless (outboxItemOutbox obi == obid) $
         throwE "Actor/obiid mismatch"
-    return (actor, obiid)
+    return (actor, Entity actorID actorDB, obiid)
-    where
-    getActor grabActor hash = do
-        key <- decodeKeyHashidE hash "No such hashid"
-        actorID <- grabActor <$> getE key "No such actor entity in DB"
-        lift $ getJust actorID
-
-    getActor' (LocalActorPerson hash) = getActor personActor hash
-    getActor' (LocalActorGroup hash)  = getActor groupActor hash
-    getActor' (LocalActorRepo hash)   = getActor repoActor hash
-    getActor' (LocalActorDeck hash)   = getActor deckActor hash
-    getActor' (LocalActorLoom hash)   = getActor loomActor hash
 
 getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do
     iid <- MaybeT $ getKeyBy $ UniqueInstance h
@@ -333,57 +292,6 @@ data ActorEntity
     | ActorRepo (Entity Repo)
 -}
 
-getLocalActor'
-    :: ( BaseBackend b ~ SqlBackend
-       , PersistUniqueRead b
-       , MonadIO m
-       )
-    => ActorId
-    -> ReaderT b m (LocalActorBy Key)
-getLocalActor' actorID = do
-    mp <- getKeyBy $ UniquePersonActor actorID
-    mg <- getKeyBy $ UniqueGroupActor actorID
-    mr <- getKeyBy $ UniqueRepoActor actorID
-    md <- getKeyBy $ UniqueDeckActor actorID
-    ml <- getKeyBy $ UniqueLoomActor actorID
-    return $
-        case (mp, mg, mr, md, ml) of
-            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
-            (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
-            (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
-            (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
-            (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
-            (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
-            _ -> error "Multi-usage of an ActorId"
-
-getLocalActor
-    :: ( BaseBackend b ~ SqlBackend
-       , PersistUniqueRead b
-       , MonadSite m
-       , YesodHashids (SiteEnv m)
-       )
-    => ActorId
-    -> ReaderT b m LocalActor
-getLocalActor actorID = do
-    mp <- getKeyBy $ UniquePersonActor actorID
-    mg <- getKeyBy $ UniqueGroupActor actorID
-    mr <- getKeyBy $ UniqueRepoActor actorID
-    md <- getKeyBy $ UniqueDeckActor actorID
-    ml <- getKeyBy $ UniqueLoomActor actorID
-    case (mp, mg, mr, md, ml) of
-        (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
-        (Just p, Nothing, Nothing, Nothing, Nothing) ->
-            LocalActorPerson <$> encodeKeyHashid p
-        (Nothing, Just g, Nothing, Nothing, Nothing) ->
-            LocalActorGroup <$> encodeKeyHashid g
-        (Nothing, Nothing, Just r, Nothing, Nothing) ->
-            LocalActorRepo <$> encodeKeyHashid r
-        (Nothing, Nothing, Nothing, Just d, Nothing) ->
-            LocalActorDeck <$> encodeKeyHashid d
-        (Nothing, Nothing, Nothing, Nothing, Just l) ->
-            LocalActorLoom <$> encodeKeyHashid l
-        _ -> error "Multi-usage of an ActorId"
-
 {-
 getOutboxActorEntity obid = do
     mp <- getBy $ UniquePersonOutbox obid
@@ -410,12 +318,6 @@ actorEntityPath (ActorRepo (Entity _ r)) =
         getJust (repoSharer r)
 -}
 
-outboxItemRoute (LocalActorPerson p) = PersonOutboxItemR p
-outboxItemRoute (LocalActorGroup g) = GroupOutboxItemR g
-outboxItemRoute (LocalActorRepo r) = RepoOutboxItemR r
-outboxItemRoute (LocalActorDeck d) = DeckOutboxItemR d
-outboxItemRoute (LocalActorLoom l) = LoomOutboxItemR l
-
 verifyActorHasItem actorID itemID errorMessage = do
     inboxID <- lift $ actorInbox <$> getJust actorID
     maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID

src/Vervis/Data/Actor.hs

@@ -15,6 +15,8 @@
 
 module Vervis.Data.Actor
     ( parseLocalActivityURI
+    , parseActivityURI
+    , activityRoute
     )
 where
 
@@ -22,12 +24,14 @@ import Control.Monad.Trans.Except
 import Data.Text (Text)
 
 import Network.FedURI
+import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
 
 import Control.Monad.Trans.Except.Local
 
+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
@@ -37,15 +41,13 @@ parseLocalActivityURI
     => LocalURI
     -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
 parseLocalActivityURI luAct = do
-    route <-
+    route <- fromMaybeE (decodeRouteLocal luAct) "Not a valid route"
-        fromMaybeE (decodeRouteLocal luAct) "Local activity: Not a valid route"
     (actorHash, outboxItemHash) <-
         fromMaybeE
             (parseOutboxItemRoute route)
-            "Local activity: Valid local route, but not an outbox item route"
+            "Valid local route, but not an outbox item route"
-    outboxItemID <-
+    outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
-        decodeKeyHashidE outboxItemHash "Local activity: Invalid outbox item hash"
+    actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
-    actorKey <- unhashLocalActorE actorHash "Local activity: Invalid actor hash"
     return (actorKey, actorHash, outboxItemID)
     where
     parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
@@ -54,3 +56,27 @@ parseLocalActivityURI luAct = do
     parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
     parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
     parseOutboxItemRoute _                       = Nothing
+
+-- | If the given URI is remote, return as is. If the URI is local, verify that
+-- it parses as an activity URI, i.e. an outbox item route, and return the
+-- parsed route.
+parseActivityURI
+    :: (MonadSite m, SiteEnv m ~ App)
+    => FedURI
+    -> ExceptT Text m
+        (Either
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+            FedURI
+        )
+parseActivityURI u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> parseLocalActivityURI lu
+        else pure $ Right u
+
+activityRoute :: LocalActorBy KeyHashid -> KeyHashid OutboxItem -> Route App
+activityRoute (LocalActorPerson p) = PersonOutboxItemR p
+activityRoute (LocalActorGroup g) = GroupOutboxItemR g
+activityRoute (LocalActorRepo r) = RepoOutboxItemR r
+activityRoute (LocalActorDeck d) = DeckOutboxItemR d
+activityRoute (LocalActorLoom l) = LoomOutboxItemR l

src/Vervis/Data/Collab.hs

@@ -18,6 +18,7 @@
 
 module Vervis.Data.Collab
     ( GrantRecipBy (..)
+    , parseInvite
     , parseGrant
     )
 where
@@ -60,6 +61,64 @@ unhashGrantRecip resource = do
 unhashGrantRecipE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
 
+parseInvite
+    :: Maybe PersonId
+    -> Invite URIMode
+    -> ExceptT Text Handler
+        ( Either (GrantResourceBy Key) FedURI
+        , Either (GrantRecipBy Key) FedURI
+        )
+parseInvite maybeSenderID (Invite instrument object target) = do
+    verifyRole instrument
+    (,) <$> parseTopic target
+        <*> parseRecipient object
+    where
+    verifyRole (Left RoleAdmin) = pure ()
+    verifyRole (Right _) =
+        throwE "ForgeFed Admin is the only role allowed currently"
+    parseTopic u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Invite target isn't a valid route"
+                resourceHash <-
+                    fromMaybeE
+                        (parseGrantResource route)
+                        "Invite target isn't a shared resource route"
+                unhashGrantResourceE
+                    resourceHash
+                    "Invite target contains invalid hashid"
+            else pure $ Right u
+        where
+        parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
+        parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
+        parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
+        parseGrantResource _         = Nothing
+    parseRecipient u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Invite object isn't a valid route"
+                recipHash <-
+                    fromMaybeE
+                        (parseGrantRecip route)
+                        "Invite object isn't a grant recipient route"
+                recipKey <-
+                    unhashGrantRecipE
+                        recipHash
+                        "Invite object contains invalid hashid"
+                case recipKey of
+                    GrantRecipPerson p | Just p == maybeSenderID ->
+                        throwE "Invite sender and recipient are the same Person"
+                    _ -> return recipKey
+            else pure $ Right u
+
 parseGrant
     :: Maybe PersonId
     -> Grant URIMode

src/Vervis/Handler/Cloth.hs

@@ -89,6 +89,7 @@ import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.API
 import Vervis.Cloth
+import Vervis.Data.Actor
 import Vervis.Discussion
 import Vervis.FedURI
 import Vervis.Foundation
@@ -96,6 +97,8 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.Paginate
+import Vervis.Persist.Actor
+import Vervis.Recipient
 import Vervis.Ticket
 
 getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
@@ -145,6 +148,7 @@ getClothR loomHash clothHash = do
     encodeRouteHome <- getEncodeRouteHome
     hashPerson <- getEncodeKeyHashid
     hashItem <- getEncodeKeyHashid
+    hashActor <- getHashLocalActor
     hLocal <- getsYesod siteInstanceHost
     repoHash <- encodeKeyHashid repoID
     bundleHash <- encodeKeyHashid bundleID
@@ -194,7 +198,7 @@ getClothR loomHash clothHash = do
             , AP.ticketResolved     =
                 let u (Left (actor, obiid)) =
                         encodeRouteHome $
-                            outboxItemRoute actor $ hashItem obiid
+                            activityRoute (hashActor actor) (hashItem obiid)
                     u (Right (i, ro)) =
                         ObjURI (instanceHost i) (remoteObjectIdent ro)
                 in  (,Nothing) . Just . u <$> resolve

src/Vervis/Handler/Person.hs

@@ -73,6 +73,7 @@ import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Persist.Actor
 import Vervis.Recipient
 import Vervis.Secure
 import Vervis.Settings
@@ -135,21 +136,6 @@ parseAuthenticatedLocalActivityURI author maybeActivityURI = do
         throwE "'actor' actor and 'id' actor mismatch"
     return outboxItemID
 
-verifyLocalActivityExistsInDB
-    :: MonadIO m
-    => LocalActorBy Key
-    -> OutboxItemId
-    -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyLocalActivityExistsInDB actorByKey outboxItemID = do
-    outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB"
-    itemActorID <- do
-        maybeActorID <-
-            lift $ getKeyBy $ UniqueActorOutbox outboxID
-        fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor"
-    itemActorByKey <- lift $ getLocalActor' itemActorID
-    unless (itemActorByKey == actorByKey) $
-        throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"
-
 insertActivityToInbox
     :: MonadIO m
     => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
@@ -292,8 +278,8 @@ postPersonOutboxR personHash = do
                     AP.CreateTicketTracker detail mlocal ->
                         createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
                     _ -> throwE "Unsupported Create 'object' type"
-            AP.GrantActivity grant ->
+            AP.InviteActivity invite ->
-                grantC eperson actorDB mcap summary audience grant
+                inviteC eperson actorDB mcap summary audience invite
             {-
             AddActivity (AP.Add obj target) ->
                 case obj of

src/Vervis/Handler/Ticket.hs

@@ -133,6 +133,7 @@ import Yesod.Persist.Local
 import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.API
+import Vervis.Data.Actor
 import Vervis.Discussion
 import Vervis.Federation
 import Vervis.FedURI
@@ -144,6 +145,8 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.Model.Workflow
 import Vervis.Paginate
+import Vervis.Persist.Actor
+import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Style
 import Vervis.Ticket
@@ -193,6 +196,7 @@ getTicketR deckHash ticketHash = do
     encodeRouteHome <- getEncodeRouteHome
     hashPerson <- getEncodeKeyHashid
     hashItem <- getEncodeKeyHashid
+    hashActor <- getHashLocalActor
     hLocal <- getsYesod siteInstanceHost
     let route mk = encodeRouteLocal $ mk deckHash ticketHash
         authorHost =
@@ -227,7 +231,7 @@ getTicketR deckHash ticketHash = do
             , AP.ticketResolved     =
                 let u (Left (actor, obiid)) =
                         encodeRouteHome $
-                            outboxItemRoute actor $ hashItem obiid
+                            activityRoute (hashActor actor) (hashItem obiid)
                     u (Right (i, ro)) =
                         ObjURI (instanceHost i) (remoteObjectIdent ro)
                 in  (,Nothing) . Just . u <$> resolve

src/Vervis/Migration.hs

@@ -2556,6 +2556,136 @@ changes hLocal ctx =
     , addFieldPrimRequired "InboxItem" defaultTime "received"
       -- 453
     , addEntities model_453_collab_receive
+      -- 454
+    , renameUnique "CollabSenderLocal" "UniqueCollabSenderLocal" "UniqueCollabFulfillsInviteLocal"
+      -- 455
+    , renameUnique "CollabSenderLocal" "UniqueCollabSenderLocalActivity" "UniqueCollabFulfillsInviteLocalInvite"
+      -- 456
+    , renameField "CollabSenderLocal" "activity" "invite"
+      -- 457
+    , renameUnique "CollabSenderRemote" "UniqueCollabSenderRemote" "UniqueCollabFulfillsInviteRemote"
+      -- 458
+    , renameUnique "CollabSenderRemote" "UniqueCollabSenderRemoteActivity" "UniqueCollabFulfillsInviteRemoteInvite"
+      -- 459
+    , renameField "CollabSenderRemote" "activity" "invite"
+      -- 460
+    , renameEntity "CollabSenderLocal" "CollabFulfillsInviteLocal"
+      -- 461
+    , renameEntity "CollabSenderRemote" "CollabFulfillsInviteRemote"
+      -- 462
+    , removeEntity "CollabRecipLocalReceive"
+      -- 463
+    , removeEntity "CollabTopicRemoteAccept"
+      -- 464
+    , removeEntity "CollabTopicRemote"
+      -- 465
+    , removeEntity "CollabTopicLocalReceive"
+      -- 466
+    , addFieldRefRequired''
+        "CollabTopicLocalRepo"
+        (insertEntity Collab466)
+        (Just $ \ (Entity collabTemp _) -> do
+            collabs <- selectList [] []
+            for_ collabs $ \ (Entity topicID topic) -> do
+                CollabTopicLocal466 collabID <-
+                    getJust $ collabTopicLocalRepo466Collab topic
+                update topicID [CollabTopicLocalRepo466CollabNew =. collabID]
+
+            delete collabTemp
+        )
+        "collabNew"
+        "Collab"
+      -- 467
+    , addFieldRefRequired''
+        "CollabTopicLocalDeck"
+        (insertEntity Collab467)
+        (Just $ \ (Entity collabTemp _) -> do
+            collabs <- selectList [] []
+            for_ collabs $ \ (Entity topicID topic) -> do
+                CollabTopicLocal467 collabID <-
+                    getJust $ collabTopicLocalDeck467Collab topic
+                update topicID [CollabTopicLocalDeck467CollabNew =. collabID]
+
+            delete collabTemp
+        )
+        "collabNew"
+        "Collab"
+      -- 468
+    , addFieldRefRequired''
+        "CollabTopicLocalLoom"
+        (insertEntity Collab468)
+        (Just $ \ (Entity collabTemp _) -> do
+            collabs <- selectList [] []
+            for_ collabs $ \ (Entity topicID topic) -> do
+                CollabTopicLocal468 collabID <-
+                    getJust $ collabTopicLocalLoom468Collab topic
+                update topicID [CollabTopicLocalLoom468CollabNew =. collabID]
+
+            delete collabTemp
+        )
+        "collabNew"
+        "Collab"
+      -- 469
+    , removeUnique' "CollabTopicLocalRepo" ""
+      -- 470
+    , renameEntity "CollabTopicLocalRepo" "CollabTopicRepo"
+      -- 471
+    , removeUnique' "CollabTopicLocalDeck" ""
+      -- 472
+    , renameEntity "CollabTopicLocalDeck" "CollabTopicDeck"
+      -- 473
+    , removeUnique' "CollabTopicLocalLoom" ""
+      -- 474
+    , renameEntity "CollabTopicLocalLoom" "CollabTopicLoom"
+      -- 475
+    , addUnique' "CollabTopicRepo" "" ["collabNew"]
+      -- 476
+    , addUnique' "CollabTopicDeck" "" ["collabNew"]
+      -- 477
+    , addUnique' "CollabTopicLoom" "" ["collabNew"]
+      -- 478
+    , removeField "CollabTopicRepo" "collab"
+      -- 479
+    , renameField "CollabTopicRepo" "collabNew" "collab"
+      -- 480
+    , removeField "CollabTopicDeck" "collab"
+      -- 481
+    , renameField "CollabTopicDeck" "collabNew" "collab"
+      -- 482
+    , removeField "CollabTopicLoom" "collab"
+      -- 483
+    , renameField "CollabTopicLoom" "collabNew" "collab"
+      -- 484
+    , renameEntity "CollabTopicLocalAccept" "CollabEnable"
+      -- 485
+    , renameField "CollabEnable" "accept" "grant"
+      -- 486
+    , addFieldRefRequired''
+        "CollabEnable"
+        (insertEntity Collab486)
+        (Just $ \ (Entity collabTemp _) -> do
+            collabs <- selectList [] []
+            for_ collabs $ \ (Entity topicID topic) -> do
+                CollabTopicLocal486 collabID <-
+                    getJust $ collabEnable486Collab topic
+                update topicID [CollabEnable486CollabNew =. collabID]
+
+            delete collabTemp
+        )
+        "collabNew"
+        "Collab"
+      -- 487
+    , removeUnique "CollabEnable" "UniqueCollabTopicLocalAcceptCollab"
+      -- 488
+    , addUnique' "CollabEnable" "" ["collabNew"]
+      -- 489
+    , removeField "CollabEnable" "collab"
+      -- 490
+    , renameField "CollabEnable" "collabNew" "collab"
+      -- 491
+    , renameUnique "CollabEnable" "UniqueCollabTopicLocalAcceptAccept" "UniqueCollabEnableGrant"
+      -- 492
+    , removeEntity "CollabTopicLocal"
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -650,3 +650,15 @@ model_451_collab_remote_accept = $(schema "451_2022-08-30_collab_remote_accept")
 
 model_453_collab_receive :: [Entity SqlBackend]
 model_453_collab_receive = $(schema "453_2022-09-01_collab_receive")
+
+makeEntitiesMigration "466"
+    $(modelFile "migrations/466_2022-09-04_collab_topic_repo.model")
+
+makeEntitiesMigration "467"
+    $(modelFile "migrations/467_2022-09-04_collab_topic_deck.model")
+
+makeEntitiesMigration "468"
+    $(modelFile "migrations/468_2022-09-04_collab_topic_loom.model")
+
+makeEntitiesMigration "486"
+    $(modelFile "migrations/486_2022-09-04_collab_enable.model")

src/Vervis/Persist/Actor.hs

@@ -0,0 +1,68 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Persist.Actor
+    ( getLocalActor
+    , verifyLocalActivityExistsInDB
+    )
+where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
+import Data.Text (Text)
+import Database.Persist
+import Database.Persist.Sql
+
+import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
+
+import Vervis.Model
+import Vervis.Recipient
+
+getLocalActor
+    :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
+getLocalActor actorID = do
+    mp <- getKeyBy $ UniquePersonActor actorID
+    mg <- getKeyBy $ UniqueGroupActor actorID
+    mr <- getKeyBy $ UniqueRepoActor actorID
+    md <- getKeyBy $ UniqueDeckActor actorID
+    ml <- getKeyBy $ UniqueLoomActor actorID
+    return $
+        case (mp, mg, mr, md, ml) of
+            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
+            (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
+            (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
+            (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
+            (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
+            (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
+            _ -> error "Multi-usage of an ActorId"
+
+verifyLocalActivityExistsInDB
+    :: MonadIO m
+    => LocalActorBy Key
+    -> OutboxItemId
+    -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyLocalActivityExistsInDB actorByKey outboxItemID = do
+    outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB"
+    itemActorID <- do
+        maybeActorID <-
+            lift $ getKeyBy $ UniqueActorOutbox outboxID
+        fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor"
+    itemActorByKey <- lift $ getLocalActor itemActorID
+    unless (itemActorByKey == actorByKey) $
+        throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"

src/Web/ActivityPub.hs

@@ -71,6 +71,7 @@ module Web.ActivityPub
     , Create (..)
     , Follow (..)
     , Grant (..)
+    , Invite (..)
     , OfferObject (..)
     , Offer (..)
     , Push (..)
@@ -1507,13 +1508,32 @@ data Grant u = Grant
 parseGrant :: UriMode u => Object -> Parser (Grant u)
 parseGrant o =
     Grant
-        <$> o .: "object"
+        <$> o .:+ "object"
         <*> o .: "context"
         <*> o .: "target"
 
 encodeGrant :: UriMode u => Grant u -> Series
 encodeGrant (Grant obj context target)
-    =  "object"  .= obj
+    =  "object"  .=+ obj
+    <> "context" .= context
+    <> "target"  .= target
+
+data Invite u = Invite
+    { inviteInstrument :: Either Role (ObjURI u)
+    , inviteObject     :: ObjURI u
+    , inviteTarget     :: ObjURI u
+    }
+
+parseInvite :: UriMode u => Object -> Parser (Invite u)
+parseInvite o =
+    Invite
+        <$> o .:+ "instrument"
+        <*> o .: "object"
+        <*> o .: "target"
+
+encodeInvite :: UriMode u => Invite u -> Series
+encodeInvite (Invite obj context target)
+    =  "object"  .=+ obj
     <> "context" .= context
     <> "target"  .= target
 
@@ -1629,6 +1649,7 @@ data SpecificActivity u
     | CreateActivity  (Create u)
     | FollowActivity  (Follow u)
     | GrantActivity   (Grant u)
+    | InviteActivity  (Invite u)
     | OfferActivity   (Offer u)
     | PushActivity    (Push u)
     | RejectActivity  (Reject u)
@@ -1666,6 +1687,7 @@ instance ActivityPub Activity where
                         "Create"  -> CreateActivity  <$> parseCreate o a actor
                         "Follow"  -> FollowActivity  <$> parseFollow o
                         "Grant"   -> GrantActivity   <$> parseGrant o
+                        "Invite"  -> InviteActivity  <$> parseInvite o
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
                         "Push"    -> PushActivity    <$> parsePush a o
                         "Reject"  -> RejectActivity  <$> parseReject o
@@ -1691,6 +1713,7 @@ instance ActivityPub Activity where
         activityType (CreateActivity _)  = "Create"
         activityType (FollowActivity _)  = "Follow"
         activityType (GrantActivity _)   = "Grant"
+        activityType (InviteActivity _)  = "Invite"
         activityType (OfferActivity _)   = "Offer"
         activityType (PushActivity _)    = "Push"
         activityType (RejectActivity _)  = "Reject"
@@ -1702,6 +1725,7 @@ instance ActivityPub Activity where
         encodeSpecific _ _ (CreateActivity a)  = encodeCreate a
         encodeSpecific _ _ (FollowActivity a)  = encodeFollow a
         encodeSpecific _ _ (GrantActivity a)   = encodeGrant a
+        encodeSpecific _ _ (InviteActivity a)  = encodeInvite a
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a
         encodeSpecific h _ (PushActivity a)    = encodePush h a
         encodeSpecific _ _ (RejectActivity a)  = encodeReject a

th/models

@@ -587,6 +587,28 @@ RemoteMessage
 
 Collab
 
+-------------------------------- Collab reason -------------------------------
+
+CollabFulfillsLocalTopicCreation
+    collab CollabId
+
+    UniqueCollabFulfillsLocalTopicCreation collab
+
+CollabFulfillsInviteLocal
+    collab CollabId
+    invite OutboxItemId
+
+    UniqueCollabFulfillsInviteLocal       collab
+    UniqueCollabFulfillsInviteLocalInvite invite
+
+CollabFulfillsInviteRemote
+    collab CollabId
+    actor  RemoteActorId
+    invite RemoteActivityId
+
+    UniqueCollabFulfillsInviteRemote       collab
+    UniqueCollabFulfillsInviteRemoteInvite invite
+
 -------------------------------- Collab topic --------------------------------
 
 -- Removed for now, until I figure out whether/how to federate custom roles
@@ -596,74 +618,30 @@ Collab
 --
 --    UniqueCollabRoleLocal collab
 
-CollabTopicLocal
+CollabTopicRepo
     collab CollabId
-
-    UniqueCollabTopicLocal collab
-
-CollabTopicLocalRepo
-    collab CollabTopicLocalId
     repo   RepoId
 
-    UniqueCollabTopicLocalRepo collab
+    UniqueCollabTopicRepo collab
 
-CollabTopicLocalDeck
+CollabTopicDeck
-    collab CollabTopicLocalId
+    collab CollabId
     deck   DeckId
 
-    UniqueCollabTopicLocalDeck collab
+    UniqueCollabTopicDeck collab
 
-CollabTopicLocalLoom
+CollabTopicLoom
-    collab CollabTopicLocalId
+    collab CollabId
     loom   LoomId
 
-    UniqueCollabTopicLocalLoom collab
+    UniqueCollabTopicLoom collab
 
-CollabTopicLocalReceive
+CollabEnable
-    collab CollabTopicLocalId
-    item   InboxItemId
-
-    UniqueCollabTopicLocalReceiveCollab collab
-    UniqueCollabTopicLocalReceiveItem   item
-
-CollabTopicLocalAccept
-    collab CollabTopicLocalId
-    accept OutboxItemId
-
-    UniqueCollabTopicLocalAcceptCollab collab
-    UniqueCollabTopicLocalAcceptAccept accept
-
-CollabTopicRemote
     collab CollabId
-    topic  RemoteObjectId
+    grant  OutboxItemId
-    actor  RemoteActorId
-    role   LocalURI       Maybe
 
-    UniqueCollabTopicRemote collab
+    UniqueCollabEnable      collab
-
+    UniqueCollabEnableGrant grant
-CollabTopicRemoteAccept
-    collab CollabTopicRemoteId
-    accept RemoteActivityId
-
-    UniqueCollabTopicRemoteAcceptCollab collab
-    UniqueCollabTopicRemoteAcceptAccept accept
-
--------------------------------- Collab sender -------------------------------
-
-CollabSenderLocal
-    collab   CollabId
-    activity OutboxItemId
-
-    UniqueCollabSenderLocal collab
-    UniqueCollabSenderLocalActivity activity
-
-CollabSenderRemote
-    collab   CollabId
-    actor    RemoteActorId
-    activity RemoteActivityId
-
-    UniqueCollabSenderRemote collab
-    UniqueCollabSenderRemoteActivity activity
 
 -------------------------------- Collab recipient ----------------------------
 
@@ -673,13 +651,6 @@ CollabRecipLocal
 
     UniqueCollabRecipLocal collab
 
-CollabRecipLocalReceive
-    collab CollabRecipLocalId
-    item   InboxItemId
-
-    UniqueCollabRecipLocalReceiveCollab collab
-    UniqueCollabRecipLocalReceiveItem   item
-
 CollabRecipLocalAccept
     collab CollabRecipLocalId
     accept OutboxItemId
@@ -700,13 +671,6 @@ CollabRecipRemoteAccept
     UniqueCollabRecipRemoteAcceptCollab collab
     UniqueCollabRecipRemoteAcceptAccept accept
 
--------------------------------- Collab reason -------------------------------
-
-CollabFulfillsLocalTopicCreation
-    collab CollabId
-
-    UniqueCollabFulfillsLocalTopicCreation collab
-
 ------------------------------------------------------------------------------
 ------------------------------------------------------------------------------
 

vervis.cabal

@@ -137,8 +137,10 @@ library
                        Vervis.Colour
                        Vervis.Content
                        Vervis.Darcs
+
                        Vervis.Data.Actor
                        Vervis.Data.Collab
+
                        Vervis.Delivery
                        Vervis.Discussion
                        Vervis.Federation
@@ -203,6 +205,9 @@ library
                        Vervis.Paginate
                        Vervis.Palette
                        Vervis.Path
+
+                       Vervis.Persist.Actor
+
                        Vervis.Query
                        Vervis.Readme
                        Vervis.Recipient