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.
2024-12-27 17:44:52 +09:00 · 2023-11-05 16:13:09 +02:00 · 2023-11-05 16:13:09 +02:00 · cbd81d1d0b
commit cbd81d1d0b
parent 222ba823c1
8 changed files with 132 additions and 235 deletions
--- 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
--- 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"
--- 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
-    let audAuthor =
+    -> 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
-                [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]
+                                []
+                                [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]

-        (_, _, _, audLocal, audRemote) =
-            collectAudience $
-                audAuthor :
-                audTicketAuthor :
-                audTicketFollowers :
-                audTicketContext
+    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)

-        recips = map encodeRouteHome audLocal ++ audRemote
-    return (Nothing, Audience recips [] [] [] [] [], Resolve uObject)
-    -}
+    let audAuthor =
+            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)

+        audience = [audAuthor, audTracker, audFollowers]
+
+    return (Nothing, audience, AP.Resolve uObject)
+
+{-
 undoFollow
    :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
    => ShrIdent
--- 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)
--- 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
--- 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 <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"

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

 <h3>Custom fields

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