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

Improve the content negotiation handling in general

Browse source 
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:
Christopher Baines 2019-05-11 22:56:25 +01:00
parent 640fb8a2ad
commit 658a1a20b2
3 changed files with 163 additions and 144 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -78,28 +78,30 @@
target-commit target-commit
(commit->revision-id conn target-commit)))) (commit->revision-id conn target-commit))))
(define (render-compare-unknown-commit content-type (define (render-compare-unknown-commit mime-types
conn conn
base-commit base-commit
base-revision-id base-revision-id
target-commit target-commit
target-revision-id) target-revision-id)
(cond (case (most-appropriate-mime-type
((eq? content-type 'json) '(application/json text/html)
(render-json mime-types)
'((unknown_commit . #t)))) ((application/json)
(else (render-json
(apply render-html '((unknown_commit . #t))))
(compare-unknown-commit base-commit (else
target-commit (apply render-html
(if base-revision-id #t #f) (compare-unknown-commit base-commit
(if target-revision-id #t #f) target-commit
(select-job-for-commit conn (if base-revision-id #t #f)
base-commit) (if target-revision-id #t #f)
(select-job-for-commit conn (select-job-for-commit conn
target-commit)))))) base-commit)
(select-job-for-commit conn
target-commit))))))
(define (render-compare content-type (define (render-compare mime-types
conn conn
base-commit base-commit
base-revision-id base-revision-id
@ -123,23 +125,25 @@
(derivation-changes (derivation-changes
(package-data-derivation-changes base-packages-vhash (package-data-derivation-changes base-packages-vhash
target-packages-vhash))) target-packages-vhash)))
(cond (case (most-appropriate-mime-type
((eq? content-type 'json) '(application/json text/html)
(render-json mime-types)
`((new-packages . ,(list->vector new-packages)) ((application/json)
(removed-packages . ,(list->vector removed-packages)) (render-json
(version-changes . ,version-changes) `((new-packages . ,(list->vector new-packages))
(derivation-changes . ,derivation-changes)))) (removed-packages . ,(list->vector removed-packages))
(else (version-changes . ,version-changes)
(apply render-html (derivation-changes . ,derivation-changes))))
(compare base-commit (else
target-commit (apply render-html
new-packages (compare base-commit
removed-packages target-commit
version-changes new-packages
derivation-changes))))))) removed-packages
version-changes
derivation-changes)))))))
(define (render-compare/derivations content-type (define (render-compare/derivations mime-types
conn conn
query-parameters) query-parameters)
(define (derivations->alist derivations) (define (derivations->alist derivations)
@ -154,18 +158,20 @@
derivations)) derivations))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(cond (case (most-appropriate-mime-type
((eq? content-type 'json) '(application/json text/html)
(render-json mime-types)
'((error . "invalid query")))) ((application/json)
(else (render-json
(apply render-html '((error . "invalid query"))))
(compare/derivations (else
query-parameters (apply render-html
(valid-systems conn) (compare/derivations
build-status-strings query-parameters
'() (valid-systems conn)
'())))) 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))
@ -192,27 +198,29 @@
systems systems
targets targets
build-statuses))) build-statuses)))
(cond (case (most-appropriate-mime-type
((eq? content-type 'json) '(application/json text/html)
(render-json mime-types)
`((base . ((commit . ,base-commit) ((application/json)
(derivations . ,(list->vector (render-json
(derivations->alist `((base . ((commit . ,base-commit)
base-derivations))))) (derivations . ,(list->vector
(target . ((commit . ,target-commit) (derivations->alist
(derivations . ,(list->vector base-derivations)))))
(derivations->alist (target . ((commit . ,target-commit)
target-derivations)))))))) (derivations . ,(list->vector
(else (derivations->alist
(apply render-html target-derivations))))))))
(compare/derivations (else
query-parameters (apply render-html
(valid-systems conn) (compare/derivations
build-status-strings query-parameters
base-derivations (valid-systems conn)
target-derivations))))))))) build-status-strings
base-derivations
target-derivations)))))))))
(define (render-compare/packages content-type (define (render-compare/packages mime-types
conn conn
base-commit base-commit
base-revision-id base-revision-id
@ -233,24 +241,26 @@
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id)))) target-revision-id))))
(cond (case (most-appropriate-mime-type
((eq? content-type 'json) '(application/json text/html)
(render-json mime-types)
`((base ((application/json)
. ((commit . ,base-commit) (render-json
(packages . ,(list->vector `((base
(package-data-vhash->json base-packages-vhash))))) . ((commit . ,base-commit)
(target (packages . ,(list->vector
. ((commit . ,target-commit) (package-data-vhash->json base-packages-vhash)))))
(packages . ,(list->vector (target
(package-data-vhash->json target-packages-vhash)))))))) . ((commit . ,target-commit)
(else (packages . ,(list->vector
(apply render-html (package-data-vhash->json target-packages-vhash))))))))
(compare/packages (else
base-commit (apply render-html
target-commit (compare/packages
base-packages-vhash base-commit
target-packages-vhash)))))) target-commit
base-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
@ -302,14 +312,14 @@
(define (parse-build-status s) (define (parse-build-status s)
s) s)
(define (controller request body conn) (define (controller request method-and-path-components mime-types body conn)
(define query-parameters (define query-parameters
(-> request (-> request
request-uri request-uri
uri-query uri-query
parse-query-string)) parse-query-string))
(match-lambda (match method-and-path-components
((GET) ((GET)
(apply render-html (apply render-html
(index (index
@ -392,38 +402,24 @@
#: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)
(if (string-suffix? ".drv" filename) ;; These routes are a little special, as the extensions aren't used for
(render-derivation conn (string-append "/gnu/store/" filename)) ;; content negotiation, so just use the path from the request
(render-store-item conn (string-append "/gnu/store/" filename)))) (let ((path (uri-path (request-uri request))))
(if (string-suffix? ".drv" path)
(render-derivation conn path)
(render-store-item conn path))))
((GET "compare") ((GET "compare")
(with-base-and-target-commits (with-base-and-target-commits
query-parameters conn query-parameters conn
(lambda (base-commit base-revision-id target-commit target-revision-id) (lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id)) (if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'html (render-compare-unknown-commit mime-types
conn conn
base-commit base-commit
base-revision-id base-revision-id
target-commit target-commit
target-revision-id) target-revision-id)
(render-compare 'html (render-compare mime-types
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
conn conn
base-commit base-commit
base-revision-id base-revision-id
@ -438,19 +434,7 @@
(system ,parse-system #:multi-value) (system ,parse-system #:multi-value)
(target ,parse-system #:multi-value) (target ,parse-system #:multi-value)
(build_status ,parse-build-status #:multi-value))))) (build_status ,parse-build-status #:multi-value)))))
(render-compare/derivations 'html (render-compare/derivations mime-types
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
conn conn
parsed-query-parameters))) parsed-query-parameters)))
((GET "compare" "packages") ((GET "compare" "packages")
@ -458,30 +442,13 @@
query-parameters conn query-parameters conn
(lambda (base-commit base-revision-id target-commit target-revision-id) (lambda (base-commit base-revision-id target-commit target-revision-id)
(if (not (and base-revision-id target-revision-id)) (if (not (and base-revision-id target-revision-id))
(render-compare-unknown-commit 'html (render-compare-unknown-commit mime-types
conn conn
base-commit base-commit
base-revision-id base-revision-id
target-commit target-commit
target-revision-id) target-revision-id)
(render-compare/packages 'html (render-compare/packages mime-types
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
conn conn
base-commit base-commit
base-revision-id base-revision-id

12
guix-data-service/web/server.scm
View file

@ -18,6 +18,7 @@
(define-module (guix-data-service web server) (define-module (guix-data-service web server)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (web http) #:use-module (web http)
#:use-module (web request) #:use-module (web request)
#:use-module (web uri) #:use-module (web uri)
@ -30,9 +31,14 @@
(define (run-controller controller request body) (define (run-controller controller request body)
(with-postgresql-connection (with-postgresql-connection
(lambda (conn) (lambda (conn)
((controller request body conn) (let-values (((request-components mime-types)
(cons (request-method request) (request->path-components-and-mime-type request)))
(request-path-components request)))))) (controller request
(cons (request-method request)
request-components)
mime-types
body
conn)))))
(define (handler request body controller) (define (handler request body controller)
(format #t "~a ~a\n" (format #t "~a ~a\n"

52
guix-data-service/web/util.scm
View file

@ -22,15 +22,61 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (web request) #:use-module (web request)
#:use-module (web uri) #:use-module (web uri)
#:export (request-path-components #:export (most-appropriate-mime-type
request->path-components-and-mime-type
file-extension file-extension
directory? directory?
hyphenate-words hyphenate-words
underscore-join-words)) underscore-join-words))
(define (request-path-components request) (define (most-appropriate-mime-type accepted-mime-types
(split-and-decode-uri-path (uri-path (request-uri request)))) 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) (define (file-extension file-name)
(last (string-split file-name #\.))) (last (string-split file-name #\.)))