C2S: Invite: Support component mode

src/Vervis/Actor/Person/Client.hs

@@ -75,7 +75,7 @@ import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Persist.Follow
-import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve, localActorFollowers)
 import Vervis.RemoteActorStore
 import Vervis.Ticket
 
@@ -97,6 +97,14 @@ verifyResourceAddressed localRecips resource = do
         routes <- lookup r $ recipProjects localRecips
         guard $ routeProject routes
 
+verifyProjectAddressed localRecips projectID = do
+    projectHash <- encodeKeyHashid projectID
+    fromMaybeE (verify projectHash) "Project not addressed"
+    where
+    verify j = do
+        routes <- lookup j $ recipProjects localRecips
+        guard $ routeProject routes
+
 verifyRecipientAddressed localRecips recipient = do
     recipientHash <- hashGrantRecip recipient
     fromMaybeE (verify recipientHash) "Recipient not addressed"
@@ -105,6 +113,21 @@ verifyRecipientAddressed localRecips recipient = do
         routes <- lookup p $ recipPeople localRecips
         guard $ routePerson routes
 
+verifyComponentAddressed :: RecipientRoutes -> ComponentBy Key -> ActE ()
+verifyComponentAddressed localRecips component = do
+    componentHash <- hashComponent component
+    fromMaybeE (verify componentHash) "Local component not addressed"
+    where
+    verify (ComponentRepo r) = do
+        routes <- lookup r $ recipRepos localRecips
+        guard $ routeRepo routes
+    verify (ComponentDeck d) = do
+        routes <- lookup d $ recipDecks localRecips
+        guard $ routeDeck $ familyDeck routes
+    verify (ComponentLoom l) = do
+        routes <- lookup l $ recipLooms localRecips
+        guard $ routeLoom $ familyLoom routes
+
 verifyRemoteAddressed :: [(Host, NonEmpty LocalURI)] -> FedURI -> ActE ()
 verifyRemoteAddressed remoteRecips u =
     fromMaybeE (verify u) "Given remote entity not addressed"
@@ -478,23 +501,7 @@ clientInvite
 clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do
 
     -- Check input
-    (_role, resourceOrComps, recipientOrComp) <- parseInvite (Left $ LocalActorPerson personMeID) invite
+    (_role, resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite
-    resource <-
-        bitraverse
-            (\case
-                Left r -> pure r
-                Right _ -> throwE "Not accepting project components as target"
-            )
-            pure
-            resourceOrComps
-    recipient <-
-        bitraverse
-            (\case
-                Left r -> pure r
-                Right _ -> throwE "Not accepting component actors as collabs"
-            )
-            pure
-            recipientOrComp
     _capID <- fromMaybeE maybeCap "No capability provided"
 
     -- If resource collabs URI is remote, HTTP GET it and its resource and its
@@ -502,14 +509,17 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
     -- our DB.
     resourceDB <-
         bitraverse
-            (withDBExcept . flip getGrantResource "Grant context not found in DB")
+            (bitraverse
+                (withDBExcept . flip getGrantResource "Grant resource not found in DB")
+                (withDBExcept . flip getEntityE "Grant context project not found in DB")
+            )
             (\ u@(ObjURI h luColl) -> 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 _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                unless (mluCollabs == Just luColl || mluComps == Just luColl) $
-                    throwE "Invite target isn't a collabs list"
+                    throwE "Invite target isn't a collabs/components list"
 
                 instanceID <-
                     lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@@ -528,7 +538,10 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
     -- it to our DB. If recipient is local, find it in our DB.
     recipientDB <-
         bitraverse
-            (withDBExcept . flip getGrantRecip "Grant recipient not found in DB")
+            (bitraverse
+                (withDBExcept . flip getGrantRecip "Grant recipient person not found in DB")
+                (withDBExcept . flip getComponentE "Grant recipient component not found in DB")
+            )
             (\ u@(ObjURI h lu) -> do
                 instanceID <-
                     lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@@ -545,11 +558,17 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
 
     -- Verify that resource and recipient are addressed by the Invite
     bitraverse_
+        (bitraverse_
             (verifyResourceAddressed localRecips . bmap entityKey)
+            (verifyProjectAddressed localRecips . entityKey)
+        )
         (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
         resourceDB
     bitraverse_
+        (bitraverse_
             (verifyRecipientAddressed localRecips . bmap entityKey)
+            (verifyComponentAddressed localRecips . bmap entityKey)
+        )
         (verifyRemoteAddressed remoteRecips . snd)
         recipientDB
 
@@ -566,30 +585,28 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
 
         -- Prepare local recipients for Invite delivery
         sieve <- lift $ do
-            resourceHash <- bitraverse hashGrantResource' pure resource
+            resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource
-            recipientHash <- bitraverse hashGrantRecip pure recipient
+            recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
             senderHash <- encodeKeyHashid personMeID
             let sieveActors = catMaybes
                     [ case resourceHash of
-                        Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+                        Left (Left r)  -> Just $ grantResourceLocalActor r
-                        Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
+                        Left (Right j) -> Just $ LocalActorProject j
-                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
-                        Left (GrantResourceProject l) -> Just $ LocalActorProject l
                         Right _        -> Nothing
                     , case recipientHash of
-                        Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
+                        Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p
+                        Left (Right c)                   -> Just $ componentActor c
                         Right _                          -> Nothing
                     ]
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
                     , case resourceHash of
-                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+                        Left (Left r)  -> Just $ localActorFollowers $ grantResourceLocalActor r
-                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
+                        Left (Right j) -> Just $ LocalStageProjectFollowers j
-                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
-                        Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
                         Right _        -> Nothing
                     , case recipientHash of
-                        Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
+                        Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p
+                        Left (Right c)                   -> Just $ localActorFollowers $ componentActor c
                         Right _                          -> Nothing
                     ]
             return $ makeRecipientSet sieveActors sieveStages