C2S: Implement team creation

migrations/549_2023-11-21_group_create.model

@@ -0,0 +1,47 @@
+Inbox
+FollowerSet
+
+Actor
+    name      Text
+    desc      Text
+    createdAt UTCTime
+    inbox     InboxId
+    outbox    OutboxId
+    followers FollowerSetId
+    justCreatedBy ActorId Maybe
+
+    UniqueActorInbox     inbox
+    UniqueActorOutbox    outbox
+    UniqueActorFollowers followers
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Group
+    actor  ActorId
+    create OutboxItemId
+
+    UniqueGroupActor  actor
+    UniqueGroupCreate create
+
+Person
+    username            Username
+    login               Text
+    passphraseHash      ByteString
+    email               EmailAddress
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    actor               ActorId
+--  reviewFollow        Bool
+
+    UniquePersonUsername username
+    UniquePersonLogin    login
+    UniquePersonEmail    email
+    UniquePersonActor    actor

src/Vervis/Actor/Person/Client.hs

@@ -61,6 +61,7 @@ import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.Actor2
 import Vervis.Actor.Deck
+import Vervis.Actor.Group
 import Vervis.Actor.Project
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -620,6 +621,163 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
                 }
         return (action, recipientSet, remoteActors, fwdHosts)
 
+-- Meaning: The human wants to create a team
+-- Behavior:
+--      * Create a team on DB
+--      * Launch a team actor
+--      * Record a FollowRequest in DB
+--      * Create and send Create and Follow to it
+clientCreateTeam
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.ActorDetail
+    -> ActE OutboxItemId
+clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
+
+    -- Check input
+    verifyNothingE maybeCap "Capability not needed"
+    (name, msummary) <- parseTracker tracker
+
+    (actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, groupID) <- lift $ withDB $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+        let actorMeID = personActor personMe
+
+        -- Insert new team to DB
+        createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
+        (groupID, projectFollowerSetID) <-
+            insertTeam now name msummary createID actorMeID
+
+        -- Insert the Create activity to my outbox
+        groupHash <- lift $ encodeKeyHashid groupID
+        actionCreate <- lift $ prepareCreate name msummary groupHash
+        luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
+
+        -- Prepare recipient sieve for sending the Create
+        personMeHash <- lift $ encodeKeyHashid personMeID
+        let sieve =
+                makeRecipientSet
+                    [LocalActorGroup groupHash]
+                    [LocalStagePersonFollowers personMeHash]
+            onlyGroup = GroupRoutes True False
+            addMe' groups = (groupHash, onlyGroup) : groups
+            addMe rs = rs { recipGroups = addMe' $ recipGroups rs }
+
+        -- Insert a follow request, since I'm about to send a Follow
+        followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
+        insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
+
+        -- Insert a Follow to my outbox
+        follow@(actionFollow, _, _, _) <- lift $ prepareFollow groupID luCreate
+        _luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
+
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False $ addMe localRecips
+            , createID
+            , actionCreate
+            , followID
+            , follow
+            , groupID
+            )
+
+    -- Spawn new Group actor
+    success <- lift $ launchActor LocalActorGroup groupID
+    unless success $
+        error "Failed to spawn new Group, somehow ID already in Theater"
+
+    -- Send the Create
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts createID actionCreate
+
+    -- Send the Follow
+    let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFollow
+        remoteRecipsFollow fwdHostsFollow followID actionFollow
+
+    return createID
+
+    where
+
+    parseTracker (AP.ActorDetail typ muser mname msummary) = do
+        unless (typ == AP.ActorTypeTeam) $
+            error "clientCreateTeam: Create object isn't a Team"
+        verifyNothingE muser "Team can't have a username"
+        name <- fromMaybeE mname "Team doesn't specify name"
+        return (name, msummary)
+
+    insertTeam now name msummary obiidCreate actorMeID = do
+        ibid <- insert Inbox
+        obid <- insert Outbox
+        fsid <- insert FollowerSet
+        aid <- insert Actor
+            { actorName      = name
+            , actorDesc      = fromMaybe "" msummary
+            , actorCreatedAt = now
+            , actorInbox     = ibid
+            , actorOutbox    = obid
+            , actorFollowers = fsid
+            , actorJustCreatedBy = Just actorMeID
+            }
+        gid <- insert Group
+            { groupActor      = aid
+            , groupCreate     = obiidCreate
+            }
+        return (gid, fsid)
+
+    prepareCreate name msummary groupHash = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksEnv stageInstanceHost
+        let ttdetail = AP.ActorDetail
+                { AP.actorType     = AP.ActorTypeTeam
+                , AP.actorUsername = Nothing
+                , AP.actorName     = Just name
+                , AP.actorSummary  = msummary
+                }
+            ttlocal = AP.ActorLocal
+                { AP.actorId         = encodeRouteLocal $ GroupR groupHash
+                , AP.actorInbox      = encodeRouteLocal $ GroupInboxR groupHash
+                , AP.actorOutbox     = Nothing
+                , AP.actorFollowers  = Nothing
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys = []
+                , AP.actorSshKeys    = []
+                }
+            specific = AP.CreateActivity AP.Create
+                { AP.createObject = AP.CreateTeam ttdetail (Just (hLocal, ttlocal))
+                , AP.createTarget = Nothing
+                }
+        return action { AP.actionSpecific = specific }
+
+    prepareFollow groupID luCreate = do
+        encodeRouteHome <- getEncodeRouteHome
+        h <- asksEnv stageInstanceHost
+        groupHash <- encodeKeyHashid groupID
+
+        let audTopic = AudLocal [LocalActorGroup groupHash] []
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [ObjURI h luCreate]
+                , AP.actionSpecific   = AP.FollowActivity AP.Follow
+                    { AP.followObject  = encodeRouteHome $ GroupR groupHash
+                    , AP.followContext = Nothing
+                    , AP.followHide    = False
+                    }
+                }
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 clientCreate
     :: UTCTime
     -> PersonId
