Port deck creation to the new actor system

src/Vervis/API.hs

@@ -25,7 +25,6 @@ module Vervis.API
     , createNoteC
     , createPatchTrackerC
     , createRepositoryC
-    , createTicketTrackerC
     , followC
     , offerTicketC
     --, offerDepC
@@ -1510,247 +1509,6 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                         hook
                         (renderAuthority host)
 
-createTicketTrackerC
-    :: Entity Person
-    -> Actor
-    -> Maybe
-        (Either
-            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-            FedURI
-        )
-    -> RecipientRoutes
-    -> [(Host, NonEmpty LocalURI)]
-    -> [Host]
-    -> AP.Action URIMode
-    -> AP.ActorDetail
-    -> Maybe (Host, AP.ActorLocal URIMode)
-    -> Maybe FedURI
-    -> ExceptT Text Handler OutboxItemId
-createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips remoteRecips fwdHosts action tracker mlocal muTarget = do
-
-    -- Check input
-    verifyNothingE maybeCap "Capability not needed"
-    verifyNothingE mlocal "'id' not allowed in new TicketTracker to create"
-    (name, msummary) <- parseTracker tracker
-    senderHash <- encodeKeyHashid pidUser
-    now <- liftIO getCurrentTime
-    verifyNothingE muTarget "'target' not supported in Create TicketTracker"
-
-    (deckID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
-
-        -- 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
-        actionCreate <- prepareCreate name msummary deckHash
-        _luCreate <- lift $ updateOutboxItem (LocalActorPerson pidUser) obiidCreate actionCreate
-
-        -- Deliver the Create activity to local recipients, and schedule
-        -- delivery for unavailable remote recipients
-        deliverHttpCreate <- do
-            let sieve =
-                    makeRecipientSet [] [LocalStagePersonFollowers senderHash]
-                localRecipsFinal = localRecipSieve sieve False localRecips
-            deliverActivityDB
-                (LocalActorPerson senderHash) (personActor personUser)
-                localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate
-
-        -- Insert collaboration access for deck's creator
-        obiidGrant <- lift $ insertEmptyOutboxItem obidDeck now
-        lift $ insertCollab jid obiidGrant
-
-        -- Insert a Grant activity to deck's outbox
-        let grantRecipActors = [LocalActorPerson senderHash]
-            grantRecipStages = [LocalStagePersonFollowers senderHash]
-        actionGrant <- prepareGrant senderHash deckHash obiidCreate grantRecipActors grantRecipStages
-        _luGrant <- lift $ updateOutboxItem (LocalActorDeck jid) obiidGrant actionGrant
-
-        -- Deliver the Grant activity to local recipients, and schedule
-        -- delivery for unavailable remote recipients
-        deliverHttpGrant <- do
-            let localRecipsGrant =
-                    makeRecipientSet grantRecipActors grantRecipStages
-            deliverActivityDB
-                (LocalActorDeck deckHash) aidDeck localRecipsGrant [] []
-                obiidGrant actionGrant
-
-        -- 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 now
-            insert_ $ InboxItemLocal ibidDeck obiidFollow ibiidF
-            ibiidA <- insert $ InboxItem False now
-            insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
-
-        -- Return instructions for HTTP delivery to remote recipients
-        return (jid, obiidCreate, deliverHttpCreate, deliverHttpGrant)
-
-    -- Launch asynchronous HTTP delivery of Create and Grant
-    lift $ do
-        forkWorker "createTicketTrackerC: async HTTP Create delivery" deliverHttpCreate
-        forkWorker "createTicketTrackerC: async HTTP Grant delivery" deliverHttpGrant
-
-    -- Spawn new Deck actor
-    success <- do
-        theater <- asksSite appTheater
-        env <- asksSite appEnv
-        liftIO $ launchActorIO theater env LocalActorDeck deckID
-    unless success $
-        error "Failed to spawn new Deck, somehow ID already in Theater"
-
-    return obiid
-    where
-    parseTracker (AP.ActorDetail typ muser mname msummary) = do
-        unless (typ == AP.ActorTypeTicketTracker) $
-            error "createTicketTrackerC: Create object isn't a TicketTracker"
-        verifyNothingE muser "TicketTracker can't have a username"
-        name <- fromMaybeE mname "TicketTracker doesn't specify name"
-        return (name, msummary)
-
-    findWorkflow = do
-        mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
-        entityKey <$> fromMaybeE mw "Can't find a workflow"
-
-    insertDeck now name msummary obiidCreate wid = 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 $ personActor personUser
-            }
-        did <- insert Deck
-            { deckActor      = aid
-            , deckWorkflow   = wid
-            , deckNextTicket = 1
-            , deckWiki       = Nothing
-            , deckCreate     = obiidCreate
-            }
-        return (did, obid, ibid, aid, fsid)
-
-    prepareCreate name msummary deckHash = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        hLocal <- asksSite siteInstanceHost
-        let ttdetail = AP.ActorDetail
-                { AP.actorType     = AP.ActorTypeTicketTracker
-                , AP.actorUsername = Nothing
-                , AP.actorName     = Just name
-                , AP.actorSummary  = msummary
-                }
-            ttlocal = AP.ActorLocal
-                { AP.actorId         = encodeRouteLocal $ DeckR deckHash
-                , AP.actorInbox      = encodeRouteLocal $ DeckInboxR deckHash
-                , AP.actorOutbox     = Nothing
-                , AP.actorFollowers  = Nothing
-                , AP.actorFollowing  = Nothing
-                , AP.actorPublicKeys = []
-                , AP.actorSshKeys    = []
-                }
-            specific = CreateActivity Create
-                { createObject = CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
-                , createTarget = Nothing
-                }
-        return action { actionSpecific = specific }
-
-    insertCollab did obiidGrant = do
-        cid <- insert $ Collab RoleAdmin
-        insert_ $ CollabTopicDeck cid did
-        insert_ $ CollabEnable cid obiidGrant
-        insert_ $ CollabRecipLocal cid pidUser
-        insert_ $ CollabFulfillsLocalTopicCreation cid
-
-    prepareGrant adminHash deckHash obiidCreate actors stages = do
-        encodeRouteHome <- getEncodeRouteHome
-        encodeRouteLocal <- getEncodeRouteLocal
-        obikhidCreate <- encodeKeyHashid obiidCreate
-        let recips =
-                map encodeRouteHome $
-                        map renderLocalActor actors ++
-                        map renderLocalStage stages
-        return Action
-            { actionCapability = Nothing
-            , actionSummary    = Nothing
-            , actionAudience   = Audience recips [] [] [] [] []
-            , actionFulfills   =
-                [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
-            , actionSpecific   = GrantActivity Grant
-                { grantObject    = RoleAdmin
-                , grantContext   = encodeRouteLocal $ DeckR deckHash
-                , grantTarget    = encodeRouteHome $ PersonR adminHash
-                , grantResult    = Nothing
-                , grantStart   = Nothing
-                , grantEnd     = Nothing
-                , grantAllows  = Invoke
-                , grantDelegates = Nothing
-                }
-            }
-
-    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 [] [] [] [] []
-                , activityFulfills = []
-                , activityProof    = Nothing
-                , 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 [] [] [] [] []
-                , activityFulfills = []
-                , activityProof    = Nothing
-                , activitySpecific = AcceptActivity Accept
-                    { acceptObject = ObjURI hLocal luFollow
-                    , acceptResult = Nothing
-                    }
-                }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-
 followC
     :: Entity Person
     -> Actor

