Remove the HTTP headers from the html module

Given that the headers may be the same, regardless whether it's HTML or JSON
being sent in the body of the response, I think it makes more sense to handle
the headers in the controller.

2 files changed, 151 insertions, 181 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index c245144..18ae16d 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -106,12 +106,12 @@
                                             (derivation_count . ,derivation_count))))
                                        derivations-counts))))))
       (else
-       (apply render-html
-              (view-revision
-               commit-hash
-               packages-count
-               git-repositories-and-branches
-               derivations-counts))))))
+       (render-html
+        #:sxml (view-revision
+                commit-hash
+                packages-count
+                git-repositories-and-branches
+                derivations-counts))))))
 
 (define (texinfo->variants-alist s)
   (let ((stexi (texi-fragment->stexi s)))
@@ -133,12 +133,12 @@
          (render-json
           `((error . "invalid query"))))
         (else
-         (apply render-html
-                (view-revision-packages commit-hash
-                                        query-parameters
-                                        '()
-                                        '()
-                                        #f))))
+         (render-html
+          #:sxml (view-revision-packages commit-hash
+                                         query-parameters
+                                         '()
+                                         '()
+                                         #f))))
 
       (let* ((search-query (assq-ref query-parameters 'search_query))
              (limit-results (assq-ref query-parameters 'limit_results))
@@ -204,12 +204,12 @@
                                    '()))))
                         packages))))))
           (else
-           (apply render-html
-                  (view-revision-packages commit-hash
-                                          query-parameters
-                                          packages
-                                          git-repositories
-                                          show-next-page?)))))))
+           (render-html
+            #:sxml (view-revision-packages commit-hash
+                                           query-parameters
+                                           packages
+                                           git-repositories
+                                           show-next-page?)))))))
 
 (define (render-revision-package mime-types
                                  conn
@@ -251,13 +251,13 @@
                                      (derivation . ,file-name))))
                                 derivations))))))
       (else
-       (apply render-html
-              (view-revision-package-and-version commit-hash
-                                                 name
-                                                 version
-                                                 metadata
-                                                 derivations
-                                                 git-repositories))))))
+       (render-html
+        #:sxml (view-revision-package-and-version commit-hash
+                                                  name
+                                                  version
+                                                  metadata
+                                                  derivations
+                                                  git-repositories))))))
 
 (define (render-compare-unknown-commit mime-types
                                        conn
@@ -272,15 +272,15 @@
      (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))))))
+     (render-html
+      #:sxml (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 mime-types
                         conn
@@ -316,13 +316,13 @@
             (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)))))))
+         (render-html
+          #:sxml (compare base-commit
+                          target-commit
+                          new-packages
+                          removed-packages
+                          version-changes
+                          derivation-changes)))))))
 
 (define (render-compare/derivations mime-types
                                     conn
@@ -346,13 +346,13 @@
          (render-json
           '((error . "invalid query"))))
         (else
-         (apply render-html
-                (compare/derivations
-                 query-parameters
-                 (valid-systems conn)
-                 build-status-strings
-                 '()
-                 '()))))
+         (render-html
+          #:sxml (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))
@@ -393,13 +393,13 @@
                                               (derivations->alist
                                                target-derivations))))))))
               (else
-               (apply render-html
-                      (compare/derivations
-                       query-parameters
-                       (valid-systems conn)
-                       build-status-strings
-                       base-derivations
-                       target-derivations)))))))))
+               (render-html
+                #:sxml (compare/derivations
+                        query-parameters
+                        (valid-systems conn)
+                        build-status-strings
+                        base-derivations
+                        target-derivations)))))))))
 
 (define (render-compare/packages mime-types
                                  conn
@@ -436,12 +436,12 @@
               (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))))))
+       (render-html
+        #:sxml (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
@@ -456,11 +456,11 @@
               (builds (select-builds-with-context-by-derivation-id
                        conn
                        (first derivation))))
-          (apply render-html
-                 (view-derivation derivation
-                                  derivation-inputs
-                                  derivation-outputs
-                                  builds)))
+          (render-html
+           #:sxml (view-derivation derivation
+                                   derivation-inputs
+                                   derivation-outputs
+                                   builds)))
         #f ;; TODO
         )))
 
@@ -470,15 +470,15 @@
       (()
        #f)
       (derivations
-       (apply render-html
-              (view-store-item filename
-                               derivations
-                               (map (lambda (derivation)
-                                      (match derivation
-                                        ((file-name output-id rest ...)
-                                         (select-derivations-using-output
-                                          conn output-id))))
-                                    derivations)))))))
+       (render-html
+        #:sxml (view-store-item filename
+                                derivations
+                                (map (lambda (derivation)
+                                       (match derivation
+                                         ((file-name output-id rest ...)
+                                          (select-derivations-using-output
+                                           conn output-id))))
+                                     derivations)))))))
 
 (define (parse-commit conn)
   (lambda (s)
@@ -502,32 +502,32 @@
 
   (match method-and-path-components
     ((GET)
-     (apply render-html
-            (index
-             (map
-              (lambda (git-repository-details)
-                (cons
-                 git-repository-details
-                 (map
-                  (match-lambda
-                    ((id job-id commit source)
-                     (list id
-                           job-id
-                           commit
-                           source
-                           (git-branches-for-commit conn commit))))
-                  (guix-revisions-and-jobs-for-git-repository
-                   conn
-                   (car git-repository-details)))))
-              (all-git-repositories conn)))))
+     (render-html
+      #:sxml (index
+              (map
+               (lambda (git-repository-details)
+                 (cons
+                  git-repository-details
+                  (map
+                   (match-lambda
+                     ((id job-id commit source)
+                      (list id
+                            job-id
+                            commit
+                            source
+                            (git-branches-for-commit conn commit))))
+                   (guix-revisions-and-jobs-for-git-repository
+                    conn
+                    (car git-repository-details)))))
+               (all-git-repositories conn)))))
     ((GET "builds")
-     (apply render-html
-            (view-builds (select-build-stats conn)
-                         (select-builds-with-context conn))))
+     (render-html
+      #:sxml (view-builds (select-build-stats conn)
+                          (select-builds-with-context conn))))
     ((GET "statistics")
-     (apply render-html
-            (view-statistics (count-guix-revisions conn)
-                             (count-derivations conn))))
+     (render-html
+      #:sxml (view-statistics (count-guix-revisions conn)
+                              (count-derivations conn))))
     ((GET "revision" commit-hash) (render-view-revision mime-types
                                                         conn
                                                         commit-hash))
@@ -556,9 +556,9 @@
                                                           name
                                                           version))
     ((GET "branches")
-     (apply render-html
-            (view-branches
-             (all-branches-with-most-recent-commit conn))))
+     (render-html
+      #:sxml (view-branches
+              (all-branches-with-most-recent-commit conn))))
     ((GET "branch" branch-name)
      (let ((parsed-query-parameters
             (parse-query-parameters
@@ -566,21 +566,20 @@
              `((after_date     ,parse-datetime)
                (before_date    ,parse-datetime)
                (limit_results  ,parse-result-limit #:default 100)))))
-       (apply
-        render-html
-        (if (any-invalid-query-parameters? parsed-query-parameters)
-            (view-branch branch-name parsed-query-parameters '())
-            (view-branch
-             branch-name
-             parsed-query-parameters
-             (most-recent-commits-for-branch
-              conn
-              branch-name
-              #:limit (assq-ref parsed-query-parameters 'limit_results)
-              #:after-date (assq-ref parsed-query-parameters
-                                     'after_date)
-              #:before-date (assq-ref parsed-query-parameters
-                                      'before_date)))))))
+       (render-html
+        #:sxml (if (any-invalid-query-parameters? parsed-query-parameters)
+                   (view-branch branch-name parsed-query-parameters '())
+                   (view-branch
+                    branch-name
+                    parsed-query-parameters
+                    (most-recent-commits-for-branch
+                     conn
+                     branch-name
+                     #:limit (assq-ref parsed-query-parameters 'limit_results)
+                     #:after-date (assq-ref parsed-query-parameters
+                                            'after_date)
+                     #:before-date (assq-ref parsed-query-parameters
+                                             'before_date)))))))
     ((GET "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
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 54ce0b0..1d7a7d0 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -57,44 +57,41 @@
 (define* (layout #:key
                  (head '())
                  (body '())
-                 (title "Guix Data Service")
-                 (extra-headers '()))
-  `(#:sxml ((doctype "html")
-            (html
-             (head
-              (title ,title)
-              (meta (@ (http-equiv "Content-Type")
-                       (content "text/html; charset=UTF-8")))
-              (meta (@ (http-equiv "Content-Language") (content "en")))
-              (meta (@ (name "author") (content "Christopher Baines")))
-              (meta (@ (name "viewport")
-                       (content "width=device-width, initial-scale=1")))
-              (link
-               (@ (rel "stylesheet")
-                  (media "screen")
-                  (type "text/css")
-                  (href "/css/reset.css")))
-              (link
-               (@ (rel "stylesheet")
-                  (media "screen")
-                  (type "text/css")
-                  (href "/css/bootstrap.css")))
-              ,@head
-              (link
-               (@ (rel "stylesheet")
-                  (media "screen")
-                  (type "text/css")
-                  (href "/css/screen.css"))))
-             (body ,@body
-                   (footer
-                    (p "Copyright © 2016—2019 by the GNU Guix community."
-                       (br)
-                       "Now with even more " (span (@ (class "lambda")) "λ") "! ")
-                    (p "This is free software.  Download the "
-                       (a (@ (href "https://git.cbaines.net/guix/data-service/"))
-                          "source code here") ".")))))
-    #:extra-headers ,extra-headers))
-
+                 (title "Guix Data Service"))
+  `((doctype "html")
+    (html
+     (head
+      (title ,title)
+      (meta (@ (http-equiv "Content-Type")
+               (content "text/html; charset=UTF-8")))
+      (meta (@ (http-equiv "Content-Language") (content "en")))
+      (meta (@ (name "author") (content "Christopher Baines")))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1")))
+      (link
+       (@ (rel "stylesheet")
+          (media "screen")
+          (type "text/css")
+          (href "/css/reset.css")))
+      (link
+       (@ (rel "stylesheet")
+          (media "screen")
+          (type "text/css")
+          (href "/css/bootstrap.css")))
+      ,@head
+      (link
+       (@ (rel "stylesheet")
+          (media "screen")
+          (type "text/css")
+          (href "/css/screen.css"))))
+     (body ,@body
+           (footer
+            (p "Copyright © 2016—2019 by the GNU Guix community."
+               (br)
+               "Now with even more " (span (@ (class "lambda")) "λ") "! ")
+            (p "This is free software.  Download the "
+               (a (@ (href "https://git.cbaines.net/guix/data-service/"))
+                  "source code here") "."))))))
 
 (define* (form-horizontal-control label query-parameters
                                   #:key
@@ -202,8 +199,6 @@
 
 (define (index git-repositories-and-revisions)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -290,8 +285,6 @@
 
 (define (view-statistics guix-revisions-count derivations-count)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -315,8 +308,6 @@
                                            package-metadata
                                            derivations git-repositories)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -405,8 +396,6 @@
 (define (view-revision commit-hash packages-count
                        git-repositories-and-branches derivations-count)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -490,8 +479,6 @@
        "Home page" "Location" "Licenses")))
 
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -640,8 +627,6 @@
 
 (define (view-branches branches-with-most-recent-commits)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -683,8 +668,6 @@
 (define (view-branch branch-name query-parameters
                      branch-commits)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -746,8 +729,6 @@
 
 (define (view-builds stats builds)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -858,8 +839,6 @@
 
 (define (view-store-item filename derivations derivations-using-store-item-list)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -902,8 +881,6 @@
 (define (view-derivation derivation derivation-inputs derivation-outputs
                          builds)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -996,8 +973,6 @@
                    "&target_commit=" target-commit))
 
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -1194,8 +1169,6 @@
                              base-derivations
                              target-derivations)
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div
@@ -1322,8 +1295,6 @@
                    "&target_commit=" target-commit))
 
   (layout
-   #:extra-headers
-   '((cache-control . ((max-age . 60))))
    #:body
    `(,(header)
      (div