guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Fix extension handling a bit more 

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
Show Stats 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)
("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)))
(()
(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 (list (string-join first-parts "."))
(or (cons
(or (assoc-ref extensions-to-mime-types extension)
'text/html)
(request-accept request)))))))
(if (ends-with-recognised-extension? single-component)
(match (string-split single-component #\.)
((first-parts ... extension)
(values (list (string-join first-parts "."))
(or (cons
(assoc-ref extensions-to-mime-types extension)
(or (request-accept request)
(list 'text/html)))))))
(values (list single-component)
(or (request-accept request)
(list 'text/html)))))
((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)))))))))
(if (ends-with-recognised-extension? last-component)
(match (string-split last-component #\.)
((first-parts ... extension)
(values (append first-components
(list (string-join first-parts ".")))
(or (cons
(assoc-ref extensions-to-mime-types extension)
(or (request-accept request)
(list 'text/html)))))))
(values (append first-components
(list last-component))
(or (request-accept request)
(list 'text/html)))))))
(define (file-extension file-name)
(last (string-split file-name #\.)))