C2S: Enable creation of new decks, with automatic Grant and Follow

src/Vervis/API.hs

@@ -1036,16 +1036,17 @@ verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips =
 
 createTicketTrackerC
     :: Entity Person
+    -> Actor
     -> Maybe TextHtml
     -> Audience URIMode
     -> AP.ActorDetail
+    -> Maybe (Host, AP.ActorLocal URIMode)
     -> Maybe FedURI
     -> ExceptT Text Handler OutboxItemId
-createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarget = do
-    error "Temporarily disabled"
+createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tracker mlocal muTarget = do
 
-{-
     -- Check input
+    verifyNothingE mlocal "'id' not allowed in new TicketTracker to create"
     (name, msummary) <- parseTracker tracker
     senderHash <- encodeKeyHashid pidUser
     now <- liftIO getCurrentTime
@@ -1056,14 +1057,14 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
     checkFederation remoteRecips
     (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
 
-        -- Insert new project to DB
-        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
-        wid <- findWorkflow $ personIdent personUser
-        (jid, obidDeck, ibidDeck) <- lift $ insertDeck now name msummary obiidCreate wid
+        -- Insert new deck to DB
+        obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        wid <- findWorkflow
+        (jid, obidDeck, ibidDeck, aidDeck, fsidDeck) <- lift $ insertDeck now name msummary obiidCreate wid
 
         -- Insert the Create activity to author's outbox
         deckHash <- encodeKeyHashid jid
-        docCreate <- lift $ insertCreateToOutbox shrUser now blinded name msummary obiidCreate deckHash
+        docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate deckHash
 
         -- Deliver the Create activity to local recipients, and schedule
         -- delivery for unavailable remote recipients
@@ -1071,16 +1072,16 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
             let sieve =
                     makeRecipientSet [] [LocalStagePersonFollowers senderHash]
             moreRemoteRecips <-
-                lift $ deliverLocal' True (LocalActorPerson senderHash) (personInbox personUser) obiidCreate $
+                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $
                     localRecipSieve sieve False localRecips
             checkFederation moreRemoteRecips
             lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
 
-        -- Insert collaboration access for project's creator
+        -- Insert collaboration access for deck's creator
         obiidGrant <- lift $ insertEmptyOutboxItem obidDeck now
         lift $ insertCollab jid obiidGrant
 
-        -- Insert a Grant activity to project's outbox
+        -- Insert a Grant activity to deck's outbox
         let grantRecipActors = [LocalActorPerson senderHash]
             grantRecipStages = [LocalStagePersonFollowers senderHash]
         docGrant <-
@@ -1090,11 +1091,29 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
         -- delivery for unavailable remote recipients
         remoteRecipsHttpGrant <- do
             remoteRecips <-
-                lift $ deliverLocal' True (LocalActorDeck shrUser deckHash) ibidDeck obiidGrant $
+                lift $ deliverLocal' True (LocalActorDeck deckHash) aidDeck obiidGrant $
                     makeRecipientSet grantRecipActors grantRecipStages
             checkFederation remoteRecips
             lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips
 
+        -- Insert follow record
+        obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        obiidAccept <- lift $ insertEmptyOutboxItem obidDeck now
+        lift $ insert_ $ Follow (personActor personUser) fsidDeck True obiidFollow obiidAccept
+
+        -- Insert a Follow activity to sender's outbox, and an Accept to the
+        -- deck's outbox
+        luFollow <- lift $ insertFollowToOutbox senderHash deckHash obiidFollow
+        lift $ insertAcceptToOutbox senderHash deckHash obiidAccept luFollow
+
+        -- Deliver the Follow and Accept by simply manually inserting them to
+        -- deck and sender inboxes respectively
+        lift $ do
+            ibiidF <- insert $ InboxItem False
+            insert_ $ InboxItemLocal ibidDeck obiidFollow ibiidF
+            ibiidA <- insert $ InboxItem False
+            insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
+
         -- Return instructions for HTTP delivery to remote recipients
         return
             ( obiidCreate
@@ -1117,7 +1136,7 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
         return (name, msummary)
 
     findWorkflow = do
-        mw <- lift $ selectFirst ([] :: Filter Workflow) []
+        mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
         entityKey <$> fromMaybeE mw "Can't find a workflow"
 
     insertDeck now name msummary obiidCreate wid = do
@@ -1141,7 +1160,7 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
             , deckCollabUser = Nothing
             , deckCreate     = obiidCreate
             }
-        return (did, obid, ibid)
+        return (did, obid, ibid, aid, fsid)
 
     insertCreateToOutbox senderHash now blinded name msummary obiidCreate deckHash = do
         encodeRouteLocal <- getEncodeRouteLocal
@@ -1176,9 +1195,9 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
         update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
         return create
 
-    insertCollab jid obiidGrant = do
+    insertCollab did obiidGrant = do
         cid <- insert Collab
-        insert_ $ CollabTopicLocalProject cid jid
+        insert_ $ CollabTopicLocalDeck cid did
         insert_ $ CollabSenderLocal cid obiidGrant
         insert_ $ CollabRecipLocal cid pidUser
         insert_ $ CollabFulfillsLocalTopicCreation cid
@@ -1210,7 +1229,50 @@ createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarg
                 }
         update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant]
         return grant
