From 9b28ec7d152623692877bcb767e5c654e59e57ed Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Sun, 5 Jun 2022 00:07:48 +0200
Subject: Redirect /msgid/ URL to issue URL with message id anchor.

---
 mumi/web/controller.scm |  9 +++++----
 mumi/web/render.scm     | 22 +++++++++++++++++++---
 mumi/web/view/html.scm  |  2 ++
 3 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm
index 10252dd..e8163bb 100644
--- a/mumi/web/controller.scm
+++ b/mumi/web/controller.scm
@@ -132,7 +132,8 @@
     (('GET "msgid" msgid)
      (match (search (format #false "msgid:~a" (string-hash msgid)))
        ((id . rest)
-        (redirect (list "issue" id)))
+        (redirect (list "issue" id)
+                  #:fragment (format #false "msgid-~a" (string-hash msgid))))
        (_ (render-html (unknown msgid)))))
     (('POST "issue" (? string->number id) "comment")
      (if (mailer-enabled?)
@@ -168,9 +169,9 @@
                             (to . ,(format #f "~a@~a"
                                            id (%config 'debbugs-domain)))
                             (text . ,(assoc-ref form-data 'text))))
-                 (redirect (list "issue" id) "comment-ok"))
-               (redirect (list "issue" id) "comment-error")))
-         (redirect (list "issue" id) "comment-error")))
+                 (redirect (list "issue" id) #:query "comment-ok"))
+               (redirect (list "issue" id) #:query "comment-error")))
+         (redirect (list "issue" id) #:query "comment-error")))
     (('GET "issue" (? string->number id)
            "attachment" (? string->number msg-num)
            (? string->number path) ...)
diff --git a/mumi/web/render.scm b/mumi/web/render.scm
index 370a5d4..bbfaf7e 100644
--- a/mumi/web/render.scm
+++ b/mumi/web/render.scm
@@ -25,8 +25,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 binary-ports)
   #:use-module ((ice-9 textual-ports)
-                #:select (get-string-all))
+                #:select (get-string-all put-string))
   #:use-module (ice-9 match)
+  #:use-module (web http)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
@@ -119,11 +120,26 @@
   (list (build-response #:code 201)
         ""))
 
-(define* (redirect path #:optional query (headers '()))
+;; We need to override the writer for Location header values, because
+;; write-uri drops the fragment.  Since we want to be able to redirect
+;; to URLs with a fragment to jump to an anchor we need to replace the
+;; header definition.
+(define (write-uri* uri port)
+  (put-string port (uri->string uri #:include-fragment? #true)))
+
+(declare-header! "Location"
+                 (lambda (str)
+                   (or (string->uri-reference str)
+                       (throw 'bad-header-component 'uri-reference str)))
+                 uri-reference?
+                 write-uri*)
+
+(define* (redirect path #:key query fragment (headers '()))
   (let ((uri (build-relative-ref
               #:path (string-append
                       "/" (encode-and-join-uri-path path))
-              #:query query)))
+              #:query query
+              #:fragment fragment)))
     (list (build-response
            #:code 302
            #:headers (append `((content-type . (text/html))
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 38ff9d8..10bf6c4 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -544,6 +544,8 @@ currently disabled."))
     `((div (@ (class "mb-5"))
            (a (@ (class "message-anchor")
                  (id ,(number->string message-number))))
+           (a (@ (class "message-anchor")
+                 (id ,(format #false "msgid-~a" (string-hash (message-id message))))))
            (div
             (@ (class "avatar")
                (style ,(string-append "background-color:"
-- 
cgit v1.2.3