S2S: Copy topicAccept code into projectAccept and reorganize the comment

This is in preparation to implementing Component mode

src/Vervis/Actor/Project.hs

@@ -31,6 +31,7 @@ import Data.Barbie
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
+import Data.Either
 import Data.Foldable
 import Data.Maybe
 import Data.Text (Text)
@@ -53,6 +54,7 @@ import Yesod.MonadSite
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
+import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.Access
@@ -68,7 +70,7 @@ import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model hiding (projectCreate)
-import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
 import Vervis.RemoteActorStore
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
@@ -77,26 +79,298 @@ import Vervis.Ticket
 
 -- Meaning: An actor accepted something
 -- Behavior:
---     * If it's on an Invite where I'm the resource:
+--     * Check if I know the activity that's being Accepted:
---         * Verify the Accept is by the Invite target
+--         * Is it an Invite to be a collaborator in me?
---         * Forward the Accept to my followers
+--             * Verify the Accept is by the Invite target
---         * Send a Grant:
+--         * If it's on a Join to be a collaborator in me?
+--             * Verify the Accept is authorized
+--         * If it's none of these, respond with error
+--     * Verify the Collab isn't enabled yet
+--     * Insert the Accept to my inbox
+--     * Record the Accept and enable the Collab in DB
+--     * Forward the Accept to my followers
+--     * Send a regular collaborator-Grant:
+--         * For Invite mode:
 --             * To: Accepter (i.e. Invite target)
 --             * CC: Invite sender, Accepter's followers, my followers
---     * If it's on a Join where I'm the resource:
+--         * For Join mode:
---         * Verify the Accept is authorized
---         * Forward the Accept to my followers
---         * Send a Grant:
 --             * To: Join sender
 --             * CC: Accept sender, Join sender's followers, my followers
