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