src/Vervis/Actor/Common.hs

@@ -22,6 +22,7 @@ module Vervis.Actor.Common
     , topicInvite
     , topicRemove
     , topicJoin
+    , topicCreateMe
     )
 where
 
@@ -1137,3 +1138,113 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
                 let authorID = remoteAuthorId author
                 recipID <- insert $ CollabRecipRemote collabID authorID
                 insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
+
+topicCreateMe
+    :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
+       , PersistRecordBackend ct SqlBackend
+       )
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> EntityField ct (Key topic)
+    -> (CollabId -> Key topic -> ct)
+    -> UTCTime
+    -> Key topic
+    -> Verse
+    -> ActE (Text, Act (), Next)
+topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now recipKey (Verse authorIdMsig body) = do
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust recipKey
+            let actorID = topicActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Verify I'm in the initial just-been-created state
+        creatorActorID <-
+            fromMaybeE
+                (actorJustCreatedBy recipActor)
+                "I already sent the initial Grant, why am I receiving this Create?"
+        creatorPersonID <- do
+            mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
+            fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
+        existingCollabIDs <-
+            lift $ selectList [collabTopicFieldTopic ==. recipKey] []
+        unless (null existingCollabIDs) $
+            error "Just-been-created but I somehow already have Collabs"
+
+        -- Verify the Create author is my creator indeed
+        case authorIdMsig of
+            Left (_, actorID, _) | actorID == creatorActorID -> pure ()
+            _ -> throwE "Create author isn't why I believe my creator is - is this Create fake?"
+
+        maybeCreateDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+        lift $ for maybeCreateDB $ \ _createDB -> do
+
+            -- Create a Collab record and exit just-been-created state
+            grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+            insertCollab creatorPersonID grantID
+            update creatorActorID [ActorJustCreatedBy =. Nothing]
+
+            -- Prepare a Grant activity and insert to my outbox
+            grant@(actionGrant, _, _, _) <- lift prepareGrant
+            let recipByKey = grantResourceLocalActor $ topicResource recipKey
+            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
+
+            return (recipActorID, grantID, grant)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            lift $ sendActivity
+                recipByID recipActorID localRecipsGrant
+                remoteRecipsGrant fwdHostsGrant grantID actionGrant
+            done "Created a Collab record and published a Grant"
+
+    where
+
+    insertCollab personID grantID = do
+        collabID <- insert $ Collab AP.RoleAdmin
+        insert_ $ collabTopicCtor collabID recipKey
+        insert_ $ CollabEnable collabID grantID
+        insert_ $ CollabRecipLocal collabID personID
+        insert_ $ CollabFulfillsLocalTopicCreation collabID
+
+    prepareGrant = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        audCreator <- makeAudSenderOnly authorIdMsig
+        recipHash <- encodeKeyHashid recipKey
+        uCreator <- getActorURI authorIdMsig
+        uCreate <- getActivityURI authorIdMsig
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+            audience =
+                let audTopic = AudLocal [] [localActorFollowers topicByHash]
+                in  [audCreator, audTopic]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uCreate]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = AP.RoleAdmin
+                    , AP.grantContext   =
+                        encodeRouteLocal $ renderLocalActor topicByHash
+                    , AP.grantTarget    = uCreator
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)