--}
+
+    insertFollowToOutbox senderHash deckHash obiidFollow = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+
+        obikhid <- encodeKeyHashid obiidFollow
+        let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
+            recips = [encodeRouteHome $ DeckR deckHash]
+            doc = Doc hLocal Activity
+                { activityId       = Just luFollow
+                , activityActor    = encodeRouteLocal $ PersonR senderHash
+                , activityCapability = Nothing
+                , activitySummary  = Nothing
+                , activityAudience = AP.Audience recips [] [] [] [] []
+                , activitySpecific = FollowActivity AP.Follow
+                    { AP.followObject  = encodeRouteHome $ DeckR deckHash
+                    , AP.followContext = Nothing
+                    , AP.followHide    = False
+                    }
+                }
+        update obiidFollow [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return luFollow
+
+    insertAcceptToOutbox senderHash deckHash obiidAccept luFollow = do
+        hLocal <- asksSite siteInstanceHost
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+
+        obikhid <- encodeKeyHashid obiidAccept
+
+        let recips = [encodeRouteHome $ PersonR senderHash]
+            doc = Doc hLocal Activity
+                { activityId       = Just $ encodeRouteLocal $ DeckOutboxItemR deckHash obikhid
+                , activityActor    = encodeRouteLocal $ DeckR deckHash
+                , activityCapability = Nothing
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hLocal luFollow
+                    , acceptResult = Nothing
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
 
 data Followee
     = FolloweePerson (KeyHashid Person)

src/Vervis/Handler/Person.hs

@@ -61,6 +61,7 @@ import Database.Persist.Local
 import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.ActorKey
+import Vervis.API
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -127,7 +128,9 @@ postPersonOutboxR personHash = do
     unless federation badMethod
 
     personID <- decodeKeyHashid404 personHash
-    person <- runDB $ get404 personID
+    (person, actor) <- runDB $ do
+        p <- get404 personID
+        (p,) <$> getJust (personActor p)
 
     verifyPermission personID
     verifyContentTypeAP
@@ -138,7 +141,7 @@ postPersonOutboxR personHash = do
 
     result <- runExceptT $ do
         verifyAttribution $ AP.activityActor activity
-        handle (Entity personID person) activity
+        handle (Entity personID person) actor activity
     case result of
         Left err -> invalidArgs [err]
         Right outboxItemID -> do
@@ -157,8 +160,17 @@ postPersonOutboxR personHash = do
             Just (PersonR actorHash) | actorHash == personHash -> return ()
             _ -> throwE "Can't post activity attributed to someone else"
 
-    handle eperson (AP.Activity _mid actor mcap summary audience specific) =
+    handle eperson actorDB (AP.Activity _mid _actorAP mcap summary audience specific) =
         case specific of
+            AP.CreateActivity (AP.Create obj mtarget) ->
+                case obj of
+                    {-
+                    CreateNote _ note ->
+                        createNoteC eperson sharer summary audience note mtarget
+                    -}
+                    AP.CreateTicketTracker detail mlocal ->
+                        createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
+                    _ -> throwE "Unsupported Create 'object' type"
             {-
             AddActivity (AP.Add obj target) ->
                 case obj of
@@ -167,13 +179,6 @@ postPersonOutboxR personHash = do
                     _ -> throwE "Unsupported Add 'object' type"
             ApplyActivity apply ->
                 applyC eperson sharer summary audience mcap apply
-            CreateActivity (Create obj mtarget) ->
-                case obj of
-                    CreateNote _ note ->
-                        createNoteC eperson sharer summary audience note mtarget
-                    CreateTicket _ ticket ->
-                        createTicketC eperson sharer summary audience ticket mtarget
-                    _ -> throwE "Unsupported Create 'object' type"
             FollowActivity follow ->
                 followC shr summary audience follow
             OfferActivity (Offer obj target) ->