@@ -639,6 +797,11 @@ clientCreate now personMeID msg (AP.Create object muTarget) =
             verifyNothingE muTarget "'target' not supported in Create Project"
             clientCreateProject now personMeID msg detail
 
+        AP.CreateTeam detail mlocal -> do
+            verifyNothingE mlocal "Team id must not be provided"
+            verifyNothingE muTarget "'target' not supported in Create Team"
+            clientCreateTeam now personMeID msg detail
+
         _ -> throwE "Unsupported Create object for C2S"
 
 -- Meaning: The human wants to invite someone A to a resource R

src/Vervis/Migration.hs

@@ -3021,6 +3021,32 @@ changes hLocal ctx =
         "OutboxItem"
       -- 548
     , addUnique' "CollabFulfillsInvite" "Accept" ["accept"]
+      -- 549
+    , addFieldRefRequired''
+        "Group"
+        (do obid <- insert Outbox549
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            insertEntity $ OutboxItem549 obid doc defaultTime
+        )
+        (Just $ \ (Entity obiidTemp obiTemp) -> do
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            gs <- selectKeysList ([] :: [Filter Group549]) []
+            for_ gs $ \ gid -> do
+                obid <- do
+                    mp <- selectFirst [] [Asc Person549Id]
+                    p <- entityVal <$> maybe (error "No people") return mp
+                    a <- getJust $ person549Actor p
+                    return $ actor549Outbox a
+                obiid <- insert $ OutboxItem549 obid doc defaultTime
+                update gid [Group549Create =. obiid]
+
+            delete obiidTemp
+            delete $ outboxItem549Outbox obiTemp
+        )
+        "create"
+        "OutboxItem"
+      -- 550
+    , addUnique' "Group" "Create" ["create"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -528,3 +528,6 @@ makeEntitiesMigration "527"
 
 makeEntitiesMigration "547"
     $(modelFile "migrations/547_2023-06-28_invite_accept.model")
+
+makeEntitiesMigration "549"
+    $(modelFile "migrations/549_2023-11-21_group_create.model")

src/Web/ActivityPub.hs

@@ -1831,6 +1831,7 @@ data CreateObject u
     | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
     | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
     | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
+    | CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u))
 
 parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
 parseCreateObject o
@@ -1858,6 +1859,11 @@ parseCreateObject o
                 fail "type isn't Project"
             ml <- parseActorLocal o
             return $ CreateProject d ml
+    <|> do  d <- parseActorDetail o
+            unless (actorType d == ActorTypeTeam) $
+                fail "type isn't Team"
+            ml <- parseActorLocal o
+            return $ CreateTeam d ml
 
 encodeCreateObject :: UriMode u => CreateObject u -> Series
 encodeCreateObject (CreateNote h note) = toSeries h note
@@ -1874,6 +1880,8 @@ encodeCreateObject (CreatePatchTracker d repos ml)
     <> maybe mempty (uncurry encodeActorLocal) ml
 encodeCreateObject (CreateProject d ml) =
     encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
+encodeCreateObject (CreateTeam d ml) =
+    encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
 
 data Create u = Create
     { createObject :: CreateObject u
@@ -1894,6 +1902,7 @@ parseCreate o a luActor = do
         CreateRepository _ _ _ -> return ()
         CreatePatchTracker _ _ _ -> return ()
         CreateProject _ _ -> return ()
+        CreateTeam _ _ -> return ()
     Create obj <$> o .:? "target"
 
 encodeCreate :: UriMode u => Create u -> Series

th/models

@@ -270,9 +270,11 @@ SshKey
     UniqueSshKey person ident
 
 Group
-    actor ActorId
+    actor  ActorId
+    create OutboxItemId
 
-    UniqueGroupActor actor
+    UniqueGroupActor  actor
+    UniqueGroupCreate create
 
 GroupMember
     person PersonId