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.
This commit is contained in:
Pere Lev 2023-11-05 16:13:09 +02:00
parent 222ba823c1
commit cbd81d1d0b
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
8 changed files with 132 additions and 235 deletions

View file

@ -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

View file

@ -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"

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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 <fr33domlover@riseup.net>.
-
- 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"

View file

@ -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)}
<h3>Custom fields

View file

@ -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