From 9d6bbfdf92cfee1c98d22a1c069eb499e1125ec5 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 26 Jun 2023 23:01:41 +0300 Subject: [PATCH] C2S: Project creation --- src/Vervis/Actor/Person/Client.hs | 163 ++++++++++++++++++++++++++++++ 1 file changed, 163 insertions(+) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index bc7d828..4756a6c 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.Project import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab @@ -277,6 +278,163 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd } return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: The human wants to create a project +-- Behavior: +-- * Create a project on DB +-- * Launch a project actor +-- * Record a FollowRequest in DB +-- * Create and send Create and Follow to it +clientCreateProject + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.ActorDetail + -> ActE OutboxItemId +clientCreateProject 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, projectID) <- lift $ withDB $ do + + -- Grab me from DB + (personMe, actorMe) <- do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + let actorMeID = personActor personMe + + -- Insert new project to DB + createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + (projectID, projectFollowerSetID) <- + insertProject now name msummary createID actorMeID + + -- Insert the Create activity to my outbox + projectHash <- lift $ encodeKeyHashid projectID + actionCreate <- lift $ prepareCreate name msummary projectHash + luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate + + -- Prepare recipient sieve for sending the Create + personMeHash <- lift $ encodeKeyHashid personMeID + let sieve = + makeRecipientSet + [LocalActorProject projectHash] + [LocalStagePersonFollowers personMeHash] + onlyProject = ProjectRoutes True False + addMe' projects = (projectHash, onlyProject) : projects + addMe rs = rs { recipProjects = addMe' $ recipProjects 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 projectID luCreate + _luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow + + return + ( personActor personMe + , localRecipSieve sieve False $ addMe localRecips + , createID + , actionCreate + , followID + , follow + , projectID + ) + + -- Spawn new Project actor + success <- lift $ launchActor LocalActorProject projectID + unless success $ + error "Failed to spawn new Project, 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.ActorTypeProject) $ + error "clientCreateProject: Create object isn't a Project" + verifyNothingE muser "Project can't have a username" + name <- fromMaybeE mname "Project doesn't specify name" + return (name, msummary) + + insertProject 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 + } + did <- insert Project + { projectActor = aid + , projectCreate = obiidCreate + } + return (did, fsid) + + prepareCreate name msummary projectHash = do + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksEnv stageInstanceHost + let ttdetail = AP.ActorDetail + { AP.actorType = AP.ActorTypeProject + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = msummary + } + ttlocal = AP.ActorLocal + { AP.actorId = encodeRouteLocal $ ProjectR projectHash + , AP.actorInbox = encodeRouteLocal $ ProjectInboxR projectHash + , AP.actorOutbox = Nothing + , AP.actorFollowers = Nothing + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = [] + , AP.actorSshKeys = [] + } + specific = AP.CreateActivity AP.Create + { AP.createObject = AP.CreateProject ttdetail (Just (hLocal, ttlocal)) + , AP.createTarget = Nothing + } + return action { AP.actionSpecific = specific } + + prepareFollow projectID luCreate = do + encodeRouteHome <- getEncodeRouteHome + h <- asksEnv stageInstanceHost + projectHash <- encodeKeyHashid projectID + + let audTopic = AudLocal [LocalActorProject projectHash] [] + (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 $ ProjectR projectHash + , AP.followContext = Nothing + , AP.followHide = False + } + } + return (action, recipientSet, remoteActors, fwdHosts) + clientCreate :: UTCTime -> PersonId @@ -291,6 +449,11 @@ clientCreate now personMeID msg (AP.Create object muTarget) = verifyNothingE muTarget "'target' not supported in Create TicketTracker" clientCreateDeck now personMeID msg detail + AP.CreateProject detail mlocal -> do + verifyNothingE mlocal "Project id must not be provided" + verifyNothingE muTarget "'target' not supported in Create Project" + clientCreateProject now personMeID msg detail + _ -> throwE "Unsupported Create object for C2S" -- Meaning: The human wants to invite someone A to a resource R