S2S: Group: Implement Create handler, sending back an admin-Grant

migrations/551_2023-11-21_group_collab.model

@@ -0,0 +1,5 @@
+CollabTopicGroup
+    collab CollabId
+    group  GroupId
+
+    UniqueCollabTopicGroup collab

src/Vervis/API.hs

@@ -175,6 +175,9 @@ verifyResourceAddressed localRecips resource = do
     verify (GrantResourceProject r) = do
         routes <- lookup r $ recipProjects localRecips
         guard $ routeProject routes
+    verify (GrantResourceGroup r) = do
+        routes <- lookup r $ recipGroups localRecips
+        guard $ routeGroup routes
 
 verifyRemoteAddressed
     :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()

src/Vervis/Actor/Group.hs

@@ -18,43 +18,109 @@ module Vervis.Actor.Group
     )
 where
 
+import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Barbie
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
+import Data.Either
 import Data.Foldable
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
+import Optics.Core
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 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
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
-import Vervis.Model
+import Vervis.Model hiding (groupCreate)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
+import Vervis.RemoteActorStore
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
+-- Meaning: Someone has created a group with my ID URI
+-- Behavior:
+--     * Verify I'm in a just-been-created state
+--     * Verify my creator and the Create sender are the same actor
+--     * Create an admin Collab record in DB
+--     * Send an admin Grant to the creator
+--     * Get out of the just-been-created state
+groupCreateMe
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> ActE (Text, Act (), Next)
+groupCreateMe =
+    topicCreateMe
+        groupActor GrantResourceGroup
+        CollabTopicGroupGroup CollabTopicGroup
+
+groupCreate
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Create URIMode
+    -> ActE (Text, Act (), Next)
+groupCreate now groupID verse (AP.Create obj _muTarget) =
+    case obj of
+
+        AP.CreateTeam _ mlocal -> do
+            (h, local) <- fromMaybeE mlocal "No group id provided"
+            let luGroup = AP.actorId local
+            uMe <- do
+                groupHash <- encodeKeyHashid groupID
+                encodeRouteHome <- getEncodeRouteHome
+                return $ encodeRouteHome $ GroupR groupHash
+            unless (uMe == ObjURI h luGroup) $
+                throwE "The created group id isn't me"
+            groupCreateMe now groupID verse
+
+        _ -> throwE "Unsupported Create object for Group"
+
 groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
-groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) =
+groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.CreateActivity create -> groupCreate now groupID verse create
         _ -> throwE "Unsupported activity type for Group"
 groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
 

src/Vervis/Actor/Person/Client.hs

@@ -98,6 +98,9 @@ verifyResourceAddressed localRecips resource = do
     verify (GrantResourceProject r) = do
         routes <- lookup r $ recipProjects localRecips
         guard $ routeProject routes
+    verify (GrantResourceGroup r) = do
+        routes <- lookup r $ recipGroups localRecips
+        guard $ routeGroup routes
 
 verifyProjectAddressed localRecips projectID = do
     projectHash <- encodeKeyHashid projectID
@@ -1131,6 +1134,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
                         Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
                         Left (GrantResourceProject l) -> Just $ LocalActorProject l
+                        Left (GrantResourceGroup l) -> Just $ LocalActorGroup l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@@ -1143,6 +1147,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                         Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
                         Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
                         Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
+                        Left (GrantResourceGroup l) -> Just $ LocalStageGroupFollowers l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

src/Vervis/Client.hs

@@ -1144,6 +1144,8 @@ invite personID uRecipient uResourceCollabs role = do
                     AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
                 Left (GrantResourceProject l) ->
                     AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
+                Left (GrantResourceGroup l) ->
+                    AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]
@@ -1259,6 +1261,8 @@ remove personID uRecipient uResourceCollabs = do
                     AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
                 Left (GrantResourceProject l) ->
                     AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
+                Left (GrantResourceGroup l) ->
+                    AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]

src/Vervis/Data/Collab.hs

@@ -455,13 +455,15 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
 grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
 grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
-grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
+grantResourceActorID (GrantResourceProject (Identity j)) = projectActor j
+grantResourceActorID (GrantResourceGroup (Identity g)) = groupActor g
 
 data GrantResourceBy f
     = GrantResourceRepo (f Repo)
     | GrantResourceDeck (f Deck)
     | GrantResourceLoom (f Loom)
     | GrantResourceProject (f Project)
+    | GrantResourceGroup (f Group)
     deriving (Generic, FunctorB, TraversableB, ConstraintsB)
 
 deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
@@ -476,6 +478,8 @@ unhashGrantResourcePure ctx = f
         GrantResourceLoom <$> decodeKeyHashidPure ctx l
     f (GrantResourceProject l) =
         GrantResourceProject <$> decodeKeyHashidPure ctx l
+    f (GrantResourceGroup l) =
+        GrantResourceGroup <$> decodeKeyHashidPure ctx l
 
 unhashGrantResource resource = do
     ctx <- asksSite siteHashidsContext
