cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Remove the HTTP headers from the html module

Browse source 
Given that the headers may be the same, regardless whether it's HTML or JSON
being sent in the body of the response, I think it makes more sense to handle
the headers in the controller.
This commit is contained in:
Christopher Baines 2019-05-18 20:08:34 +01:00
parent ed19764bc3
commit 03faff5da0
2 changed files with 151 additions and 181 deletions
Download patch file Download diff file Expand all files Collapse all files

233
guix-data-service/web/controller.scm
View file

@ -106,12 +106,12 @@
(derivation_count . ,derivation_count)))) (derivation_count . ,derivation_count))))
derivations-counts)))))) derivations-counts))))))
(else (else
(apply render-html (render-html
(view-revision #:sxml (view-revision
commit-hash commit-hash
packages-count packages-count
git-repositories-and-branches git-repositories-and-branches
derivations-counts)))))) derivations-counts))))))
(define (texinfo->variants-alist s) (define (texinfo->variants-alist s)
(let ((stexi (texi-fragment->stexi s))) (let ((stexi (texi-fragment->stexi s)))
@ -133,12 +133,12 @@
(render-json (render-json
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(apply render-html (render-html
(view-revision-packages commit-hash #:sxml (view-revision-packages commit-hash
query-parameters query-parameters
'() '()
'() '()
#f)))) #f))))
(let* ((search-query (assq-ref query-parameters 'search_query)) (let* ((search-query (assq-ref query-parameters 'search_query))
(limit-results (assq-ref query-parameters 'limit_results)) (limit-results (assq-ref query-parameters 'limit_results))
@ -204,12 +204,12 @@
'())))) '()))))
packages)))))) packages))))))
(else (else
(apply render-html (render-html
(view-revision-packages commit-hash #:sxml (view-revision-packages commit-hash
query-parameters query-parameters
packages packages
git-repositories git-repositories
show-next-page?))))))) show-next-page?)))))))
(define (render-revision-package mime-types (define (render-revision-package mime-types
conn conn
@ -251,13 +251,13 @@
(derivation . ,file-name)))) (derivation . ,file-name))))
derivations)))))) derivations))))))
(else (else
(apply render-html (render-html
(view-revision-package-and-version commit-hash #:sxml (view-revision-package-and-version commit-hash
name name
version version
metadata metadata
derivations derivations
git-repositories)))))) git-repositories))))))
(define (render-compare-unknown-commit mime-types (define (render-compare-unknown-commit mime-types
conn conn
@ -272,15 +272,15 @@
(render-json (render-json
'((unknown_commit . #t)))) '((unknown_commit . #t))))
(else (else
(apply render-html (render-html
(compare-unknown-commit base-commit #:sxml (compare-unknown-commit base-commit
target-commit target-commit
(if base-revision-id #t #f) (if base-revision-id #t #f)
(if target-revision-id #t #f) (if target-revision-id #t #f)
(select-job-for-commit conn (select-job-for-commit conn
base-commit) base-commit)
(select-job-for-commit conn (select-job-for-commit conn
target-commit)))))) target-commit))))))
(define (render-compare mime-types (define (render-compare mime-types
conn conn
@ -316,13 +316,13 @@
(version-changes . ,version-changes) (version-changes . ,version-changes)
(derivation-changes . ,derivation-changes)))) (derivation-changes . ,derivation-changes))))
(else (else
(apply render-html (render-html
(compare base-commit #:sxml (compare base-commit
target-commit target-commit
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
derivation-changes))))))) derivation-changes)))))))
(define (render-compare/derivations mime-types (define (render-compare/derivations mime-types
conn conn
@ -346,13 +346,13 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(apply render-html (render-html
(compare/derivations #:sxml (compare/derivations
query-parameters query-parameters
(valid-systems conn) (valid-systems conn)
build-status-strings build-status-strings
'() '()
'())))) '()))))
(let ((base-commit (assq-ref query-parameters 'base_commit)) (let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit)) (target-commit (assq-ref query-parameters 'target_commit))
@ -393,13 +393,13 @@
(derivations->alist (derivations->alist
target-derivations)))))))) target-derivations))))))))
(else (else
(apply render-html (render-html
(compare/derivations #:sxml (compare/derivations
query-parameters query-parameters
(valid-systems conn) (valid-systems conn)
build-status-strings build-status-strings
base-derivations base-derivations
target-derivations))))))))) target-derivations)))))))))
(define (render-compare/packages mime-types (define (render-compare/packages mime-types
conn conn
@ -436,12 +436,12 @@
(packages . ,(list->vector (packages . ,(list->vector
(package-data-vhash->json target-packages-vhash)))))))) (package-data-vhash->json target-packages-vhash))))))))
(else (else
(apply render-html (render-html
(compare/packages #:sxml (compare/packages
base-commit base-commit
target-commit target-commit
base-packages-vhash base-packages-vhash
target-packages-vhash)))))) target-packages-vhash))))))
(define (render-derivation conn derivation-file-name) (define (render-derivation conn derivation-file-name)
(let ((derivation (select-derivation-by-file-name conn (let ((derivation (select-derivation-by-file-name conn
@ -456,11 +456,11 @@
(builds (select-builds-with-context-by-derivation-id (builds (select-builds-with-context-by-derivation-id
conn conn
(first derivation)))) (first derivation))))
(apply render-html (render-html
(view-derivation derivation #:sxml (view-derivation derivation
derivation-inputs derivation-inputs
derivation-outputs derivation-outputs
builds))) builds)))
#f ;; TODO #f ;; TODO
))) )))
@ -470,15 +470,15 @@
(() (()
#f) #f)
(derivations (derivations
(apply render-html (render-html
(view-store-item filename #:sxml (view-store-item filename
derivations derivations
(map (lambda (derivation) (map (lambda (derivation)
(match derivation (match derivation
((file-name output-id rest ...) ((file-name output-id rest ...)
(select-derivations-using-output (select-derivations-using-output
conn output-id)))) conn output-id))))
derivations))))))) derivations)))))))
(define (parse-commit conn) (define (parse-commit conn)
(lambda (s) (lambda (s)
@ -502,32 +502,32 @@
(match method-and-path-components (match method-and-path-components
((GET) ((GET)
(apply render-html (render-html
(index #:sxml (index
(map (map
(lambda (git-repository-details) (lambda (git-repository-details)
(cons (cons
git-repository-details git-repository-details
(map (map
(match-lambda (match-lambda
((id job-id commit source) ((id job-id commit source)
(list id (list id
job-id job-id
commit commit
source source
(git-branches-for-commit conn commit)))) (git-branches-for-commit conn commit))))
(guix-revisions-and-jobs-for-git-repository (guix-revisions-and-jobs-for-git-repository
conn conn
(car git-repository-details))))) (car git-repository-details)))))
(all-git-repositories conn))))) (all-git-repositories conn)))))
((GET "builds") ((GET "builds")
(apply render-html (render-html
(view-builds (select-build-stats conn) #:sxml (view-builds (select-build-stats conn)
(select-builds-with-context conn)))) (select-builds-with-context conn))))
((GET "statistics") ((GET "statistics")
(apply render-html (render-html
(view-statistics (count-guix-revisions conn) #:sxml (view-statistics (count-guix-revisions conn)
(count-derivations conn)))) (count-derivations conn))))
((GET "revision" commit-hash) (render-view-revision mime-types ((GET "revision" commit-hash) (render-view-revision mime-types
conn conn
commit-hash)) commit-hash))
@ -556,9 +556,9 @@
name name
version)) version))
((GET "branches") ((GET "branches")
(apply render-html (render-html
(view-branches #:sxml (view-branches
(all-branches-with-most-recent-commit conn)))) (all-branches-with-most-recent-commit conn))))
((GET "branch" branch-name) ((GET "branch" branch-name)
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
@ -566,21 +566,20 @@
`((after_date ,parse-datetime) `((after_date ,parse-datetime)
(before_date ,parse-datetime) (before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100))))) (limit_results ,parse-result-limit #:default 100)))))
(apply (render-html
render-html #:sxml (if (any-invalid-query-parameters? parsed-query-parameters)
(if (any-invalid-query-parameters? parsed-query-parameters) (view-branch branch-name parsed-query-parameters '())
(view-branch branch-name parsed-query-parameters '()) (view-branch
(view-branch branch-name
branch-name parsed-query-parameters
parsed-query-parameters (most-recent-commits-for-branch
(most-recent-commits-for-branch conn
conn branch-name
branch-name #:limit (assq-ref parsed-query-parameters 'limit_results)
#:limit (assq-ref parsed-query-parameters 'limit_results) #:after-date (assq-ref parsed-query-parameters
#:after-date (assq-ref parsed-query-parameters 'after_date)
'after_date) #:before-date (assq-ref parsed-query-parameters
#:before-date (assq-ref parsed-query-parameters 'before_date)))))))
'before_date)))))))
((GET "gnu" "store" filename) ((GET "gnu" "store" filename)
;; These routes are a little special, as the extensions aren't used for ;; These routes are a little special, as the extensions aren't used for
;; content negotiation, so just use the path from the request ;; content negotiation, so just use the path from the request

99
guix-data-service/web/view/html.scm
View file

@ -57,44 +57,41 @@
(define* (layout #:key (define* (layout #:key
(head '()) (head '())
(body '()) (body '())
(title "Guix Data Service") (title "Guix Data Service"))
(extra-headers '())) `((doctype "html")
`(#:sxml ((doctype "html") (html
(html (head
(head (title ,title)
(title ,title) (meta (@ (http-equiv "Content-Type")
(meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
(content "text/html; charset=UTF-8"))) (meta (@ (http-equiv "Content-Language") (content "en")))
(meta (@ (http-equiv "Content-Language") (content "en"))) (meta (@ (name "author") (content "Christopher Baines")))
(meta (@ (name "author") (content "Christopher Baines"))) (meta (@ (name "viewport")
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))
(content "width=device-width, initial-scale=1"))) (link
(link (@ (rel "stylesheet")
(@ (rel "stylesheet") (media "screen")
(media "screen") (type "text/css")
(type "text/css") (href "/css/reset.css")))
(href "/css/reset.css"))) (link
(link (@ (rel "stylesheet")
(@ (rel "stylesheet") (media "screen")
(media "screen") (type "text/css")
(type "text/css") (href "/css/bootstrap.css")))
(href "/css/bootstrap.css"))) ,@head
,@head (link
(link (@ (rel "stylesheet")
(@ (rel "stylesheet") (media "screen")
(media "screen") (type "text/css")
(type "text/css") (href "/css/screen.css"))))
(href "/css/screen.css")))) (body ,@body
(body ,@body (footer
(footer (p "Copyright © 2016—2019 by the GNU Guix community."
(p "Copyright © 2016—2019 by the GNU Guix community." (br)
(br) "Now with even more " (span (@ (class "lambda")) "λ") "! ")
"Now with even more " (span (@ (class "lambda")) "λ") "! ") (p "This is free software. Download the "
(p "This is free software. Download the " (a (@ (href "https://git.cbaines.net/guix/data-service/"))
(a (@ (href "https://git.cbaines.net/guix/data-service/")) "source code here") "."))))))
"source code here") ".")))))
#:extra-headers ,extra-headers))
(define* (form-horizontal-control label query-parameters (define* (form-horizontal-control label query-parameters
#:key #:key
@ -202,8 +199,6 @@
(define (index git-repositories-and-revisions) (define (index git-repositories-and-revisions)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -290,8 +285,6 @@
(define (view-statistics guix-revisions-count derivations-count) (define (view-statistics guix-revisions-count derivations-count)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -315,8 +308,6 @@
package-metadata package-metadata
derivations git-repositories) derivations git-repositories)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -405,8 +396,6 @@
(define (view-revision commit-hash packages-count (define (view-revision commit-hash packages-count
git-repositories-and-branches derivations-count) git-repositories-and-branches derivations-count)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -490,8 +479,6 @@
"Home page" "Location" "Licenses"))) "Home page" "Location" "Licenses")))
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -640,8 +627,6 @@
(define (view-branches branches-with-most-recent-commits) (define (view-branches branches-with-most-recent-commits)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -683,8 +668,6 @@
(define (view-branch branch-name query-parameters (define (view-branch branch-name query-parameters
branch-commits) branch-commits)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -746,8 +729,6 @@
(define (view-builds stats builds) (define (view-builds stats builds)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -858,8 +839,6 @@
(define (view-store-item filename derivations derivations-using-store-item-list) (define (view-store-item filename derivations derivations-using-store-item-list)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -902,8 +881,6 @@
(define (view-derivation derivation derivation-inputs derivation-outputs (define (view-derivation derivation derivation-inputs derivation-outputs
builds) builds)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -996,8 +973,6 @@
"&target_commit=" target-commit)) "&target_commit=" target-commit))
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -1194,8 +1169,6 @@
base-derivations base-derivations
target-derivations) target-derivations)
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div
@ -1322,8 +1295,6 @@
"&target_commit=" target-commit)) "&target_commit=" target-commit))
(layout (layout
#:extra-headers
'((cache-control . ((max-age . 60))))
#:body #:body
`(,(header) `(,(header)
(div (div