src/Vervis/Actor/Deck.hs

@@ -63,13 +63,51 @@ import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
-import Vervis.Model
+import Vervis.Model hiding (deckCreate)
 import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
+-- Meaning: Someone has created a ticket tracker with my ID URI
+-- Behavior:
+--     * Verify I'm in a just-been-created state
+--     * Verify my creator and the Create sender are the same actor
+--     * Create an admin Collab record in DB
+--     * Send an admin Grant to the creator
+--     * Get out of the just-been-created state
+deckCreateMe
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> ActE (Text, Act (), Next)
+deckCreateMe =
+    topicCreateMe
+        deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeck
+
+deckCreate
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> AP.Create URIMode
+    -> ActE (Text, Act (), Next)
+deckCreate now deckID verse (AP.Create obj _muTarget) =
+    case obj of
+
+        AP.CreateTicketTracker _ mlocal -> do
+            (h, local) <- fromMaybeE mlocal "No tracker id provided"
+            let luTracker = AP.actorId local
+            uMe <- do
+                deckHash <- encodeKeyHashid deckID
+                encodeRouteHome <- getEncodeRouteHome
+                return $ encodeRouteHome $ DeckR deckHash
+            unless (uMe == ObjURI h luTracker) $
+                throwE "The created tracker id isn't me"
+            deckCreateMe now deckID verse
+
+        _ -> throwE "Unsupported Create object for Deck"
+
 ------------------------------------------------------------------------------
 -- Following
 ------------------------------------------------------------------------------
@@ -433,6 +471,7 @@ deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next)
 deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> deckAccept now deckID verse accept
