Copy topicInvite impl into projectInvite instead of reusing topicInvite

That's because projectInvite is about to get changes and can't use
topicInvite anymore; that's probably suitable only for components

src/Vervis/Actor/Project.hs

@@ -371,10 +371,143 @@ projectInvite
     -> Verse
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
-projectInvite =
-    topicInvite
-        projectActor GrantResourceProject
-        CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject
+projectInvite now projectID (Verse authorIdMsig body) invite = do
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    -- Check invite
+    (role, targetByKey) <- do
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
+        unless (Left (Left $ GrantResourceProject projectID) == resourceOrComps) $
+            throwE "Invite topic isn't my collabs URI"
+        recipient <-
+            bitraverse
+                (\case
+                    Left r -> pure r
+                    Right _ -> throwE "Not accepting component actors as collabs"
+                )
+                pure
+                recipientOrComp
+        return (role, recipient)
+
+    -- If target is local, find it in our DB
+    -- If target is remote, HTTP GET it, verify it's an actor, and store in
+    -- our DB (if it's already there, no need for HTTP)
+    --
+    -- NOTE: This is a blocking HTTP GET done right here in the Invite handler,
+    -- which is NOT a good idea. Ideally, it would be done async, and the
+    -- handler result (approve/disapprove the Invite) would be sent later in a
+    -- separate (e.g. Accept) activity. But for the PoC level, the current
+    -- situation will hopefully do.
+    targetDB <-
+        bitraverse
+            (withDBExcept . flip getGrantRecip "Invitee not found in DB")
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor' instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Target @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Target isn't an actor"
+                    Right (Just actor) -> return $ entityKey actor
+            )
+            targetByKey
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (topicActorID, topicActor) <- lift $ do
+            recip <- getJust projectID
+            let actorID = projectActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability'
+            capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
+
+        -- Verify that target doesn't already have a Collab for me
+        existingCollabIDs <-
+            lift $ case targetDB of
+                Left (GrantRecipPerson (Entity personID _)) ->
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
+                        E.on $
+                            topic E.^. CollabTopicProjectCollab E.==.
+                            recipl E.^. CollabRecipLocalCollab
+                        E.where_ $
+                            topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
+                            recipl E.^. CollabRecipLocalPerson E.==. E.val personID
+                        return $ recipl E.^. CollabRecipLocalCollab
+                Right remoteActorID ->
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
+                        E.on $
+                            topic E.^. CollabTopicProjectCollab E.==.
+                            recipr E.^. CollabRecipRemoteCollab
+                        E.where_ $
+                            topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
+                            recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
+                        return $ recipr E.^. CollabRecipRemoteCollab
+        case existingCollabIDs of
+            [] -> pure ()
+            [_] -> throwE "I already have a Collab for the target"
+            _ -> error "Multiple collabs found for target"
+
+        maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+        lift $ for maybeInviteDB $ \ inviteDB -> do
+
+            -- Insert Collab record to DB
+            insertCollab role targetDB inviteDB
+
+            -- Prepare forwarding Invite to my followers
+            sieve <- do
+                projectHash <- encodeKeyHashid projectID
+                return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
+            return (topicActorID, sieve)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (projectActorID, sieve) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorProject projectID) projectActorID sieve
+            done "Recorded and forwarded the Invite"
+
+    where
+
+    insertCollab role recipient inviteDB = do
+        collabID <- insert $ Collab role
+        fulfillsID <- insert $ CollabFulfillsInvite collabID
+        insert_ $ CollabTopicProject collabID projectID
+        case inviteDB of
+            Left (_, _, inviteID) ->
+                insert_ $ CollabInviterLocal fulfillsID inviteID
+            Right (author, _, inviteID) -> do
+                let authorID = remoteAuthorId author
+                insert_ $ CollabInviterRemote fulfillsID authorID inviteID
+        case recipient of
+            Left (GrantRecipPerson (Entity personID _)) ->
+                insert_ $ CollabRecipLocal collabID personID
+            Right remoteActorID ->
+                insert_ $ CollabRecipRemote collabID remoteActorID
 
 -- Meaning: An actor A asked to join a resource
 -- Behavior: