From cbd81d1d0b8202ebe3f7a6df0cef9fbc03178391 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 5 Nov 2023 16:13:09 +0200 Subject: [PATCH] C2S, UI: Deck ticket closing button on ticket page Ticket closing can now be done via the new C2S, and the "Close ticket" button on TicketR page is back, and uses that new C2S. S2S, C2S and pseudo-client are implemented for both Deck and Loom, but the actual button and POST handler are provided here only for Deck. Will add ones for Loom soon, as needed. --- src/Vervis/API.hs | 202 ------------------------------ src/Vervis/Actor/Person/Client.hs | 35 ++++++ src/Vervis/Client.hs | 89 ++++++++----- src/Vervis/Foundation.hs | 1 + src/Vervis/Handler/Person.hs | 1 - src/Vervis/Handler/Ticket.hs | 35 +++++- templates/ticket/one.hamlet | 2 +- th/routes | 2 +- 8 files changed, 132 insertions(+), 235 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index dea3d8e..32f6b7b 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -27,7 +27,6 @@ module Vervis.API , createRepositoryC , followC --, offerDepC - , resolveC , undoC ) where @@ -1975,207 +1974,6 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve return (doc, recipientSet, remoteActors, fwdHosts) -} -resolveC - :: Entity Person - -> Actor - -> Maybe - (Either - (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) - FedURI - ) - -> RecipientRoutes - -> [(Host, NonEmpty LocalURI)] - -> [Host] - -> AP.Action URIMode - -> AP.Resolve URIMode - -> ExceptT Text Handler OutboxItemId -resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Resolve uObject) = do - - -- Check input - maybeLocalWorkItem <- - nameExceptT "Resolve object" $ either Just (const Nothing) <$> do - routeOrRemote <- parseFedURIOld uObject - bitraverse - (\ r -> do - wiByHash <- - fromMaybeE (parseWorkItem r) "Not a work item route" - VA2.runActE $ unhashWorkItemE wiByHash "Work item invalid keyhashid" - ) - pure - routeOrRemote - capID <- fromMaybeE maybeCap "No capability provided" - - -- Verify that the work item's tracker is addressed - for_ maybeLocalWorkItem $ \ wi -> do - trackerByHash <- hashLocalActor $ workItemActor wi - unless (actorIsAddressed localRecips trackerByHash) $ - throwE "Work item's tracker not addressed by the Resolve" - - senderHash <- encodeKeyHashid senderPersonID - now <- liftIO getCurrentTime - - (resolveID, deliverHttpResolve, maybeDeliverHttpAccept) <- runDBExcept $ do - - workItemDB <- for maybeLocalWorkItem $ \ wi -> do - - -- Find the work item and its tracker in DB, and verify the work - -- item isn't already resolved - (resource, actor, ticketID) <- - case wi of - WorkItemTicket deckID taskID -> do - maybeTicket <- lift $ getTicket deckID taskID - (Entity _ deck, _task, Entity ticketID _, _author, resolve) <- - fromMaybeE maybeTicket "No such ticket in DB" - verifyNothingE resolve "Ticket already resolved" - actor <- lift $ getJustEntity $ deckActor deck - return (GrantResourceDeck deckID, actor, ticketID) - WorkItemCloth loomID clothID -> do - maybeCloth <- lift $ getCloth loomID clothID - (Entity _ loom, _cloth, Entity ticketID _, _author, resolve, _merge) <- - fromMaybeE maybeCloth "No such MR in DB" - verifyNothingE resolve "MR already resolved" - actor <- lift $ getJustEntity $ loomActor loom - return (GrantResourceLoom loomID, actor, ticketID) - - -- Verify the sender is authorized by the tracker to resolve work - -- items - capability <- - case capID of - Left (capActor, _, capItem) -> return (capActor, capItem) - Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker" - verifyCapability capability (Left senderPersonID) resource RoleTriage - - return (wi, actor, ticketID) - - -- Insert Resolve to sender's outbox - resolveID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - luResolve <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) resolveID action - - -- Deliver the Resolve activity to local recipients, and schedule - -- delivery for unavailable remote recipients - deliverHttpResolve <- do - sieve <- do - (actors, stages) <- - case maybeLocalWorkItem of - Nothing -> pure ([], []) - Just (WorkItemTicket deckID taskID) -> do - deckHash <- encodeKeyHashid deckID - taskHash <- encodeKeyHashid taskID - return - ( [LocalActorDeck deckHash] - , [ LocalStageDeckFollowers deckHash - , LocalStageTicketFollowers deckHash taskHash - ] - ) - Just (WorkItemCloth loomID clothID) -> do - loomHash <- encodeKeyHashid loomID - clothHash <- encodeKeyHashid clothID - return - ( [LocalActorLoom loomHash] - , [ LocalStageLoomFollowers loomHash - , LocalStageClothFollowers loomHash clothHash - ] - ) - let stages' = LocalStagePersonFollowers senderHash : stages - return $ makeRecipientSet actors stages' - let localRecipsFinal = localRecipSieve sieve False localRecips - deliverActivityDB - (LocalActorPerson senderHash) (personActor senderPerson) - localRecipsFinal remoteRecips fwdHosts resolveID action - - -- Verify that the tracker has received the Resolve, resolve the work - -- item in DB, and publish Accept - maybeDeliverHttpAccept <- for workItemDB $ \ (wi, Entity trackerActorID trackerActor, ticketID) -> do - - -- Verify tracker received the Resolve - verifyActorHasItem - trackerActorID - resolveID - "Local tracker didn't receive the Resolve" - - -- Mark work item in DB as resolved by the Resolve - acceptID <- - lift $ insertEmptyOutboxItem (actorOutbox trackerActor) now - lift $ insertResolve ticketID resolveID acceptID - - -- Insert an Accept activity to tracker's outbox - trackerStages <- - case wi of - WorkItemTicket deckID taskID -> do - deckHash <- encodeKeyHashid deckID - taskHash <- encodeKeyHashid taskID - return - [ LocalStageDeckFollowers deckHash - , LocalStageTicketFollowers deckHash taskHash - ] - WorkItemCloth loomID clothID -> do - loomHash <- encodeKeyHashid loomID - clothHash <- encodeKeyHashid clothID - return - [ LocalStageLoomFollowers loomHash - , LocalStageClothFollowers loomHash clothHash - ] - let acceptActors = [LocalActorPerson senderHash] - acceptStages = - LocalStagePersonFollowers senderHash : trackerStages - actionAccept <- prepareAccept luResolve acceptActors acceptStages - let trackerByKey = workItemActor wi - _ <- lift $ updateOutboxItem trackerByKey acceptID actionAccept - - -- Deliver the Accept activity to local recipients, and schedule - -- delivery for unavailable remote recipients - let localRecipsAccept = makeRecipientSet acceptActors acceptStages - trackerByHash <- hashLocalActor trackerByKey - deliverActivityDB - trackerByHash trackerActorID localRecipsAccept [] [] - acceptID actionAccept - - -- Return instructions for HTTP delivery of Resolve and Accept to - -- remote recipients - return - ( resolveID - , deliverHttpResolve - , maybeDeliverHttpAccept - ) - - -- Launch asynchronous HTTP delivery of Resolve and Accept - lift $ do - forkWorker "resolveC: async HTTP Resolve delivery" deliverHttpResolve - for_ maybeDeliverHttpAccept $ - forkWorker "resolveC: async HTTP Accept delivery" - - return resolveID - - where - - insertResolve ticketID resolveID acceptID = do - trid <- insert TicketResolve - { ticketResolveTicket = ticketID - , ticketResolveAccept = acceptID - } - insert_ TicketResolveLocal - { ticketResolveLocalTicket = trid - , ticketResolveLocalActivity = resolveID - } - - prepareAccept luResolve actors stages = do - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - let recips = - map encodeRouteHome $ - map renderLocalActor actors ++ - map renderLocalStage stages - return AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = Audience recips [] [] [] [] [] - , AP.actionFulfills = [] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hLocal luResolve - , AP.acceptResult = Nothing - } - } - undoC :: Entity Person -> Actor diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 607e1d3..1b458fa 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -997,6 +997,40 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost fwdHosts removeID action return removeID +-- Meaning: The human wants to close a ticket/MR/dependency +-- Behavior: +-- * Insert Resolve to my inbox +-- * Asynchrnously deliver without filter +clientResolve + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.Resolve URIMode + -> ActE OutboxItemId +clientResolve now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) (AP.Resolve uObject) = do + + (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do + + -- Grab me from DB + (personMe, actorMe) <- lift $ do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + + -- Insert the Resolve activity to my outbox + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action + + return + ( personActor personMe + , localRecips + , acceptID + ) + + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips + fwdHosts acceptID action + return acceptID + clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next) clientBehavior now personID msg = done . T.pack . show =<< @@ -1007,4 +1041,5 @@ clientBehavior now personID msg = AP.InviteActivity invite -> clientInvite now personID msg invite AP.OfferActivity offer -> clientOffer now personID msg offer AP.RemoveActivity remove -> clientRemove now personID msg remove + AP.ResolveActivity resolve -> clientResolve now personID msg resolve _ -> throwE "Unsupported activity type for C2S" diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 23af4d9..01a16d1 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -25,7 +25,7 @@ module Vervis.Client --, followTicket --, followRepo , offerIssue - --, resolve + , resolve --, undoFollowSharer --, undoFollowProject --, undoFollowTicket @@ -364,40 +364,71 @@ offerIssue senderHash title desc uTracker = do return (Nothing, audience, ticket) -{- -{- resolve - :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent + :: KeyHashid Person -> FedURI - -> m (Either Text (Maybe TextHtml, Audience URIMode, Resolve URIMode)) -resolve shrUser uObject = runExceptT $ do - encodeRouteHome <- getEncodeRouteHome - wiFollowers <- askWorkItemFollowers - object <- parseWorkItem "Resolve object" uObject - WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" object + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode) +resolve senderHash uObject = do + + manager <- asksSite appHttpManager + AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left uObject) + uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context" + audFollowers <- do + (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id" + let luFollowers = AP.ticketParticipants tl + routeOrRemote <- parseFedURIOld $ ObjURI hFollowers luFollowers + case routeOrRemote of + Left route -> + case route of + TicketFollowersR d t -> + return $ + AudLocal + [] + [LocalStageTicketFollowers d t] + ClothFollowersR l c -> + return $ + AudLocal + [] + [LocalStageClothFollowers l c] + _ -> throwE "Not a tickets followers route" + Right u@(ObjURI h lu) -> return $ AudRemote h [] [lu] + + tracker <- do + tracker <- runActE $ checkTracker uTracker + case tracker of + TrackerDeck deckID -> Left . Left <$> encodeKeyHashid deckID + TrackerLoom loomID -> Left . Right <$> encodeKeyHashid loomID + TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do + instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker) + result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker + case result of + Left Nothing -> throwE "Tracker @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Tracker isn't an actor" + Right (Just actor) -> return (entityVal actor, uTracker) + let audAuthor = - AudLocal - [LocalActorSharer shrUser] - [LocalPersonCollectionSharerFollowers shrUser] - audTicketContext = contextAudience context - audTicketAuthor = authorAudience author - audTicketFollowers = - case ident of - Left (wi, _ltid) -> AudLocal [] [wiFollowers wi] - Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] + AudLocal [] [LocalStagePersonFollowers senderHash] + audTracker = + case tracker of + Left (Left deckHash) -> + AudLocal + [LocalActorDeck deckHash] + [LocalStageDeckFollowers deckHash] + Left (Right loomHash) -> + AudLocal + [LocalActorLoom loomHash] + [LocalStageLoomFollowers loomHash] + Right (remoteActor, ObjURI hTracker luTracker) -> + AudRemote hTracker + [luTracker] + (maybeToList $ remoteActorFollowers remoteActor) - (_, _, _, audLocal, audRemote) = - collectAudience $ - audAuthor : - audTicketAuthor : - audTicketFollowers : - audTicketContext + audience = [audAuthor, audTracker, audFollowers] - recips = map encodeRouteHome audLocal ++ audRemote - return (Nothing, Audience recips [] [] [] [] [], Resolve uObject) - -} + return (Nothing, audience, AP.Resolve uObject) +{- undoFollow :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a36aee1..5e1cd5c 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -950,6 +950,7 @@ instance YesodBreadcrumbs App where TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t) TicketNewR d -> ("New Ticket", Just $ DeckR d) + TicketCloseR _ _ -> ("", Nothing) TicketFollowR _ _ -> ("", Nothing) TicketUnfollowR _ _ -> ("", Nothing) TicketReplyR d t -> ("Reply", Just $ TicketR d t) diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index d04aa25..41b18e0 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -254,7 +254,6 @@ postPersonOutboxR personHash = do offerDepC eperson sharer summary audience dep target -} _ -> throwE "Unsupported Offer 'object' type" - AP.ResolveActivity resolve -> run resolveC resolve AP.UndoActivity undo -> run undoC undo _ -> handleViaActor diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 79f5ce8..07a3b32 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2023 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -26,6 +26,7 @@ module Vervis.Handler.Ticket , getTicketNewR , postTicketNewR + , postTicketCloseR , postTicketFollowR , postTicketUnfollowR @@ -150,6 +151,7 @@ import Vervis.Model.Ticket import Vervis.Model.Workflow import Vervis.Paginate import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Persist.Ticket import Vervis.Recipient @@ -160,6 +162,7 @@ import Vervis.TicketFilter (filterTickets) import Vervis.Time (showDate) import Vervis.Web.Actor import Vervis.Web.Discussion +import Vervis.Widget import Vervis.Widget.Discussion import Vervis.Widget.Person import Vervis.Widget.Tracker @@ -487,6 +490,36 @@ postTicketNewR deckHash = do redirect $ TicketR deckHash taskHash -} +postTicketCloseR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler () +postTicketCloseR deckHash taskHash = do + deckID <- decodeKeyHashid404 deckHash + taskID <- decodeKeyHashid404 taskHash + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + let uTicket = encodeRouteHome $ TicketR deckHash taskHash + result <- runExceptT $ do + (maybeSummary, audience, detail) <- C.resolve personHash uTicket + grantID <- do + maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID + fromMaybeE maybeItem "You need to be a collaborator in the Deck to close tickets" + grantHash <- encodeKeyHashid grantID + let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.ResolveActivity $ AP.Resolve uTicket + let cap = + Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID) + handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect $ TicketR deckHash taskHash + Right resolveID -> do + setMessage "Resolve activity sent" + redirect $ TicketR deckHash taskHash + postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler () postTicketFollowR _ = error "Temporarily disabled" diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 7ffac70..aeeffcc 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -72,7 +72,7 @@ $# . $# ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR deckHash ticketHash)} $nothing Open -$# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR deckHash ticketHash)} + ^{buttonW POST "Close this ticket" (TicketCloseR deckHash ticketHash)}

Custom fields diff --git a/th/routes b/th/routes index f52d89f..861e61a 100644 --- a/th/routes +++ b/th/routes @@ -239,7 +239,7 @@ /decks/#DeckKeyHashid/new-ticket TicketNewR GET POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/edit TicketEditR GET POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/delete TicketDeleteR POST --- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/close TicketCloseR POST +/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/close TicketCloseR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/open TicketOpenR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/claim TicketClaimR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unclaim TicketUnclaimR POST