S2S: Group: Add: Implement resource-passive mode

src/Vervis/Actor/Group.hs

@@ -147,6 +147,17 @@ import Vervis.Web.Collab
 --        * Create a Source/Dest record in DB
 --        * Forward the Add to my followers
 --
+--      * If I'm the object, being added to some resource's teams list:
+--        * Verify the target is a non-team resource's teams list, find in DB/HTTP
+--        * Verify it's not already an active resource of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential resource's Accept
+--        * Insert the Add to my inbox
+--        * Create an Effort record in DB
+--        * Forward the Add to my followers
+--
 --      * Otherwise, error
 groupAdd
     :: UTCTime
@@ -173,6 +184,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
                     addChildPassive $ Left j
                 Left (ATGroupChildren j) | j /= groupID ->
                     addParentPassive $ Left j
+                Left at | isJust $ addTargetResourceTeams at ->
+                    addResourcePassive $ Left $ fromJust $ addTargetResourceTeams at
                 Right (ObjURI h luColl) -> do
                     -- NOTE this is HTTP GET done synchronously in the activity
                     -- handler
@@ -189,6 +202,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
                         then addParentPassive $ Right $ ObjURI h lu
                     else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcParentsOrProjects rwc
                         then addChildPassive $ Right $ ObjURI h lu
+                    else if AP.actorTypeIsResourceNT typ && Just luColl == AP.rwcTeams rwc
+                        then addResourcePassive $ Right $ ObjURI h lu
                     else throwE "Weird collection situation"
                 _ -> throwE "I'm being added somewhere irrelevant"
         _ -> throwE "This Add isn't for me"
@@ -755,6 +770,87 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    addResourcePassive resource = do
+
+        -- If resource is local, find it in our DB
+        -- If resource is remote, HTTP GET it, verify it's an actor of Group
+        -- type, 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 handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        resourceDB <-
+            bitraverse
+                (\ ng ->
+                    withDBExcept $
+                        getLocalResourceEntityE (resourceFromNG ng) "Resource 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 "Resource @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Resource isn't an actor"
+                        Right (Just actor) -> do
+                            if AP.actorTypeIsResourceNT $ remoteActorType $ entityVal actor
+                                then pure ()
+                                else throwE "Remote resource type isn't a resource"
+                            return (u, actor)
+                )
+                resource
+        let resourceDB' = bimap localResourceID (entityKey . snd) resourceDB
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            -- Verify the target isn't already a resource of mine, and that no
+            -- Effort record is already in Add-Accept state
+            verifyNoStartedGroupResources groupID resourceDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create an Effort record in DB
+                insertEffort resourceDB' addDB
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    groupHash <- encodeKeyHashid groupID
+                    return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
+
+                return (groupActor group, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (groupActorID, sieve, inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
+                doneDB inboxItemID "[Resource-passive] Recorded a resource-in-progress, forwarded the Add"
+
+        where
+
+        insertEffort topicDB addDB = do
+            effortID <- insert $ Effort AP.RoleAdmin groupID
+            case topicDB of
+                Left r -> insert_ $ EffortTopicLocal effortID r
+                Right a -> insert_ $ EffortTopicRemote effortID a
+            themID <- insert $ EffortOriginThem effortID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ EffortThemGestureLocal themID addID
+                Right (author, _, addID) ->
+                    insert_ $ EffortThemGestureRemote themID (remoteAuthorId author) addID
+
 -- Meaning: An actor accepted something
 -- Behavior:
 --     * Check if I know the activity that's being Accepted:

src/Vervis/Actor/Person.hs

@@ -652,7 +652,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
                         manager <- asksEnv envHttpManager
                         coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                         lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                         if mluCollabs == Just luColl || mluMembers == Just luColl
                             then Just . (role,) . Right <$> do
                                 instanceID <-

src/Vervis/Actor/Person/Client.hs

@@ -266,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
 
                 instanceID <-
                     lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@@ -895,7 +895,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs/components list"
 
@@ -1044,7 +1044,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
                 unless (isCollabs || mluComps == Just luColl) $
                     throwE "Join resource isn't a collabs/components list"
@@ -1249,7 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 return $ ObjURI h lu
             )
             resource

src/Vervis/Client.hs

@@ -1150,7 +1150,7 @@ invite personID uRecipient uResourceCollabs role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs list"
                 return $ ObjURI h lu
@@ -1241,7 +1241,7 @@ add personID uRecipient uCollection role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote collection has no 'context'"
-                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 return $ ObjURI h lu
             )
             target
@@ -1327,7 +1327,7 @@ remove personID uRecipient uCollection = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _mluCollabs _ _mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _mluCollabs _ _mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 return $ ObjURI h lu
             )
             resource

src/Vervis/Data/Collab.hs

@@ -32,6 +32,7 @@ module Vervis.Data.Collab
     , AddTarget (..)
     , addTargetResource
     , addTargetComponentProjects
+    , addTargetResourceTeams
     , parseAdd
 
     , ComponentBy (..)
@@ -478,6 +479,13 @@ addTargetComponentProjects = \case
     ATLoomProjects l -> Just $ ComponentLoom l
     _ -> Nothing
 
+addTargetResourceTeams = \case
+    ATProjectTeams j -> Just $ LocalResourceProject' j
+    ATRepoTeams r -> Just $ LocalResourceRepo' r
+    ATDeckTeams d -> Just $ LocalResourceDeck' d
+    ATLoomTeams l -> Just $ LocalResourceLoom' l
+    _ -> Nothing
+
 parseAdd
     :: StageRoute Env ~ Route App
     => Either (LocalActorBy Key) FedURI

src/Vervis/Migration/Model2022.hs

@@ -80,13 +80,8 @@ import Vervis.Model.TH
 import Vervis.Model.Ticket
 import Vervis.Model.Workflow
 
--- For migrations 77, 114
-
 import Data.Int
-
 import Database.Persist.JSON
-import Network.FedURI
-import Web.ActivityPub
 
 makeEntitiesMigration "285"
     $(modelFile "migrations/2022_06_14_collab_mig.model")

src/Web/ActivityPub.hs

@@ -903,6 +903,7 @@ data ResourceWithCollections u = ResourceWithCollections
     , rwcParentsOrProjects :: Maybe LocalURI
     , rwcSubprojects :: Maybe LocalURI
     , rwcSubteams :: Maybe LocalURI
+    , rwcTeams :: Maybe LocalURI
     }
 
 instance ActivityPub ResourceWithCollections where
@@ -916,7 +917,8 @@ instance ActivityPub ResourceWithCollections where
             <*> withAuthorityMaybeO h (o .:? "context")
             <*> withAuthorityMaybeO h (o .:? "subprojects")
             <*> withAuthorityMaybeO h (o .:? "subteams")
-    toSeries h (ResourceWithCollections r collabs comps members ctx subj subt)
+            <*> withAuthorityMaybeO h (o .:? "teams")
+    toSeries h (ResourceWithCollections r collabs comps members ctx subj subt teams)
         =  toSeries h r
         <> "collaborators" .=? (ObjURI h <$> collabs)
         <> "components"    .=? (ObjURI h <$> comps)
@@ -924,6 +926,7 @@ instance ActivityPub ResourceWithCollections where
         <> "context"       .=? (ObjURI h <$> ctx)
         <> "subprojects"       .=? (ObjURI h <$> subj)
         <> "subteams"       .=? (ObjURI h <$> subt)
+        <> "teams"          .=? (ObjURI h <$> teams)
 
 data Project u = Project
     { projectActor      :: Actor u