From cc87b6e17d1fd53631fd68af9223837d3b55d075 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 19 Jun 2023 18:44:12 +0300 Subject: [PATCH] Port deck creation to the new actor system --- src/Vervis/API.hs | 242 ------------------------------ src/Vervis/Actor/Common.hs | 111 ++++++++++++++ src/Vervis/Actor/Deck.hs | 41 ++++- src/Vervis/Actor/Person.hs | 13 ++ src/Vervis/Actor/Person/Client.hs | 183 ++++++++++++++++++++++ src/Vervis/Handler/Deck.hs | 4 +- src/Vervis/Handler/Person.hs | 7 +- 7 files changed, 353 insertions(+), 248 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 4fc0465..ba2885c 100644 --- a/src/Vervis/API.hs +++ b/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 diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index ca41a42..d8ea4a0 100644 --- a/src/Vervis/Actor/Common.hs +++ b/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) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 139cb90..6dd8ab1 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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 diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index f47f856..7fceec9 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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 diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 7ee2bb0..3cdd7a9 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/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" diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index e2f8e87..8f312b8 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 6693648..eca71e0 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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