diff options
| author | Ricardo Wurmus <rekado@elephly.net> | 2022-06-05 00:07:48 +0200 |
|---|---|---|
| committer | Ricardo Wurmus <rekado@elephly.net> | 2022-06-05 00:07:48 +0200 |
| commit | 9b28ec7d152623692877bcb767e5c654e59e57ed (patch) | |
| tree | 2bb7fd511904714fb470f11ebdcc730129eb174b | |
| parent | e4423e4ed866bacf836aa9ebea16ed162c61c1e6 (diff) | |
Redirect /msgid/ URL to issue URL with message id anchor.
| -rw-r--r-- | mumi/web/controller.scm | 9 | ||||
| -rw-r--r-- | mumi/web/render.scm | 22 | ||||
| -rw-r--r-- | 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:" |