C2S: Project creation

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