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

Fix extension handling a bit more

Browse source 
Previously, it was spliting versions up for the package pages. To stop this,
now it just matches the extensions it knows about (currently .html and .json).
This commit is contained in:
Christopher Baines 2019-05-12 09:32:58 +01:00
parent b15c8f706e
commit bd8b9f951c
1 changed files with 30 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -46,37 +46,43 @@
'(("json" . application/json) '(("json" . application/json)
("html" . text/html))) ("html" . text/html)))
(define (ends-with-recognised-extension? path)
(any (lambda (extension)
(string-suffix? (string-append "." extension)
path))
(map car extensions-to-mime-types)))
(match (split-and-decode-uri-path (uri-path (request-uri request))) (match (split-and-decode-uri-path (uri-path (request-uri request)))
(() (()
(values '() (values '()
(or (request-accept request) (or (request-accept request)
(list 'text/html)))) (list 'text/html))))
((single-component) ((single-component)
(match (string-split single-component #\.) (if (ends-with-recognised-extension? single-component)
((part) (match (string-split single-component #\.)
(values (list single-component) ((first-parts ... extension)
(or (request-accept request) (values (list (string-join first-parts "."))
(list 'text/html)))) (or (cons
((first-parts ... extension) (assoc-ref extensions-to-mime-types extension)
(values (list (string-join first-parts ".")) (or (request-accept request)
(or (cons (list 'text/html)))))))
(or (assoc-ref extensions-to-mime-types extension) (values (list single-component)
'text/html) (or (request-accept request)
(request-accept request))))))) (list 'text/html)))))
((first-components ... last-component) ((first-components ... last-component)
(match (string-split last-component #\.) (if (ends-with-recognised-extension? last-component)
((part) (match (string-split last-component #\.)
(values (append first-components ((first-parts ... extension)
(list part)) (values (append first-components
(or (request-accept request) (list (string-join first-parts ".")))
(list 'text/html)))) (or (cons
((first-parts ... extension) (assoc-ref extensions-to-mime-types extension)
(values (append first-components (or (request-accept request)
(list (string-join first-parts "."))) (list 'text/html)))))))
(or (cons (values (append first-components
(or (assoc-ref extensions-to-mime-types extension) (list last-component))
'text/html) (or (request-accept request)
(request-accept request))))))))) (list 'text/html)))))))
(define (file-extension file-name) (define (file-extension file-name)
(last (string-split file-name #\.))) (last (string-split file-name #\.)))