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

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

@ -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 #\.)))