+        AP.CreateActivity create -> deckCreate now deckID verse create
         AP.FollowActivity follow -> deckFollow now deckID verse follow
         AP.InviteActivity invite -> deckInvite now deckID verse invite
         AP.JoinActivity join     -> deckJoin now deckID verse join

src/Vervis/Actor/Person.hs

@@ -273,6 +273,18 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
         unless (authorByKey == targetByKey) $
             lift $ throwE "You're Accepting a Follow I sent to someone else"
         lift $ lift $ delete key
+        -- The followee already inserted a Follow, so we just make sure it
+        -- already exists
+        followKey <- do
+            mf <- lift $ lift $ getKeyBy $ UniqueFollowAccept acceptID
+            lift $ fromMaybeE mf "Can't find a Follow record in DB"
+        mf1 <-
+            lift $ lift $ getKeyBy $ UniqueFollow actorID (followRequestTarget val)
+        mf2 <-
+            lift $ lift $ getKeyBy $ UniqueFollowFollow outboxItemID
+        unless (mf1 == Just followKey && mf2 == Just followKey) $
+            lift $ throwE "Weird inconsistency with Follow uniques"
+        {-
         lift $ lift $ insert_ Follow
             { followActor  = actorID
             , followTarget = followRequestTarget val
@@ -280,6 +292,7 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
             , followFollow = outboxItemID
             , followAccept = acceptID
             }
+        -}
     tryFollow _ (Right _) _ = mzero
 
 -- Meaning: An actor rejected something

src/Vervis/Actor/Person/Client.hs

@@ -60,6 +60,7 @@ import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.Actor2
+import Vervis.Actor.Deck
 import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.Data.Collab
@@ -108,6 +109,187 @@ verifyRemoteAddressed remoteRecips u =
         lus <- lookup h remoteRecips
         guard $ lu `elem` lus
 
