Improve the content negotiation handling in general
Previously, the routing layer handled the content negotiation, and the Accept header was ignored. Now, the extension if one is provided in the URL is still used, and more widely than before, but the Accept header is also taken in to account. This all now happens before the routing decisions are made, so the routing is now pretty much extension independant (with the exception of the /gnu/store/... routes).
This commit is contained in:
parent
640fb8a2ad
commit
658a1a20b2
3 changed files with 163 additions and 144 deletions
|
|
@ -78,14 +78,16 @@
|
|||
target-commit
|
||||
(commit->revision-id conn target-commit))))
|
||||
|
||||
(define (render-compare-unknown-commit content-type
|
||||
(define (render-compare-unknown-commit mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((unknown_commit . #t))))
|
||||
(else
|
||||
|
|
@ -99,7 +101,7 @@
|
|||
(select-job-for-commit conn
|
||||
target-commit))))))
|
||||
|
||||
(define (render-compare content-type
|
||||
(define (render-compare mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
|
|
@ -123,8 +125,10 @@
|
|||
(derivation-changes
|
||||
(package-data-derivation-changes base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((new-packages . ,(list->vector new-packages))
|
||||
(removed-packages . ,(list->vector removed-packages))
|
||||
|
|
@ -139,7 +143,7 @@
|
|||
version-changes
|
||||
derivation-changes)))))))
|
||||
|
||||
(define (render-compare/derivations content-type
|
||||
(define (render-compare/derivations mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(define (derivations->alist derivations)
|
||||
|
|
@ -154,8 +158,10 @@
|
|||
derivations))
|
||||
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
|
|
@ -192,8 +198,10 @@
|
|||
systems
|
||||
targets
|
||||
build-statuses)))
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((base . ((commit . ,base-commit)
|
||||
(derivations . ,(list->vector
|
||||
|
|
@ -212,7 +220,7 @@
|
|||
base-derivations
|
||||
target-derivations)))))))))
|
||||
|
||||
(define (render-compare/packages content-type
|
||||
(define (render-compare/packages mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
|
|
@ -233,8 +241,10 @@
|
|||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id))))
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((base
|
||||
. ((commit . ,base-commit)
|
||||
|
|
@ -302,14 +312,14 @@
|
|||
(define (parse-build-status s)
|
||||
s)
|
||||
|
||||
(define (controller request body conn)
|
||||
(define (controller request method-and-path-components mime-types body conn)
|
||||
(define query-parameters
|
||||
(-> request
|
||||
request-uri
|
||||
uri-query
|
||||
parse-query-string))
|
||||
|
||||
(match-lambda
|
||||
(match method-and-path-components
|
||||
((GET)
|
||||
(apply render-html
|
||||
(index
|
||||
|
|
@ -392,38 +402,24 @@
|
|||
#:before-date (assq-ref parsed-query-parameters
|
||||
'before_date)))))))
|
||||
((GET "gnu" "store" filename)
|
||||
(if (string-suffix? ".drv" filename)
|
||||
(render-derivation conn (string-append "/gnu/store/" filename))
|
||||
(render-store-item conn (string-append "/gnu/store/" filename))))
|
||||
;; These routes are a little special, as the extensions aren't used for
|
||||
;; content negotiation, so just use the path from the request
|
||||
(let ((path (uri-path (request-uri request))))
|
||||
(if (string-suffix? ".drv" path)
|
||||
(render-derivation conn path)
|
||||
(render-store-item conn path))))
|
||||
((GET "compare")
|
||||
(with-base-and-target-commits
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'html
|
||||
(render-compare-unknown-commit mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare 'html
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)))))
|
||||
((GET "compare.json")
|
||||
(with-base-and-target-commits
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'json
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare 'json
|
||||
(render-compare mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
|
|
@ -438,19 +434,7 @@
|
|||
(system ,parse-system #:multi-value)
|
||||
(target ,parse-system #:multi-value)
|
||||
(build_status ,parse-build-status #:multi-value)))))
|
||||
(render-compare/derivations 'html
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
((GET "compare" "derivations.json")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)
|
||||
(system ,parse-system #:multi-value)
|
||||
(target ,parse-system #:multi-value)
|
||||
(build_status ,parse-build-status #:multi-value)))))
|
||||
(render-compare/derivations 'json
|
||||
(render-compare/derivations mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
((GET "compare" "packages")
|
||||
|
|
@ -458,30 +442,13 @@
|
|||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'html
|
||||
(render-compare-unknown-commit mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare/packages 'html
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)))))
|
||||
((GET "compare" "packages.json")
|
||||
(with-base-and-target-commits
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'json
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare/packages 'json
|
||||
(render-compare/packages mime-types
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@
|
|||
|
||||
(define-module (guix-data-service web server)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (web http)
|
||||
#:use-module (web request)
|
||||
#:use-module (web uri)
|
||||
|
|
@ -30,9 +31,14 @@
|
|||
(define (run-controller controller request body)
|
||||
(with-postgresql-connection
|
||||
(lambda (conn)
|
||||
((controller request body conn)
|
||||
(let-values (((request-components mime-types)
|
||||
(request->path-components-and-mime-type request)))
|
||||
(controller request
|
||||
(cons (request-method request)
|
||||
(request-path-components request))))))
|
||||
request-components)
|
||||
mime-types
|
||||
body
|
||||
conn)))))
|
||||
|
||||
(define (handler request body controller)
|
||||
(format #t "~a ~a\n"
|
||||
|
|
|
|||
|
|
@ -22,15 +22,61 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (web request)
|
||||
#:use-module (web uri)
|
||||
#:export (request-path-components
|
||||
#:export (most-appropriate-mime-type
|
||||
request->path-components-and-mime-type
|
||||
file-extension
|
||||
directory?
|
||||
|
||||
hyphenate-words
|
||||
underscore-join-words))
|
||||
|
||||
(define (request-path-components request)
|
||||
(split-and-decode-uri-path (uri-path (request-uri request))))
|
||||
(define (most-appropriate-mime-type accepted-mime-types
|
||||
supported-mime-types)
|
||||
(or
|
||||
;; Pick the first supported mime-type
|
||||
(find (lambda (accepted-mime-type)
|
||||
(memq accepted-mime-type
|
||||
supported-mime-types))
|
||||
accepted-mime-types)
|
||||
;; Default to the first supported mime-type if none are accepted
|
||||
(first supported-mime-types)))
|
||||
|
||||
(define (request->path-components-and-mime-type request)
|
||||
(define extensions-to-mime-types
|
||||
'(("json" . application/json)
|
||||
("html" . text/html)))
|
||||
|
||||
(match (split-and-decode-uri-path (uri-path (request-uri request)))
|
||||
(()
|
||||
(values '()
|
||||
(or (request-accept request)
|
||||
(list 'text/html))))
|
||||
((single-component)
|
||||
(match (string-split single-component #\.)
|
||||
((part)
|
||||
(values (list single-component)
|
||||
(or (request-accept request)
|
||||
(list 'text/html))))
|
||||
((first-parts ... extension)
|
||||
(values (string-join first-parts ".")
|
||||
(or (cons
|
||||
(or (assoc-ref extensions-to-mime-types extension)
|
||||
'text/html)
|
||||
(request-accept request)))))))
|
||||
((first-components ... last-component)
|
||||
(match (string-split last-component #\.)
|
||||
((part)
|
||||
(values (append first-components
|
||||
(list part))
|
||||
(or (request-accept request)
|
||||
(list 'text/html))))
|
||||
((first-parts ... extension)
|
||||
(values (append first-components
|
||||
(list (string-join first-parts ".")))
|
||||
(or (cons
|
||||
(or (assoc-ref extensions-to-mime-types extension)
|
||||
'text/html)
|
||||
(request-accept request)))))))))
|
||||
|
||||
(define (file-extension file-name)
|
||||
(last (string-split file-name #\.)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue