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).

1 files changed, 49 insertions, 3 deletions

diff --git a/guix-data-service/web/util.scm b/guix-data-service/web/util.scm
index 574b29b..6e1abb7 100644
--- a/guix-data-service/web/util.scm
+++ b/guix-data-service/web/util.scm
@@ -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 #\.)))