From b420c982c0bcaeb5c5b9befb245e991b754cb6f1 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Sun, 5 Nov 2023 20:41:24 +0200
Subject: [PATCH] UI: Add page for publishing a Resolve with custom ticket and
 OCAP URIs

---
 src/Vervis/Client.hs               |  5 ++--
 src/Vervis/Foundation.hs           |  1 +
 src/Vervis/Handler/Client.hs       | 42 ++++++++++++++++++++++++++++++
 src/Vervis/Handler/Ticket.hs       |  3 +--
 templates/personal-overview.hamlet |  3 +++
 th/routes                          |  1 +
 6 files changed, 51 insertions(+), 4 deletions(-)

diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index c17fe8f..d8a4130 100644
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@@ -368,11 +368,12 @@ offerIssue senderHash title desc uTracker = do
     return (Nothing, audience, ticket)
 
 resolve
-    :: KeyHashid Person
+    :: PersonId
     -> FedURI
     -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode)
-resolve senderHash uObject = do
+resolve senderID uObject = do
 
+    senderHash <- encodeKeyHashid senderID
     encodeRouteHome <- getEncodeRouteHome
     (uTracker, audFollowers) <- do
         routeOrRemote <- parseFedURIOld uObject
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 291f812..4963e87 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -854,6 +854,7 @@ instance YesodBreadcrumbs App where
         PublishMergeR      -> ("Apply MR", Just HomeR)
         PublishInviteR     -> ("Invite someone to a resource", Just HomeR)
         PublishRemoveR     -> ("Remove someone from a resource", Just HomeR)
+        PublishResolveR     -> ("Close a ticket", Just HomeR)
 
         PersonR p             -> ("Person ~" <> keyHashidText p, Just HomeR)
         PersonInboxR p        -> ("Inbox", Just $ PersonR p)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index ebc524c..26fe558 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -41,6 +41,9 @@ module Vervis.Handler.Client
 
     , getPublishRemoveR
     , postPublishRemoveR
+
+    , getPublishResolveR
+    , postPublishResolveR
     )
 where
 
@@ -1268,3 +1271,42 @@ postPublishRemoveR = do
         Right _ -> do
             setMessage "Remove activity sent"
             redirect HomeR
+
+resolveForm = renderDivs $ (,)
+    <$> areq fedUriField "(URI) Ticket to close"                         Nothing
+    <*> areq capField    "(URI) Grant activity to use for authorization" Nothing
+
+getPublishResolveR :: Handler Html
+getPublishResolveR = do
+    ((_, widget), enctype) <- runFormPost resolveForm
+    defaultLayout
+        [whamlet|
+            <h1>Close a ticket
+            <form method=POST action=@{PublishResolveR} enctype=#{enctype}>
+              ^{widget}
+              <input type=submit>
+        |]
+
+postPublishResolveR :: Handler ()
+postPublishResolveR = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    (uTicket, (uCap, cap)) <- runFormPostRedirect PublishResolveR resolveForm
+
+    (ep@(Entity pid _), a) <- getSender
+    senderHash <- encodeKeyHashid pid
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, r) <- resolve pid uTicket
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            makeServerInput (Just uCap) maybeSummary audience (AP.ResolveActivity r)
+        handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left err -> do
+            setMessage $ toHtml err
+            redirect PublishResolveR
+        Right _ -> do
+            setMessage "Resolve activity sent"
+            redirect HomeR
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index 5d4c513..f4ed5aa 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -497,11 +497,10 @@ postTicketCloseR deckHash taskHash = do
     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
+        (maybeSummary, audience, detail) <- C.resolve personID 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"
diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet
index 65a4816..d0581de 100644
--- a/templates/personal-overview.hamlet
+++ b/templates/personal-overview.hamlet
@@ -42,6 +42,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 $#   <li>
 $#     <a href=@{PublishCommentR}>
 $#       Comment on a ticket or merge request
+  <li>
+    <a href=@{PublishResolveR}>
+      Close a ticket or MR
   <li>
     <a href=@{PublishMergeR}>
       Merge a merge request
diff --git a/th/routes b/th/routes
index 71d01bc..4d602a3 100644
--- a/th/routes
+++ b/th/routes
@@ -134,6 +134,7 @@
 /publish/merge       PublishMergeR      GET POST
 /publish/invite      PublishInviteR     GET POST
 /publish/remove      PublishRemoveR     GET POST
+/publish/resolve     PublishResolveR    GET POST
 
 ---- Person ------------------------------------------------------------------