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

3 files changed, 163 insertions, 144 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index afe98cb..4142a83 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -78,28 +78,30 @@
        target-commit
        (commit->revision-id conn target-commit))))
 
-(define (render-compare-unknown-commit content-type
+(define (render-compare-unknown-commit mime-types
                                        conn
                                        base-commit
                                        base-revision-id
                                        target-commit
                                        target-revision-id)
-  (cond
-   ((eq? content-type 'json)
-    (render-json
-     '((unknown_commit . #t))))
-   (else
-    (apply render-html
-           (compare-unknown-commit base-commit
-                                   target-commit
-                                   (if base-revision-id #t #f)
-                                   (if target-revision-id #t #f)
-                                   (select-job-for-commit conn
-                                                          base-commit)
-                                   (select-job-for-commit conn
-                                                          target-commit))))))
+  (case (most-appropriate-mime-type
+         '(application/json text/html)
+         mime-types)
+    ((application/json)
+     (render-json
+      '((unknown_commit . #t))))
+    (else
+     (apply render-html
+            (compare-unknown-commit base-commit
+                                    target-commit
+                                    (if base-revision-id #t #f)
+                                    (if target-revision-id #t #f)
+                                    (select-job-for-commit conn
+                                                           base-commit)
+                                    (select-job-for-commit conn
+                                                           target-commit))))))
 
-(define (render-compare content-type
+(define (render-compare mime-types
                         conn
                         base-commit
                         base-revision-id
@@ -123,23 +125,25 @@
            (derivation-changes
             (package-data-derivation-changes base-packages-vhash
                                              target-packages-vhash)))
-      (cond
-       ((eq? content-type 'json)
-        (render-json
-         `((new-packages . ,(list->vector new-packages))
-           (removed-packages . ,(list->vector removed-packages))
-           (version-changes . ,version-changes)
-           (derivation-changes . ,derivation-changes))))
-       (else
-        (apply render-html
-               (compare base-commit
-                        target-commit
-                        new-packages
-                        removed-packages
-                        version-changes
-                        derivation-changes)))))))
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          `((new-packages . ,(list->vector new-packages))
+            (removed-packages . ,(list->vector removed-packages))
+            (version-changes . ,version-changes)
+            (derivation-changes . ,derivation-changes))))
+        (else
+         (apply render-html
+                (compare base-commit
+                         target-commit
+                         new-packages
+                         removed-packages
+                         version-changes
+                         derivation-changes)))))))
 
-(define (render-compare/derivations content-type
+(define (render-compare/derivations mime-types
                                     conn
                                     query-parameters)
   (define (derivations->alist derivations)
@@ -154,18 +158,20 @@
          derivations))
 
   (if (any-invalid-query-parameters? query-parameters)
-      (cond
-       ((eq? content-type 'json)
-        (render-json
-         '((error . "invalid query"))))
-       (else
-        (apply render-html
-               (compare/derivations
-                query-parameters
-                (valid-systems conn)
-                build-status-strings
-                '()
-                '()))))
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          '((error . "invalid query"))))
+        (else
+         (apply render-html
+                (compare/derivations
+                 query-parameters
+                 (valid-systems conn)
+                 build-status-strings
+                 '()
+                 '()))))
 
       (let ((base-commit    (assq-ref query-parameters 'base_commit))
             (target-commit  (assq-ref query-parameters 'target_commit))
@@ -192,27 +198,29 @@
                   systems
                   targets
                   build-statuses)))
-            (cond
-             ((eq? content-type 'json)
-              (render-json
-               `((base . ((commit . ,base-commit)
-                          (derivations . ,(list->vector
-                                           (derivations->alist
-                                            base-derivations)))))
-                 (target . ((commit . ,target-commit)
-                            (derivations . ,(list->vector
-                                             (derivations->alist
-                                              target-derivations))))))))
-             (else
-              (apply render-html
-                     (compare/derivations
-                      query-parameters
-                      (valid-systems conn)
-                      build-status-strings
-                      base-derivations
-                      target-derivations)))))))))
+            (case (most-appropriate-mime-type
+                   '(application/json text/html)
+                   mime-types)
+              ((application/json)
+               (render-json
+                `((base . ((commit . ,base-commit)
+                           (derivations . ,(list->vector
+                                            (derivations->alist
+                                             base-derivations)))))
+                  (target . ((commit . ,target-commit)
+                             (derivations . ,(list->vector
+                                              (derivations->alist
+                                               target-derivations))))))))
+              (else
+               (apply render-html
+                      (compare/derivations
+                       query-parameters
+                       (valid-systems conn)
+                       build-status-strings
+                       base-derivations
+                       target-derivations)))))))))
 
-(define (render-compare/packages content-type
+(define (render-compare/packages mime-types
                                  conn
                                  base-commit
                                  base-revision-id
@@ -233,24 +241,26 @@
          (package-differences-data conn
                                    base-revision-id
                                    target-revision-id))))
-    (cond
-     ((eq? content-type 'json)
-      (render-json
-       `((base
-          . ((commit . ,base-commit)
-             (packages . ,(list->vector
-                           (package-data-vhash->json base-packages-vhash)))))
-         (target
-          . ((commit . ,target-commit)
-             (packages . ,(list->vector
-                           (package-data-vhash->json target-packages-vhash))))))))
-     (else
-      (apply render-html
-             (compare/packages
-              base-commit
-              target-commit
-              base-packages-vhash
-              target-packages-vhash))))))
+    (case (most-appropriate-mime-type
+           '(application/json text/html)
+           mime-types)
+      ((application/json)
+       (render-json
+        `((base
+           . ((commit . ,base-commit)
+              (packages . ,(list->vector
+                            (package-data-vhash->json base-packages-vhash)))))
+          (target
+           . ((commit . ,target-commit)
+              (packages . ,(list->vector
+                            (package-data-vhash->json target-packages-vhash))))))))
+      (else
+       (apply render-html
+              (compare/packages
+               base-commit
+               target-commit
+               base-packages-vhash
+               target-packages-vhash))))))
 
 (define (render-derivation conn derivation-file-name)
   (let ((derivation (select-derivation-by-file-name conn
@@ -302,14 +312,14 @@
 (define (parse-build-status s)
   s)
 
-(define (controller request body conn)
+(define (controller request method-and-path-components mime-types body conn)
   (define query-parameters
     (-> request
         request-uri
         uri-query
         parse-query-string))
 
-  (match-lambda
+  (match method-and-path-components
     ((GET)
      (apply render-html
             (index
@@ -392,38 +402,24 @@
               #:before-date (assq-ref parsed-query-parameters
                                       'before_date)))))))
     ((GET "gnu" "store" filename)
-     (if (string-suffix? ".drv" filename)
-         (render-derivation conn (string-append "/gnu/store/" filename))
-         (render-store-item conn (string-append "/gnu/store/" filename))))
+     ;; These routes are a little special, as the extensions aren't used for
+     ;; content negotiation, so just use the path from the request
+     (let ((path (uri-path (request-uri request))))
+       (if (string-suffix? ".drv" path)
+           (render-derivation conn path)
+           (render-store-item conn path))))
     ((GET "compare")
      (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 'html
+            (render-compare-unknown-commit mime-types
                                            conn
                                            base-commit
                                            base-revision-id
                                            target-commit
                                            target-revision-id)
-            (render-compare 'html
-                            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
+            (render-compare mime-types
                             conn
                             base-commit
                             base-revision-id
@@ -438,19 +434,7 @@
                 (system        ,parse-system #:multi-value)
                 (target        ,parse-system #:multi-value)
                 (build_status  ,parse-build-status #:multi-value)))))
-       (render-compare/derivations 'html
-                                   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
+       (render-compare/derivations mime-types
                                    conn
                                    parsed-query-parameters)))
     ((GET "compare" "packages")
@@ -458,30 +442,13 @@
       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 'html
-                                           conn
-                                           base-commit
-                                           base-revision-id
-                                           target-commit
-                                           target-revision-id)
-            (render-compare/packages 'html
-                                     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
+            (render-compare-unknown-commit mime-types
                                            conn
                                            base-commit
                                            base-revision-id
                                            target-commit
                                            target-revision-id)
-            (render-compare/packages 'json
+            (render-compare/packages mime-types
                                      conn
                                      base-commit
                                      base-revision-id
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index ba27c53..f390da1 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -18,6 +18,7 @@
 
 (define-module (guix-data-service web server)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (web http)
   #:use-module (web request)
   #:use-module (web uri)
@@ -30,9 +31,14 @@
 (define (run-controller controller request body)
   (with-postgresql-connection
    (lambda (conn)
-     ((controller request body conn)
-      (cons (request-method request)
-            (request-path-components request))))))
+     (let-values (((request-components mime-types)
+                   (request->path-components-and-mime-type request)))
+       (controller request
+                   (cons (request-method request)
+                         request-components)
+                   mime-types
+                   body
+                   conn)))))
 
 (define (handler request body controller)
   (format #t "~a ~a\n"
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 #\.)))