diff --git a/migrations/549_2023-11-21_group_create.model b/migrations/549_2023-11-21_group_create.model new file mode 100644 index 0000000..c7b1eef --- /dev/null +++ b/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 diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 0d3977b..d65b957 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index d524e87..245ee8d 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 61369c3..172c8c6 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d022c47..939fc2a 100644 --- a/src/Web/ActivityPub.hs +++ b/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 diff --git a/th/models b/th/models index bf787ce..d4ba2d6 100644 --- a/th/models +++ b/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