+-- Meaning: The human wants to create a ticket tracker
+-- Behavior:
+--      * Create a deck on DB
+--      * Launch a deck actor
+--      * Record a FollowRequest in DB
+--      * Create and send Create and Follow to it
+clientCreateDeck
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.ActorDetail
+    -> ActE OutboxItemId
+clientCreateDeck 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, deckID) <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- lift $ do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+        let actorMeID = personActor personMe
+
+        -- Insert new deck to DB
+        createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        wid <- findWorkflow
+        (deckID, deckFollowerSetID) <-
+            lift $ insertDeck now name msummary createID wid actorMeID
+
+        -- Insert the Create activity to my outbox
+        deckHash <- encodeKeyHashid deckID
+        actionCreate <- prepareCreate name msummary deckHash
+        luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
+
+        -- Prepare recipient sieve for sending the Create
+        personMeHash <- lift $ encodeKeyHashid personMeID
+        let sieve =
+                makeRecipientSet
+                    [LocalActorDeck deckHash]
+                    [LocalStagePersonFollowers personMeHash]
+            onlyDeck = DeckFamilyRoutes (DeckRoutes True False) []
+            addMe' decks = (deckHash, onlyDeck) : decks
+            addMe rs = rs { recipDecks = addMe' $ recipDecks rs }
+
+        -- Insert a follow request, since I'm about to send a Follow
+        followID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        lift $ insert_ $ FollowRequest actorMeID deckFollowerSetID True followID
+
+        -- Insert a Follow to my outbox
+        follow@(actionFollow, _, _, _) <- lift $ lift $ prepareFollow deckID luCreate
+        _luFollow <- lift $ updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
+
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False $ addMe localRecips
+            , createID
+            , actionCreate
+            , followID
+            , follow
+            , deckID
+            )
+
+    -- Spawn new Deck actor
+    success <- lift $ launchActor LocalActorDeck deckID
+    unless success $
+        error "Failed to spawn new Deck, 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.ActorTypeTicketTracker) $
+            error "createTicketTrackerC: Create object isn't a TicketTracker"
+        verifyNothingE muser "TicketTracker can't have a username"
+        name <- fromMaybeE mname "TicketTracker doesn't specify name"
+        return (name, msummary)
+
+    findWorkflow = do
+        mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
+        entityKey <$> fromMaybeE mw "Can't find a workflow"
+
+    insertDeck now name msummary obiidCreate wid 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 Deck
+            { deckActor      = aid
+            , deckWorkflow   = wid
+            , deckNextTicket = 1
+            , deckWiki       = Nothing
+            , deckCreate     = obiidCreate
+            }
+        return (did, fsid)
+
+    prepareCreate name msummary deckHash = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksEnv stageInstanceHost
+        let ttdetail = AP.ActorDetail
+                { AP.actorType     = AP.ActorTypeTicketTracker
+                , AP.actorUsername = Nothing
+                , AP.actorName     = Just name
+                , AP.actorSummary  = msummary
+                }
+            ttlocal = AP.ActorLocal
+                { AP.actorId         = encodeRouteLocal $ DeckR deckHash
+                , AP.actorInbox      = encodeRouteLocal $ DeckInboxR deckHash
+                , AP.actorOutbox     = Nothing
+                , AP.actorFollowers  = Nothing
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys = []
+                , AP.actorSshKeys    = []
+                }
+            specific = AP.CreateActivity AP.Create
+                { AP.createObject = AP.CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
+                , AP.createTarget = Nothing
+                }
+        return action { AP.actionSpecific = specific }
+
+    prepareFollow deckID luCreate = do
+        encodeRouteHome <- getEncodeRouteHome
+        h <- asksEnv stageInstanceHost
+        deckHash <- encodeKeyHashid deckID
+
+        let audTopic = AudLocal [LocalActorDeck deckHash] []
+            (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 $ DeckR deckHash
+                    , AP.followContext = Nothing
+                    , AP.followHide    = False
+                    }
+                }
+        return (action, recipientSet, remoteActors, fwdHosts)
+
+clientCreate
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.Create URIMode
+    -> ActE OutboxItemId
+clientCreate now personMeID msg (AP.Create object muTarget) =
+    case object of
+
+        AP.CreateTicketTracker detail mlocal -> do
+            verifyNothingE mlocal "Tracker id must not be provided"
+            verifyNothingE muTarget "'target' not supported in Create TicketTracker"
+            clientCreateDeck now personMeID msg detail
+
+        _ -> throwE "Unsupported Create object for C2S"
+
 -- Meaning: The human wants to invite someone A to a resource R
 -- Behavior:
 --      * Some basic sanity checks
@@ -334,6 +516,7 @@ clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
 clientBehavior now personID msg =
     done . T.pack . show =<<
     case AP.actionSpecific $ cmAction msg of
+        AP.CreateActivity create -> clientCreate now personID msg create
         AP.InviteActivity invite -> clientInvite now personID msg invite
         AP.RemoveActivity remove -> clientRemove now personID msg remove
         _ -> throwE "Unsupported activity type for C2S"

src/Vervis/Handler/Deck.hs

@@ -340,9 +340,9 @@ postDeckNewR = do
     (maybeSummary, audience, detail) <- C.createDeck personHash name desc
     (localRecips, remoteRecips, fwdHosts, action) <-
         C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing
-    actor <- runDB $ getJust $ personActor person
     result <-
-        runExceptT $ createTicketTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail Nothing Nothing
+        runExceptT $
+        handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
 
     case result of
         Left e -> do

src/Vervis/Handler/Person.hs

@@ -228,13 +228,14 @@ postPersonOutboxR personHash = do
                 case obj of
                     AP.CreateNote _ note ->
                         run createNoteC note mtarget
-                    AP.CreateTicketTracker detail mlocal ->
-                        run createTicketTrackerC detail mlocal mtarget
                     AP.CreateRepository detail vcs mlocal ->
                         run createRepositoryC detail vcs mlocal mtarget
                     AP.CreatePatchTracker detail repos mlocal ->
                         run createPatchTrackerC detail repos mlocal mtarget
-                    _ -> throwE "Unsupported Create 'object' type"
+                    _ ->
+                        handleViaActor
+                            (entityKey eperson) maybeCap localRecips remoteRecips
+                            fwdHosts action
             {-
             AddActivity (AP.Add obj target) ->
                 case obj of