diff options
-rw-r--r-- | mumi/web/controller.scm | 47 | ||||
-rw-r--r-- | mumi/web/render.scm | 2 | ||||
-rw-r--r-- | mumi/web/view/html.scm | 100 |
3 files changed, 75 insertions, 74 deletions
diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm index 56b8eaf..4849a9e 100644 --- a/mumi/web/controller.scm +++ b/mumi/web/controller.scm @@ -20,6 +20,7 @@ #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module ((debbugs bug) #:select (bug-archived bug-done)) #:use-module (web request) #:use-module (web uri) #:use-module (webutils sessions) @@ -48,9 +49,11 @@ (define (controller request body) (match-lambda (('GET) - (apply render-html (index))) + (render-html (index) + #:extra-headers + '((cache-control . ((max-age . 60)))))) (('GET "easy") - (apply render-html (list-of-matching-bugs "tag:easy" (easy-bugs)))) + (render-html (list-of-matching-bugs "tag:easy" (easy-bugs)))) (('GET "search") (let ((query (-> request request-uri @@ -74,24 +77,35 @@ ;; Search for matching messages and return list of bug reports ;; that belong to them. (else - (apply render-html - (list-of-matching-bugs query - (match (process-query query) - ((#:terms terms - #:sets s) - (search-bugs (string-join terms) - #:sets s))))))))) + (render-html + (list-of-matching-bugs query + (match (process-query query) + ((#:terms terms + #:sets s) + (search-bugs (string-join terms) + #:sets s))))))))) ((or ('GET "issue" (? string->number id)) ('GET (? string->number id))) - (let ((message (match (uri-query (request-uri request)) + (let ((bug (fetch-bug id)) + (message (match (uri-query (request-uri request)) ("comment-ok" '(info . "Your comment has been submitted!")) ("comment-error" '(error . "There was an error submitting your comment!")) (_ #f)))) - (apply render-html (or (and=> (fetch-bug id) - (lambda (bug) (issue-page bug message))) - (unknown id))))) + (if bug + (let ((headers + (cond + ((bug-archived bug) + ;; Tell browser to cache this for 12 hours. + '((cache-control . ((max-age . 43200))))) + ((bug-done bug) + ;; Tell browser to cache this for 1 hour. + '((cache-control . ((max-age . 3600))))) + (else '())))) + (render-html (issue-page bug message) + #:extra-headers headers)) + (render-html (unknown id))))) (('GET "issue" (? string->number id) "attachment" (? string->number msg-num) (? string->number path) ...) @@ -99,8 +113,11 @@ (string->number msg-num) (map string->number path))) (('GET "issue" not-an-id) - (apply render-html (unknown not-an-id))) + (render-html (unknown not-an-id))) (('GET "help") - (apply render-html (help))) + (render-html (help) + ;; Cache for 24 hours. + #:extra-headers + '((cache-control . ((max-age . 86400)))))) (('GET path ...) (render-static-asset request)))) diff --git a/mumi/web/render.scm b/mumi/web/render.scm index 7f99731..0b4b705 100644 --- a/mumi/web/render.scm +++ b/mumi/web/render.scm @@ -96,7 +96,7 @@ failure)) failure))) -(define* (render-html #:key sxml (extra-headers '())) +(define* (render-html sxml #:key (extra-headers '())) (list (append extra-headers '((content-type . (text/html)))) (lambda (port) diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm index cbc907d..9771dee 100644 --- a/mumi/web/view/html.scm +++ b/mumi/web/view/html.scm @@ -45,50 +45,48 @@ (define* (layout #:key (head '()) (body '()) - (title "Guix issue tracker") - (extra-headers '())) - `(#:sxml ((doctype "html") - (html - (head - (title ,title) - (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8"))) - (meta (@ (http-equiv "Content-Language") (content "en"))) - (meta (@ (name "author") (content "Ricardo Wurmus"))) - (meta (@ (name "viewport") - (content "width=device-width, initial-scale=1"))) - (link - (@ (rel "stylesheet") - (media "screen") - (type "text/css") - (href "/css/reset.css"))) - (link - (@ (rel "stylesheet") - (media "screen") - (type "text/css") - (href "/css/bootstrap.css"))) - ,@head - (link - (@ (rel "stylesheet") - (media "screen") - (type "text/css") - (href "/css/screen.css"))) - (link - (@ (rel "stylesheet") - (media "screen") - (type "text/css") - (href "/css/code.css")))) - (body ,@body - (footer (@ (class "text-center")) - (p "Copyright © 2016—2020 by the GNU Guix community." - (br) - "Now with even more " (span (@ (class "lambda")) "λ") "! ") - (p "This is free software. Download the " - (a (@ (href "https://git.elephly.net/software/mumi.git")) - "source code here") "."))) - (script - (@ (type "text/javascript") - (src "/js/sort-table.js"))))) - #:extra-headers ,extra-headers)) + (title "Guix issue tracker")) + `((doctype "html") + (html + (head + (title ,title) + (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8"))) + (meta (@ (http-equiv "Content-Language") (content "en"))) + (meta (@ (name "author") (content "Ricardo Wurmus"))) + (meta (@ (name "viewport") + (content "width=device-width, initial-scale=1"))) + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/reset.css"))) + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/bootstrap.css"))) + ,@head + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/screen.css"))) + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/code.css")))) + (body ,@body + (footer (@ (class "text-center")) + (p "Copyright © 2016—2020 by the GNU Guix community." + (br) + "Now with even more " (span (@ (class "lambda")) "λ") "! ") + (p "This is free software. Download the " + (a (@ (href "https://git.elephly.net/software/mumi.git")) + "source code here") "."))) + (script + (@ (type "text/javascript") + (src "/js/sort-table.js")))))) (define* (search-form #:key (standalone? #f) (text "")) `(form (@ (id "search") @@ -170,8 +168,6 @@ (define (index) (layout - #:extra-headers - '((cache-control . ((max-age . 60)))) #:body `(,(header #:search-bar? #f) (main @@ -213,9 +209,6 @@ (define (help) (layout - #:extra-headers - ;; Cache for 24 hours. - '((cache-control . ((max-age . 86400)))) #:body `(,(header #:search-bar? #f) (div @@ -354,15 +347,6 @@ some examples.") '()))) (layout #:title (bug-subject* bug) - #:extra-headers - (cond - ((bug-archived bug) - ;; Tell browser to cache this for 12 hours. - '((cache-control . ((max-age . 43200))))) - ((bug-done bug) - ;; Tell browser to cache this for 1 hour. - '((cache-control . ((max-age . 3600))))) - (else '())) #:body `(,(header) (div |