@@ -501,6 +505,8 @@ hashGrantResource (GrantResourceLoom k) =
     GrantResourceLoom <$> encodeKeyHashid k
 hashGrantResource (GrantResourceProject k) =
     GrantResourceProject <$> encodeKeyHashid k
+hashGrantResource (GrantResourceGroup k) =
+    GrantResourceGroup <$> encodeKeyHashid k
 
 hashGrantResource' (GrantResourceRepo k) =
     GrantResourceRepo <$> WAP.encodeKeyHashid k
@@ -510,6 +516,8 @@ hashGrantResource' (GrantResourceLoom k) =
     GrantResourceLoom <$> WAP.encodeKeyHashid k
 hashGrantResource' (GrantResourceProject k) =
     GrantResourceProject <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceGroup k) =
+    GrantResourceGroup <$> WAP.encodeKeyHashid k
 
 getGrantResource (GrantResourceRepo k) e =
     GrantResourceRepo <$> getEntityE k e
@@ -519,6 +527,8 @@ getGrantResource (GrantResourceLoom k) e =
     GrantResourceLoom <$> getEntityE k e
 getGrantResource (GrantResourceProject k) e =
     GrantResourceProject <$> getEntityE k e
+getGrantResource (GrantResourceGroup k) e =
+    GrantResourceGroup <$> getEntityE k e
 
 getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
     where
@@ -530,12 +540,15 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
         fmap GrantResourceLoom <$> getEntity k
     getGrantResourceEntity (GrantResourceProject k) =
         fmap GrantResourceProject <$> getEntity k
+    getGrantResourceEntity (GrantResourceGroup k) =
+        fmap GrantResourceGroup <$> getEntity k
 
 grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
 grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
 grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
 grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
 grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l
+grantResourceLocalActor (GrantResourceGroup l) = LocalActorGroup l
 
 data ComponentBy f
     = ComponentRepo (f Repo)
@@ -578,6 +591,7 @@ resourceToComponent = \case
     GrantResourceDeck k -> Just $ ComponentDeck k
     GrantResourceLoom k -> Just $ ComponentLoom k
     GrantResourceProject _ -> Nothing
+    GrantResourceGroup _ -> Nothing
 
 data GrantRecipBy' f
     = GrantRecipPerson' (f Person)

src/Vervis/Migration/Entities.hs

@@ -64,6 +64,7 @@ module Vervis.Migration.Entities
     , model_531_follow_request
     , model_541_project
     , model_542_component
+    , model_551_group_collab
     )
 where
 
@@ -248,3 +249,6 @@ model_541_project = $(schema "541_2023-06-26_project")
 
 model_542_component :: [Entity SqlBackend]
 model_542_component = $(schema "542_2023-06-26_component")
+
+model_551_group_collab :: [Entity SqlBackend]
+model_551_group_collab = $(schema "551_2023-11-21_group_collab")

src/Vervis/Persist/Collab.hs

@@ -71,23 +71,7 @@ import Vervis.Persist.Actor
 
 getCollabTopic
     :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
-getCollabTopic collabID = do
+getCollabTopic = fmap snd . getCollabTopic'
-    maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-    maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-    maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-    maybeProject <- getValBy $ UniqueCollabTopicProject collabID
-    return $
-        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
-            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just r, Nothing, Nothing, Nothing) ->
-                GrantResourceRepo $ collabTopicRepoRepo r
-            (Nothing, Just d, Nothing, Nothing) ->
-                GrantResourceDeck $ collabTopicDeckDeck d
-            (Nothing, Nothing, Just l, Nothing) ->
-                GrantResourceLoom $ collabTopicLoomLoom l
-            (Nothing, Nothing, Nothing, Just l) ->
-                GrantResourceProject $ collabTopicProjectProject l
-            _ -> error "Found Collab with multiple topics"
 
 getCollabTopic'
     :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key)
@@ -96,17 +80,20 @@ getCollabTopic' collabID = do
     maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
     maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
     maybeProject <- getBy $ UniqueCollabTopicProject collabID
+    maybeGroup <- getBy $ UniqueCollabTopicGroup collabID
     return $
-        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
+        case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of
-            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
+            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just (Entity k r), Nothing, Nothing, Nothing) ->
+            (Just (Entity k r), Nothing, Nothing, Nothing, Nothing) ->
                 (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
-            (Nothing, Just (Entity k d), Nothing, Nothing) ->
+            (Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
                 (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
-            (Nothing, Nothing, Just (Entity k l), Nothing) ->
+            (Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
                 (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
-            (Nothing, Nothing, Nothing, Just (Entity k l)) ->
+            (Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
                 (delete k, GrantResourceProject $ collabTopicProjectProject l)
+            (Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) ->
+                (delete k, GrantResourceGroup $ collabTopicGroupGroup l)
             _ -> error "Found Collab with multiple topics"
 
 getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)

th/models

@@ -676,6 +676,12 @@ CollabTopicProject
 
     UniqueCollabTopicProject collab
 
+CollabTopicGroup
+    collab CollabId
+    group  GroupId
+
+    UniqueCollabTopicGroup collab
+
 CollabEnable
     collab CollabId
     grant  OutboxItemId