path: root/guix-data-service/web/compare/controller.scm

;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-data-service web compare controller)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (texinfo)
  #:use-module (texinfo html)
  #:use-module (texinfo plain-text)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service web sxml)
  #:use-module (guix-data-service web util)
  #:use-module (guix-data-service web render)
  #:use-module (guix-data-service web query-parameters)
  #:use-module (guix-data-service web controller)
  #:use-module (guix-data-service model utils)
  #:use-module (guix-data-service comparison)
  #:use-module (guix-data-service jobs load-new-guix-revision)
  #:use-module (guix-data-service model guix-revision)
  #:use-module (guix-data-service model system)
  #:use-module (guix-data-service model git-repository)
  #:use-module (guix-data-service model derivation)
  #:use-module (guix-data-service model build-server)
  #:use-module (guix-data-service model build-status)
  #:use-module (guix-data-service model lint-warning-message)
  #:use-module (guix-data-service web compare html)
  #:export (compare-controller))

(define cache-control-default-max-age
  (* 60 60 24)) ; One day

(define http-headers-for-unchanging-content
  `((cache-control
     . (public
        (max-age . ,cache-control-default-max-age)))))

(define (parse-build-status s)
  s)

(define (parse-commit s)
  (with-resource-from-pool (connection-pool) conn
    (let* ((job-details
            (select-job-for-commit conn s))
           (job-state
            (assq-ref job-details 'state)))
      (if job-details
          (cond
           ((string=? job-state "succeeded")
            s)
           ((string=? job-state "queued")
            (make-invalid-query-parameter
             s
             `("data unavailable, "
               (a (@ (href ,(string-append
                             "/revision/" s)))
                  "yet to process revision"))))
           ((string=? job-state "failed")
            (make-invalid-query-parameter
             s
             `("data unavailable, "
               (a (@ (href ,(string-append
                             "/revision/" s)))
                  "failed to process revision"))))
           (else
            (make-invalid-query-parameter
             s "unknown job state")))
          (make-invalid-query-parameter
           s "unknown commit")))))

(define (parse-derivation file-name)
  (if (with-resource-from-pool (connection-pool) conn
        (select-derivation-by-file-name conn file-name))
      file-name
      (make-invalid-query-parameter
       file-name "unknown derivation")))

(define (parse-build-change val)
  (or (if (member val '("broken" "fixed"
                        "still-working"
                        "still-failing"
                        "unknown"))
          val
          #f)
      (make-invalid-query-parameter
       val
       "unknown build change value")))

(define (compare-controller request
                            method-and-path-components
                            mime-types
                            body)
  (match method-and-path-components
    (('GET "compare")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_commit   ,parse-commit #:required)
                (target_commit ,parse-commit #:required)
                (locale        ,identity #:default "en_US.UTF-8")))))
       (render-compare mime-types
                       parsed-query-parameters)))
    (('GET "compare-by-datetime")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_branch     ,identity #:required)
                (base_datetime   ,parse-datetime
                                 #:default ,(current-date))
                (target_branch   ,identity #:required)
                (target_datetime ,parse-datetime
                                 #:default ,(current-date))
                (locale          ,identity #:default "en_US.UTF-8")))))
       (render-compare-by-datetime mime-types
                                   parsed-query-parameters)))
    (('GET "compare" "derivation")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_derivation   ,parse-derivation #:required)
                (target_derivation ,parse-derivation #:required)))))
       (render-compare/derivation mime-types
                                  parsed-query-parameters)))
    (('GET "compare" "package-derivations")
     (let* ((parsed-query-parameters
             (guard-against-mutually-exclusive-query-parameters
              (parse-query-parameters
               request
               `((base_commit   ,parse-commit #:required)
                 (target_commit ,parse-commit #:required)
                 (system        ,parse-system #:multi-value)
                 (target        ,parse-target #:multi-value)
                 (build_status  ,parse-build-status #:multi-value)
                 (build_change  ,parse-build-change)
                 (after_name    ,identity)
                 (limit_results ,parse-result-limit
                                #:no-default-when (all_results)
                                #:default 40)
                 (all_results   ,parse-checkbox-value)))
              '((limit_results all_results)))))

       (render-compare/package-derivations mime-types
                                           parsed-query-parameters)))
    (('GET "compare-by-datetime" "package-derivations")
     (let* ((parsed-query-parameters
             (guard-against-mutually-exclusive-query-parameters
              (parse-query-parameters
               request
               `((base_branch     ,identity #:required)
                 (base_datetime   ,parse-datetime
                                  #:default ,(current-date))
                 (target_branch   ,identity #:required)
                 (target_datetime ,parse-datetime
                                  #:default ,(current-date))
                 (system          ,parse-system #:multi-value)
                 (target          ,parse-target #:multi-value)
                 (build_status    ,parse-build-status #:multi-value)
                 (build_change    ,parse-build-change)
                 (after_name    ,identity)
                 (limit_results ,parse-result-limit
                                #:no-default-when (all_results)
                                #:default 40)
                 (all_results   ,parse-checkbox-value)))
              '((base_commit base_datetime)
                (target_commit target_datetime)
                (limit_results all_results)))))
       (render-compare-by-datetime/package-derivations mime-types
                                                       parsed-query-parameters)))
    (('GET "compare" "packages")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_commit   ,parse-commit #:required)
                (target_commit ,parse-commit #:required)))))
       (render-compare/packages mime-types
                                parsed-query-parameters)))
    (('GET "compare" "system-test-derivations")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_commit   ,parse-commit #:required)
                (target_commit ,parse-commit #:required)
                (system        ,parse-system #:default "x86_64-linux")))))

       (render-compare/system-test-derivations mime-types
                                               parsed-query-parameters)))
    (('GET "compare-by-datetime" "system-test-derivations")
     (let* ((parsed-query-parameters
             (parse-query-parameters
              request
              `((base_branch     ,identity #:required)
                 (base_datetime   ,parse-datetime
                                  #:default ,(current-date))
                 (target_branch   ,identity #:required)
                 (target_datetime ,parse-datetime
                                  #:default ,(current-date))
                 (system        ,parse-system #:default "x86_64-linux")))))

       (render-compare-by-datetime/system-test-derivations
        mime-types
        parsed-query-parameters)))
    (_ #f)))

(define (texinfo->variants-alist s)
  (let ((stexi (texi-fragment->stexi s)))
    `((source . ,s)
      (html   . ,(with-output-to-string
                   (lambda ()
                     (sxml->html (stexi->shtml stexi)))))
      (plain . ,(stexi->plain-text stexi)))))

(define (render-compare mime-types
                        query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (letpar& ((base-job
                 (match (assq-ref query-parameters 'base_commit)
                   (($ <invalid-query-parameter> value)
                    (with-resource-from-pool (connection-pool) conn
                      (and (string? value)
                           (select-job-for-commit conn value))))
                   (_ #f)))
                (target-job
                 (match (assq-ref query-parameters 'target_commit)
                   (($ <invalid-query-parameter> value)
                    (with-resource-from-pool (connection-pool) conn
                      (and (string? value)
                           (select-job-for-commit conn value))))
                   (_ #f))))
        (case (most-appropriate-mime-type
               '(application/json text/html)
               mime-types)
          ((application/json)
           (render-json
            `((error      . "invalid query")
              (query_parameters
               . ,(map
                   (match-lambda
                     ((key . val)
                      (cons key
                            (match val
                              (($ <invalid-query-parameter> value message)
                               `((invalid_value . ,value)
                                 (message       . ,(call-with-output-string
                                                     (lambda (port)
                                                       (sxml->html message port))))))
                              (val val)))))
                   query-parameters))
              (base_job   . ,base-job)
              (target_job . ,target-job))))
          (else
           (render-html
            #:sxml (compare query-parameters
                            'revision
                            #f
                            #f
                            #f
                            #f
                            #f
                            #f
                            #f)))))
      (letpar& ((base-revision-id
                 (with-resource-from-pool (connection-pool) conn
                   (commit->revision-id
                    conn
                    (assq-ref query-parameters 'base_commit))))
                (target-revision-id
                 (with-resource-from-pool (connection-pool) conn
                   (commit->revision-id
                    conn
                    (assq-ref query-parameters 'target_commit))))
                (locale
                 (assq-ref query-parameters 'locale)))
        (let-values
            (((base-packages-vhash target-packages-vhash)
              (package-data->package-data-vhashes
               (with-resource-from-pool (connection-pool) conn
                 (package-differences-data conn
                                           base-revision-id
                                           target-revision-id)))))
          (let ((new-packages
                 (package-data-vhashes->new-packages base-packages-vhash
                                                     target-packages-vhash))
                (removed-packages
                 (package-data-vhashes->removed-packages base-packages-vhash
                                                         target-packages-vhash))
                (version-changes
                 (package-data-version-changes base-packages-vhash
                                               target-packages-vhash)))
            (letpar& ((lint-warnings-data
                       (with-resource-from-pool (connection-pool) conn
                         (group-list-by-first-n-fields
                          2
                          (lint-warning-differences-data conn
                                                         base-revision-id
                                                         target-revision-id
                                                         locale))))
                      (channel-news-data
                       (with-resource-from-pool (connection-pool) conn
                         (channel-news-differences-data conn
                                                        base-revision-id
                                                        target-revision-id))))
              (case (most-appropriate-mime-type
                     '(application/json text/html)
                     mime-types)
                ((application/json)
                 (render-json
                  `((base-commit    . ,(assq-ref query-parameters 'base_commit))
                    (target-commit  . ,(assq-ref query-parameters 'target_commit))
                    (channel-news . ,(list->vector
                                      (map
                                       (match-lambda
                                         ((commit tag title_text body_text change)
                                          `(,@(if (null? commit)
                                                  '()
                                                  `((commit . ,commit)))
                                            ,@(if (null? tag)
                                                  '()
                                                  `((tag . ,tag)))
                                            (title-text
                                             . ,(map
                                                 (match-lambda
                                                   ((lang . text)
                                                    (cons
                                                     lang
                                                     (texinfo->variants-alist text))))
                                                 title_text))
                                            (body-text
                                             . ,(map
                                                 (match-lambda
                                                   ((lang . text)
                                                    (cons
                                                     lang
                                                     (texinfo->variants-alist text))))
                                                 body_text))
                                            (change . ,change))))
                                       channel-news-data)))
                    (new-packages . ,(list->vector new-packages))
                    (removed-packages . ,(list->vector removed-packages))
                    (version-changes . ,(list->vector
                                         (map
                                          (match-lambda
                                            ((name data ...)
                                             `((name . ,name)
                                               ,@data)))
                                          version-changes)))
                    (lint_warnings
                     . ,(list->vector
                         (map
                          (match-lambda
                            (((package-name package-version)
                              . warnings)

                             `((package
                                . ((name . ,package-name)
                                   (version . ,package-version)))
                               (warnings
                                . ,(list->vector
                                    (map
                                     (match-lambda
                                       ((lint-checker-name
                                         message
                                         lint-checker-description
                                         lint-checker-network-dependent
                                         file line column-number
                                         change)

                                        `((change  . ,change)
                                          (checker
                                           . ((name . ,lint-checker-name)
                                              (description
                                               . ,lint-checker-description)))
                                          (message . ,message)
                                          (location
                                           . ((file   . ,file)
                                              (line   . ,(string->number line))
                                              (column . ,(string->number
                                                          column-number)))))))
                                     warnings))))))
                          lint-warnings-data))))
                  #:extra-headers http-headers-for-unchanging-content))
                (else
                 (letpar& ((lint-warnings-locale-options
                            (map
                             (match-lambda
                               ((locale)
                                locale))
                             (with-resource-from-pool (connection-pool) conn
                               (lint-warning-message-locales-for-revision
                                conn
                                (assq-ref query-parameters 'target_commit)))))
                           (cgit-url-bases
                            (with-resource-from-pool (connection-pool) conn
                              (guix-revisions-cgit-url-bases
                               conn
                               (list base-revision-id
                                     target-revision-id)))))
                   (render-html
                    #:sxml (compare query-parameters
                                    'revision
                                    cgit-url-bases
                                    new-packages
                                    removed-packages
                                    version-changes
                                    lint-warnings-data
                                    lint-warnings-locale-options
                                    channel-news-data)
                    #:extra-headers http-headers-for-unchanging-content))))))))))

(define (render-compare-by-datetime mime-types
                                    query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (render-html
          #:sxml (compare query-parameters
                          'datetime
                          #f
                          #f
                          #f
                          #f
                          #f
                          #f
                          #f))))

      (let ((base-branch     (assq-ref query-parameters 'base_branch))
            (base-datetime   (assq-ref query-parameters 'base_datetime))
            (target-branch   (assq-ref query-parameters 'target_branch))
            (target-datetime (assq-ref query-parameters 'target_datetime))
            (locale          (assq-ref query-parameters 'locale)))
        (letpar& ((base-revision-details
                   (with-resource-from-pool (connection-pool) conn
                     (select-guix-revision-for-branch-and-datetime
                      conn
                      base-branch
                      base-datetime)))
                  (target-revision-details
                   (with-resource-from-pool (connection-pool) conn
                     (select-guix-revision-for-branch-and-datetime
                      conn
                      target-branch
                      target-datetime))))
          (let ((lint-warnings-locale-options
                 (map
                  (match-lambda
                    ((locale)
                     locale))
                  (with-resource-from-pool (connection-pool) conn
                    (lint-warning-message-locales-for-revision
                     conn
                     (second base-revision-details))))))
            (let ((base-revision-id
                   (first base-revision-details))
                  (target-revision-id
                   (first target-revision-details)))
              (let-values
                  (((base-packages-vhash target-packages-vhash)
                    (package-data->package-data-vhashes
                      (with-resource-from-pool (connection-pool) conn
                        (package-differences-data conn
                                                  base-revision-id
                                                  target-revision-id)))))
                (let* ((new-packages
                        (package-data-vhashes->new-packages base-packages-vhash
                                                            target-packages-vhash))
                       (removed-packages
                        (package-data-vhashes->removed-packages base-packages-vhash
                                                                target-packages-vhash))
                       (version-changes
                        (package-data-version-changes base-packages-vhash
                                                      target-packages-vhash))
                       (channel-news-data
                        (with-resource-from-pool (connection-pool) conn
                          (channel-news-differences-data conn
                                                         base-revision-id
                                                         target-revision-id))))
                  (case (most-appropriate-mime-type
                         '(application/json text/html)
                         mime-types)
                    ((application/json)
                     (render-json
                      `((revisions
                         . ((base
                             . ((commit . ,(second base-revision-details))
                                (datetime . ,(fourth base-revision-details))))
                            (target
                             . ((commit . ,(second target-revision-details))
                                (datetime . ,(fourth target-revision-details))))))
                        (channel-news . ,(list->vector
                                          (map
                                           (match-lambda
                                             ((commit tag title_text body_text change)
                                              `(,@(if (null? commit)
                                                      '()
                                                      `((commit . ,commit)))
                                                ,@(if (null? tag)
                                                      '()
                                                      `((tag . ,tag)))
                                                (title-text
                                                 . ,(map
                                                     (match-lambda
                                                       ((lang . text)
                                                        (cons
                                                         lang
                                                         (texinfo->variants-alist text))))
                                                     title_text))
                                                (body-text
                                                 . ,(map
                                                     (match-lambda
                                                       ((lang . text)
                                                        (cons
                                                         lang
                                                         (texinfo->variants-alist text))))
                                                     body_text))
                                                (change . ,change))))
                                           channel-news-data)))
                        (new-packages . ,(list->vector new-packages))
                        (removed-packages . ,(list->vector removed-packages))
                        (version-changes . ,(list->vector
                                             (map
                                              (match-lambda
                                                ((name data ...)
                                                 `((name . ,name)
                                                   ,@data)))
                                              version-changes))))
                      #:extra-headers http-headers-for-unchanging-content))
                    (else
                     (render-html
                      #:sxml (compare
                              `(,@query-parameters
                                (base_commit . ,(second base-revision-details))
                                (target_commit . ,(second target-revision-details)))
                              'datetime
                              (with-resource-from-pool (connection-pool) conn
                                (guix-revisions-cgit-url-bases
                                 conn
                                 (list base-revision-id
                                       target-revision-id)))
                              new-packages
                              removed-packages
                              version-changes
                              (group-list-by-first-n-fields
                               2
                               (with-resource-from-pool (connection-pool) conn
                                 (lint-warning-differences-data
                                  conn
                                  base-revision-id
                                  target-revision-id
                                  locale)))
                              lint-warnings-locale-options
                              channel-news-data)
                      #:extra-headers http-headers-for-unchanging-content)))))))))))

(define (render-compare/derivation mime-types
                                   query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (render-html
          #:sxml (compare/derivation
                  query-parameters
                  '()))))

      (let ((base-derivation    (assq-ref query-parameters 'base_derivation))
            (target-derivation  (assq-ref query-parameters 'target_derivation)))
        (let ((data
               (with-resource-from-pool (connection-pool) conn
                 (derivation-differences-data conn
                                              base-derivation
                                              target-derivation))))
          (case (most-appropriate-mime-type
                 '(application/json text/html)
                 mime-types)
            ((application/json)
             (render-json
              `((base                  . ((derivation . ,base-derivation)))
                (target                . ((derivation . ,target-derivation)))
                (outputs               . ,(assq-ref data 'outputs))
                (inputs                . ,(assq-ref data 'inputs))
                (sources               . ,(assq-ref data 'sources))
                (system                . ,(assq-ref data 'system))
                (builder               . ,(assq-ref data 'builder))
                (arguments             . ,(assq-ref data 'arguments))
                (environment-variables . ,(assq-ref
                                           data 'environment-variables)))
              #:extra-headers http-headers-for-unchanging-content))
            (else
             (render-html
              #:sxml (compare/derivation
                      query-parameters
                      data)
              #:extra-headers http-headers-for-unchanging-content)))))))

(define (render-compare/package-derivations mime-types
                                            query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (letpar& ((base-job
                    (and=> (match (assq-ref query-parameters 'base_commit)
                             (($ <invalid-query-parameter> value)
                              (and (string? value) value))
                             ((? string? value) value)
                             (_ #f))
                           (lambda (commit)
                             (with-resource-from-pool (connection-pool) conn
                               (select-job-for-commit conn commit)))))
                   (target-job
                    (and=> (match (assq-ref query-parameters 'target_commit)
                             (($ <invalid-query-parameter> value)
                              (and (string? value) value))
                             ((? string? value) value)
                             (_ #f))
                           (lambda (commit)
                             (with-resource-from-pool (connection-pool) conn
                               (select-job-for-commit conn commit))))))
           (render-json
            `((error . "invalid query")
              (query_parameters
               .
               ,(map
                 (match-lambda
                   ((key . val)
                    (cons key
                          (match val
                            (($ <invalid-query-parameter> value message)
                             `((invalid_value . ,value)
                               (message       . ,(call-with-output-string
                                                   (lambda (port)
                                                     (sxml->html message port))))))
                            ((? list? val)
                             (list->vector val))
                            (val val)))))
                 query-parameters))
              (base_job   . ,base-job)
              (target_job . ,target-job)))))
        (else
         (letpar& ((systems
                    (call-with-resource-from-pool (connection-pool)
                      list-systems))
                   (targets
                    (call-with-resource-from-pool (connection-pool)
                      valid-targets))
                   (build-server-urls
                    (call-with-resource-from-pool (connection-pool)
                      select-build-server-urls-by-id)))
         (render-html
          #:sxml (compare/package-derivations
                  query-parameters
                  'revision
                  systems
                  (valid-targets->options targets)
                  build-status-strings
                  build-server-urls
                  '())))))

      (let ((base-commit    (assq-ref query-parameters 'base_commit))
            (target-commit  (assq-ref query-parameters 'target_commit))
            (systems        (assq-ref query-parameters 'system))
            (targets        (assq-ref query-parameters 'target))
            (build-change   (and=>
                             (assq-ref query-parameters 'build_change)
                             string->symbol))
            (after-name     (assq-ref query-parameters 'after_name))
            (limit-results  (assq-ref query-parameters 'limit_results)))
        (letpar& ((data
                   (with-resource-from-pool (connection-pool) conn
                     (package-derivation-differences-data
                      conn
                      (commit->revision-id conn base-commit)
                      (commit->revision-id conn target-commit)
                      #:systems systems
                      #:targets targets
                      #:build-change build-change
                      #:after-name after-name
                      #:limit-results limit-results)))
                  (build-server-urls
                   (with-resource-from-pool (connection-pool) conn
                    select-build-server-urls-by-id)))
          (let ((names-and-versions
                 (package-derivation-data->names-and-versions data)))
            (let-values
                (((base-packages-vhash target-packages-vhash)
                  (package-derivation-data->package-derivation-data-vhashes data)))
              (let ((derivation-changes
                     (package-derivation-data-changes names-and-versions
                                                      base-packages-vhash
                                                      target-packages-vhash)))
                (case (most-appropriate-mime-type
                       '(application/json text/html)
                       mime-types)
                  ((application/json)
                   (render-json
                    `((revisions
                       . ((base
                           . ((commit . ,base-commit)))
                          (target
                           . ((commit . ,target-commit)))))
                      (derivation_changes
                       . ,derivation-changes))))
                  (else
                   (letpar& ((systems
                              (call-with-resource-from-pool (connection-pool)
                                list-systems))
                             (targets
                              (call-with-resource-from-pool (connection-pool)
                                valid-targets)))
                     (render-html
                      #:sxml (compare/package-derivations
                              query-parameters
                              'revision
                              systems
                              (valid-targets->options targets)
                              build-status-strings
                              build-server-urls
                              derivation-changes))))))))))))

(define (render-compare-by-datetime/package-derivations mime-types
                                                        query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (render-html
          #:sxml (compare/package-derivations
                  query-parameters
                  'datetime
                  (call-with-resource-from-pool (connection-pool)
                    list-systems)
                  (valid-targets->options
                   (call-with-resource-from-pool (connection-pool)
                     valid-targets))
                  build-status-strings
                  '()
                  '()
                  '()))))

      (let ((base-branch     (assq-ref query-parameters 'base_branch))
            (base-datetime   (assq-ref query-parameters 'base_datetime))
            (target-branch   (assq-ref query-parameters 'target_branch))
            (target-datetime (assq-ref query-parameters 'target_datetime))
            (systems         (assq-ref query-parameters 'system))
            (targets         (assq-ref query-parameters 'target))
            (build-change    (and=>
                              (assq-ref query-parameters 'build_change)
                              string->symbol))
            (after-name     (assq-ref query-parameters 'after_name))
            (limit-results  (assq-ref query-parameters 'limit_results)))
        (letpar&
            ((base-revision-details
              (with-resource-from-pool (connection-pool) conn
                (select-guix-revision-for-branch-and-datetime conn
                                                              base-branch
                                                              base-datetime)))
             (target-revision-details
              (with-resource-from-pool (connection-pool) conn
                (select-guix-revision-for-branch-and-datetime conn
                                                              target-branch
                                                              target-datetime))))
          (letpar&
              ((data
                (with-resource-from-pool (connection-pool) conn
                  (package-derivation-differences-data
                   conn
                   (first base-revision-details)
                   (first target-revision-details)
                   #:systems systems
                   #:targets targets
                   #:build-change build-change
                   #:after-name after-name
                   #:limit-results limit-results))))
            (let ((names-and-versions
                   (package-derivation-data->names-and-versions data)))
              (let-values
                  (((base-packages-vhash target-packages-vhash)
                    (package-derivation-data->package-derivation-data-vhashes data)))
                (let ((derivation-changes
                       (package-derivation-data-changes names-and-versions
                                                        base-packages-vhash
                                                        target-packages-vhash)))
                  (case (most-appropriate-mime-type
                         '(application/json text/html)
                         mime-types)
                    ((application/json)
                     (render-json
                      `((revisions
                         . ((base
                             . ((commit . ,(second base-revision-details))
                                (datetime . ,(fourth base-revision-details))))
                            (target
                             . ((commit . ,(second target-revision-details))
                                (datetime . ,(fourth target-revision-details))))))
                        (derivation_changes
                         . ,derivation-changes))))
                    (else
                     (render-html
                      #:sxml (compare/package-derivations
                              query-parameters
                              'datetime
                              (call-with-resource-from-pool
                               (connection-pool)
                               list-systems)
                              (valid-targets->options
                               (call-with-resource-from-pool
                                (connection-pool)
                                valid-targets))
                              build-status-strings
                              (call-with-resource-from-pool
                               (connection-pool)
                               select-build-server-urls-by-id)
                              derivation-changes
                              base-revision-details
                              target-revision-details))))))))))))

(define (render-compare/packages mime-types
                                 query-parameters)
  (define (package-data-vhash->json vh)
    (delete-duplicates
     (vhash-fold (lambda (name data result)
                   (cons `((name . ,name)
                           (version . ,(car data)))
                         result))
                 '()
                 vh)))

  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (letpar& ((base-job
                    (match (assq-ref query-parameters 'base_commit)
                      (($ <invalid-query-parameter> value)
                       (with-resource-from-pool (connection-pool) conn
                         (select-job-for-commit conn value)))
                      (_ #f)))
                   (target-job
                    (match (assq-ref query-parameters 'target_commit)
                      (($ <invalid-query-parameter> value)
                       (with-resource-from-pool (connection-pool) conn
                         (select-job-for-commit conn value)))
                      (_ #f))))
         (render-html
          #:sxml (compare-invalid-parameters
                  query-parameters
                  base-job
                  target-job)))))

      (let ((base-commit    (assq-ref query-parameters 'base_commit))
            (target-commit  (assq-ref query-parameters 'target_commit)))
        (letpar& ((base-revision-id
                   (with-resource-from-pool (connection-pool) conn
                     (commit->revision-id
                      conn
                      base-commit)))
                  (target-revision-id
                   (with-resource-from-pool (connection-pool) conn
                     (commit->revision-id
                      conn
                      target-commit))))
          (let-values
              (((base-packages-vhash target-packages-vhash)
                (package-data->package-data-vhashes
                 (with-resource-from-pool (connection-pool) conn
                   (package-differences-data conn
                                             base-revision-id
                                             target-revision-id)))))
            (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))))))
                #:extra-headers http-headers-for-unchanging-content))
              (else
               (render-html
                #:sxml (compare/packages
                        query-parameters
                        base-packages-vhash
                        target-packages-vhash)
                #:extra-headers http-headers-for-unchanging-content))))))))

(define (render-compare/system-test-derivations mime-types
                                                query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (letpar& ((systems
                    (with-resource-from-pool (connection-pool) conn
                     list-systems))
                   (build-server-urls
                    (with-resource-from-pool (connection-pool) conn
                     select-build-server-urls-by-id)))
         (render-html
          #:sxml (compare/system-test-derivations
                  query-parameters
                  'revision
                  systems
                  build-server-urls
                  '()
                  '()
                  '())))))

      (let ((base-commit    (assq-ref query-parameters 'base_commit))
            (target-commit  (assq-ref query-parameters 'target_commit))
            (system         (assq-ref query-parameters 'system)))
        (letpar& ((data
                   (with-resource-from-pool (connection-pool) conn
                     (system-test-derivations-differences-data
                      conn
                      (commit->revision-id conn base-commit)
                      (commit->revision-id conn target-commit)
                      system)))
                  (build-server-urls
                   (with-resource-from-pool (connection-pool) conn
                    select-build-server-urls-by-id))
                  (base-git-repositories
                   (with-resource-from-pool (connection-pool) conn
                     (git-repositories-containing-commit conn base-commit)))
                  (target-git-repositories
                   (with-resource-from-pool (connection-pool) conn
                     (git-repositories-containing-commit conn target-commit)))
                  (systems
                   (with-resource-from-pool (connection-pool) conn
                    list-systems)))
          (case (most-appropriate-mime-type
                 '(application/json text/html)
                 mime-types)
            ((application/json)
             (render-json
              `((revisions
                 . ((base
                     . ((commit . ,base-commit)))
                    (target
                     . ((commit . ,target-commit)))))
                (changes . ,(list->vector data)))))
            (else
             (render-html
              #:sxml (compare/system-test-derivations
                      query-parameters
                      'revision
                      systems
                      build-server-urls
                      base-git-repositories
                      target-git-repositories
                      data))))))))

(define (render-compare-by-datetime/system-test-derivations mime-types
                                                            query-parameters)
  (if (any-invalid-query-parameters? query-parameters)
      (case (most-appropriate-mime-type
             '(application/json text/html)
             mime-types)
        ((application/json)
         (render-json
          '((error . "invalid query"))))
        (else
         (letpar& ((systems
                    (with-resource-from-pool (connection-pool) conn
                     list-systems))
                   (build-server-urls
                    (with-resource-from-pool (connection-pool) conn
                     select-build-server-urls-by-id)))
         (render-html
          #:sxml (compare/system-test-derivations
                  query-parameters
                  'datetime
                  systems
                  build-server-urls
                  '()
                  '()
                  '())))))

      (let ((base-branch     (assq-ref query-parameters 'base_branch))
            (base-datetime   (assq-ref query-parameters 'base_datetime))
            (target-branch   (assq-ref query-parameters 'target_branch))
            (target-datetime (assq-ref query-parameters 'target_datetime))
            (system         (assq-ref query-parameters 'system)))
        (letpar&
            ((base-revision-details
              (with-resource-from-pool (connection-pool) conn
                (select-guix-revision-for-branch-and-datetime conn
                                                              base-branch
                                                              base-datetime)))
             (target-revision-details
              (with-resource-from-pool (connection-pool) conn
                (select-guix-revision-for-branch-and-datetime conn
                                                              target-branch
                                                              target-datetime))))
          (letpar& ((data
                     (with-resource-from-pool (connection-pool) conn
                       (system-test-derivations-differences-data
                        conn
                        (first base-revision-details)
                        (first target-revision-details)
                        system)))
                    (build-server-urls
                     (with-resource-from-pool (connection-pool) conn
                      select-build-server-urls-by-id))
                    (base-git-repositories
                     (with-resource-from-pool (connection-pool) conn
                       (git-repositories-containing-commit
                        conn
                        (second base-revision-details))))
                    (target-git-repositories
                     (with-resource-from-pool (connection-pool) conn
                       (git-repositories-containing-commit
                        conn
                        (second target-revision-details))))
                    (systems
                     (with-resource-from-pool (connection-pool) conn
                      list-systems)))
            (case (most-appropriate-mime-type
                   '(application/json text/html)
                   mime-types)
              ((application/json)
               (render-json
                `((revisions
                   . ((base
                       . ((commit . ,(second base-revision-details))
                          (datetime . ,(fourth base-revision-details))))
                      (target
                       . ((commit . ,(second target-revision-details))
                          (datetime . ,(fourth target-revision-details))))))
                  (changes . ,(list->vector data)))))
              (else
               (render-html
                #:sxml (compare/system-test-derivations
                        query-parameters
                        'datetime
                        systems
                        build-server-urls
                        base-git-repositories
                        target-git-repositories
                        data
                        base-revision-details
                        target-revision-details)))))))))