---     * Otherwise respond with error
+--
+--
+--
+-- Stuff I'm about to implement for Component mode:
+--
+--
+--     * If it's on an Invite to be a component of me:
+--         * Verify the Component isn't enabled yet (same as checking if I've
+--           recorded the component's Accept)
+--         * If the sender isn't the component, just forward the Accept to my
+--           followers and done
+--         * If the sender is the component:
+--             * Enable the Component in DB
+--             * Forward the Accept to my followers
+--             * Send a delegator Grant to the component
+--                 * To: Component
+--                 * CC:
+--                     - Component's followers
+--                     - My followers
+--
+--
+--     * If it's on an Add to be a component of me:
+--         * Verify the Component isn't enabled yet (same as checking if I've
+--           recorded an Accept from a collaborator of mine)
+--         * If the sender is the component:
+--             * Verify I haven't seen a component-Accept on this Add
+--             * Record the Accept into the Component record in DB
+--             * Forward the Accept to my followers
+--         * Otherwise, i.e. sender isn't the component:
+--             * Verify I've seen the component-Accept for this Add
+--             * Verify the Accept is authorized
+--             * Record the Accept and enable the Component in DB
+--             * Forward the Accept to my followers
+--             * Send a delegator Grant to the component
+--                 * To: Component
+--                 * CC:
+--                     - Component's followers
+--                     - My followers
+--                     - The Accept's sender
 projectAccept
     :: UTCTime
     -> ProjectId
     -> Verse
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-projectAccept = topicAccept projectActor GrantResourceProject
+projectAccept now projectID (Verse authorIdMsig body) accept = do
+
+    -- Check input
+    acceptee <- parseAccept accept
+
+    -- Verify the capability URI is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCap <-
+        traverse
+            (nameExceptT "Accept capability" . parseActivityURI')
+            (AP.activityCapability $ actbActivity body)
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust projectID
+            let actorID = projectActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the accepted activity in our DB
+        accepteeDB <- do
+            a <- getActivity acceptee
+            fromMaybeE a "Can't find acceptee in DB"
+
+        -- See if the accepted activity is an Invite or Join to a local
+        -- resource, grabbing the Collab record from our DB
+        collab <- do
+            maybeCollab <-
+                lift $ runMaybeT $
+                    Left <$> tryInvite accepteeDB <|>
+                    Right <$> tryJoin accepteeDB
+            fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"
+
+        -- Find the local resource and verify it's me
+        collabID <-
+            lift $ case collab of
+                Left (fulfillsID, _) ->
+                    collabFulfillsInviteCollab <$> getJust fulfillsID
+                Right (fulfillsID, _) ->
+                    collabFulfillsJoinCollab <$> getJust fulfillsID
+        topic <- lift $ getCollabTopic collabID
+        unless (GrantResourceProject projectID == topic) $
+            throwE "Accept object is an Invite/Join for some other resource"
+
+        idsForAccept <-
+            case collab of
+
+                -- If accepting an Invite, find the Collab recipient and verify
+                -- it's the sender of the Accept
+                Left (fulfillsID, _) -> Left <$> do
+                    recip <-
+                        lift $
+                        requireEitherAlt
+                            (getBy $ UniqueCollabRecipLocal collabID)
+                            (getBy $ UniqueCollabRecipRemote collabID)
+                            "Found Collab with no recip"
+                            "Found Collab with multiple recips"
+                    case (recip, authorIdMsig) of
+                        (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
+                            | 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
+                Right (fulfillsID, _) -> Right <$> do
+                    capID <- fromMaybeE maybeCap "No capability provided"
+                    capability <-
+                        case capID of
+                            Left (capActor, _, capItem) -> return (capActor, capItem)
+                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
+                    verifyCapability'
+                        capability
+                        authorIdMsig
+                        (GrantResourceProject projectID)
+                        AP.RoleAdmin
+                    return fulfillsID
+
+        -- Verify the Collab isn't already validated
+        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
+        verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
+
+        maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+        for maybeAcceptDB $ \ acceptDB -> do
+
+            -- Record the Accept on the Collab
+            case (idsForAccept, acceptDB) of
+                (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
+                    maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
+                    unless (isNothing maybeAccept) $
+                        throwE "This Invite already has an Accept by recip"
+                (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
+                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
+                    unless (isJust maybeAccept) $
+                        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 $ GrantResourceProject projectID
+            recipByHash <- hashLocalActor recipByID
+            let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+
+            grantInfo <- do
+
+                -- Enable the Collab in our DB
+                grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
+                lift $ insert_ $ CollabEnable collabID grantID
+
+                -- Prepare a Grant activity and insert to my outbox
+                let inviterOrJoiner = either snd snd collab
+                    isInvite = isLeft collab
+                grant@(actionGrant, _, _, _) <- do
+                    Collab role <- lift $ getJust collabID
+                    lift $ prepareGrant isInvite inviterOrJoiner role
+                let recipByKey = grantResourceLocalActor $ GrantResourceProject projectID
+                _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
+                return (grantID, grant)
+
+            return (recipActorID, sieve, grantInfo)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
+            let recipByID = grantResourceLocalActor $ GrantResourceProject projectID
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
+            lift $ sendActivity
+                recipByID recipActorID localRecipsGrant
+                remoteRecipsGrant fwdHostsGrant grantID actionGrant
+            done "Forwarded the Accept and published a Grant"
+
+    where
+
+    tryInvite (Left (actorByKey, _actorEntity, itemID)) =
+        (,Left actorByKey) . collabInviterLocalCollab <$>
+            MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
+    tryInvite (Right remoteActivityID) = do
+        CollabInviterRemote collab actorID _ <-
+            MaybeT $ getValBy $
+                UniqueCollabInviterRemoteInvite remoteActivityID
+        actor <- lift $ getJust actorID
+        sender <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (collab, Right sender)
+
+    tryJoin (Left (actorByKey, _actorEntity, itemID)) =
+        (,Left actorByKey) . collabRecipLocalJoinFulfills <$>
+            MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
+    tryJoin (Right remoteActivityID) = do
+        CollabRecipRemoteJoin recipID fulfillsID _ <-
+            MaybeT $ getValBy $
+                UniqueCollabRecipRemoteJoinJoin remoteActivityID
+        remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
+        actor <- lift $ getJust remoteActorID
+        joiner <-
+            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+        return (fulfillsID, Right joiner)
+
+    prepareGrant isInvite sender role = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        audAccepter <- makeAudSenderWithFollowers authorIdMsig
+        audApprover <- lift $ makeAudSenderOnly authorIdMsig
+        recipHash <- encodeKeyHashid projectID
+        let topicByHash = grantResourceLocalActor $ GrantResourceProject recipHash
+
+        senderHash <- bitraverse hashLocalActor pure sender
+
+        uAccepter <- lift $ getActorURI authorIdMsig
+
+        let audience =
+                if isInvite
+                    then
+                        let audInviter =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] []
+                                    Right (ObjURI h lu, _followers) ->
+                                        AudRemote h [lu] []
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audInviter, audAccepter, audTopic]
+                    else
+                        let audJoiner =
+                                case senderHash of
+                                    Left actor -> AudLocal [actor] [localActorFollowers actor]
+                                    Right (ObjURI h lu, followers) ->
+                                        AudRemote h [lu] (maybeToList followers)
+                            audTopic = AudLocal [] [localActorFollowers topicByHash]
+                        in  [audJoiner, audApprover, audTopic]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [AP.acceptObject accept]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = role
+                    , AP.grantContext   =
+                        encodeRouteLocal $ renderLocalActor topicByHash
+                    , AP.grantTarget    =
+                        if isInvite
+                            then uAccepter
+                            else case senderHash of
+                                Left actor ->
+                                    encodeRouteHome $ renderLocalActor actor
+                                Right (ObjURI h lu, _) -> ObjURI h lu
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
 
 checkExistingComponents
     :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()

src/Vervis/Data/Collab.hs

@@ -136,19 +136,14 @@ parseTopic
     :: StageRoute Env ~ Route App
     => FedURI -> ActE (Either (GrantResourceBy Key) FedURI)
 parseTopic u = do
-    routeOrRemote <- parseFedURI u
+    t <- parseTopic' u
     bitraverse
-        (\ route -> do
+        (\case
-            resourceHash <-
+            Left r -> pure r
-                fromMaybeE
+            Right _ -> throwE "Local topic is a components route"
-                    (parseGrantResourceCollabs route)
-                    "Not a shared resource collabs route"
-            unhashGrantResourceE'
-                resourceHash
-                "Contains invalid hashid"
         )
         pure
-        routeOrRemote
+        t
 
 parseTopic'
     :: StageRoute Env ~ Route App