;;; 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 html)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (texinfo)
  #:use-module (texinfo html)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service web query-parameters)
  #:use-module (guix-data-service web util)
  #:use-module (guix-data-service web html-utils)
  #:use-module (guix-data-service web view html)
  #:export (compare
            compare/derivation
            compare/package-derivations
            compare-by-datetime/package-derivations
            compare/packages
            compare/system-test-derivations
            compare-invalid-parameters))

(define (compare-form-controls-for-mode mode query-parameters)
  (cond
   ((eq? mode 'revision)
    (list
     (form-horizontal-control
      "Base commit" query-parameters
      #:required? #t
      #:help-text "The commit to use as the basis for the comparison."
      #:font-family "monospace")
     (form-horizontal-control
      "Target commit" query-parameters
      #:required? #t
      #:help-text "The commit to compare against the base commit."
      #:font-family "monospace")))
   ((eq? mode 'datetime)
    (list
     (form-horizontal-control
      "Base branch" query-parameters
      #:required? #t
      #:help-text "The branch to compare from."
      #:font-family "monospace")
     (form-horizontal-control
      "Base datetime" query-parameters
      #:help-text "The date and time to compare from. The required format is YYYY-MM-DD HH:MM:SS"
      #:font-family "monospace")
     (form-horizontal-control
      "Target branch" query-parameters
      #:required? #t
      #:help-text "The branch to compare to."
      #:font-family "monospace")
     (form-horizontal-control
      "Target datetime" query-parameters
      #:help-text "The date and time to compare to. The required format is YYYY-MM-DD HH:MM:SS"
      #:font-family "monospace")))
   (else
    '())))

(define (compare query-parameters
                 mode
                 cgit-url-bases
                 new-packages
                 removed-packages
                 version-changes
                 lint-warnings-data
                 lint-warnings-locale-options
                 channel-news-data)
  (define invalid-query?
    (any-invalid-query-parameters? query-parameters))

  (define base-commit
    (assq-ref query-parameters 'base_commit))

  (define target-commit
    (assq-ref query-parameters 'target_commit))

  (define locale
    (assq-ref query-parameters 'locale))

  (define query-params
    (unless invalid-query?
      (query-parameters->string query-parameters)))

  (layout
   #:title
   (if invalid-query?
       "Compare"
       (string-append "Comparing " (string-take base-commit 8) " and "
                      (string-take target-commit 8)))
   #:body
   `(,(header)
     (div
      (@ (class "container"))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-7"))
        ,@(if invalid-query?
              `((h1 "Compare"))
              `((h1 "Comparing "
                    (a (@ (href ,(string-append "/revision/" base-commit)))
                       (samp ,(string-take base-commit 8) "…"))
                    " and "
                    (a (@ (href ,(string-append "/revision/" target-commit)))
                       (samp ,(string-take target-commit 8) "…")))
                ,@(if (apply string=? cgit-url-bases)
                      `((a (@ (href ,(string-append
                                      (first cgit-url-bases)
                                      "log/?qt=range&q="
                                      base-commit ".." target-commit)))
                           "(View cgit)"))
                      '()))))
       (div
        (@ (class "col-sm-5"))
        (div
         (@ (class "btn-group btn-group-lg")
            (style "margin-top: 1.3rem; margin-bottom: 0.5rem;")
            (role "group"))
         (a (@ (class ,(string-append
                        "btn btn-default btn-lg"
                        (if (eq? mode 'revision)
                            " disabled"
                            "")))
               (href "/compare"))
            "Compare revisions")
         (a (@ (class ,(string-append
                        "btn btn-default btn-lg"
                        (if (eq? mode 'datetime)
                            " disabled"
                            "")))
               (href "/compare-by-datetime"))
            "Compare by datetime"))))

      (div
         (@ (class "row"))
         (div
          (@ (class "col-md-12"))
          (div
           (@ (class "well"))
           (form
            (@ (method "get")
               (action "")
               (style "padding-bottom: 0")
               (class "form-horizontal"))
            ,@(compare-form-controls-for-mode mode query-parameters)
            ,(form-horizontal-control
              "Locale" query-parameters
              #:name "locale"
              #:allow-selecting-multiple-options #f
              #:options lint-warnings-locale-options
              #:help-text "Language")
            (div (@ (class "form-group form-group-lg"))
                 (div (@ (class "col-sm-offset-2 col-sm-10"))
                      (button (@ (type "submit")
                                 (class "btn btn-lg btn-primary"))
                              "Update results")))))))

      ,@(if
         invalid-query?
         '()
         `((div
            (@ (class "row") (style "clear: left;"))
            (div
             (@ (class "col-sm-10"))
             (div
              (@ (class "btn-group btn-group-lg")
                 (role "group"))
              (a (@ (class "btn btn-default")
                    (href ,(string-append
                            "/"
                            (cond
                             ((eq? mode 'revision) "compare")
                             ((eq? mode 'datetime) "compare-by-datetime"))
                            "/packages?"
                            query-params)))
                 "Compare packages")
              (a (@ (class "btn btn-default")
                    (href ,(string-append
                            "/"
                            (cond
                             ((eq? mode 'revision) "compare")
                             ((eq? mode 'datetime) "compare-by-datetime"))
                            "/package-derivations?"
                            query-params)))
                 "Compare package derivations")
             (a (@ (class "btn btn-default")
                   (href ,(string-append
                           "/"
                           (cond
                            ((eq? mode 'revision) "compare")
                            ((eq? mode 'datetime) "compare-by-datetime"))
                           "/system-test-derivations?"
                           query-params)))
                "Compare system test derivations")))
            (div
             (@ (class "col-sm-2"))
             (a (@ (class "btn btn-default btn-lg pull-right")
                   (href ,(string-append
                           "/compare.json?" query-params)))
                "View JSON")))
           (div
            (@ (class "row"))
            (div
             (@ (class "col-sm-12"))
             (h3 (@ (style "clear: both;"))
                 "News entries")
             ,(if (null? channel-news-data)
                  "No news entry changes"
                  (map
                   (match-lambda
                     ((commit tag title-text body-text change)
                      `(div
                        (h4 ,@(if (null? commit)
                                  '()
                                  `(("Commit: " (samp ,commit))))
                            ,@(if (null? tag)
                                  '()
                                  `(("Tag: " ,tag))))
                        (table
                         (@ (class "table"))
                         (thead
                          (tr
                           (th (@ (class "col-sm-1")) "")
                           (th (@ (class "col-sm-1")) "Language")
                           (th (@ (class "col-sm-3")) "Title")
                           (th (@ (class "col-sm-7")) "Body"))
                          (tbody
                           ,@(let ((languages
                                    (sort
                                     (delete-duplicates
                                      (append (map car title-text)
                                              (map car body-text)))
                                     string<?)))
                               (map (lambda (lang index)
                                      `(tr
                                        ,@(if (eq? index 0)
                                              `((td (@ (rowspan ,(length languages)))
                                                    ,(case change
                                                       ((new) "New")
                                                       ((removed) "Removed")
                                                       ((changed) "Changed"))))
                                              '())
                                        (td ,lang)
                                        (td ,(stexi->shtml
                                              (texi-fragment->stexi
                                               (assoc-ref title-text lang))))
                                        (td ,
                                         (stexi->shtml
                                          (texi-fragment->stexi
                                           (assoc-ref body-text lang))))))
                                    languages
                                    (iota (length languages))))))))))
                   channel-news-data))))
           (div
            (@ (class "row"))
            (div
             (@ (class "col-sm-12"))
             (h3 "New packages")
             ,(if (null? new-packages)
                  '(p "No new packages")
                  `(table
                    (@ (class "table"))
                    (thead
                     (tr
                      (th (@ (class "col-md-4")) "Name")
                      (th (@ (class "col-md-4")) "Version")
                      (th (@ (class "col-md-4")) "")))
                    (tbody
                     ,@(map
                        (match-lambda
                          ((('name . name)
                            ('version . version))
                           `(tr
                             (td ,name)
                             (td ,version)
                             (td (@ (class "text-right"))
                                 (a (@ (href ,(string-append
                                               "/revision/" target-commit
                                               "/package/" name "/" version)))
                                    "More information")))))
                        new-packages))))))
           (div
            (@ (class "row"))
            (div
             (@ (class "col-sm-12"))
             (h3 "Removed packages")
             ,(if (null? removed-packages)
                  '(p "No removed packages")
                  `(table
                    (@ (class "table"))
                    (thead
                     (tr
                      (th (@ (class "col-md-4")) "Name")
                      (th (@ (class "col-md-4")) "Version")
                      (th (@ (class "col-md-4")) "")))
                    (tbody
                     ,@(map
                        (match-lambda
                          ((('name . name)
                            ('version . version))
                           `(tr
                             (td ,name)
                             (td ,version)
                             (td (@ (class "text-right"))
                                 (a (@ (href ,(string-append
                                               "/revision/" base-commit
                                               "/package/" name "/" version)))
                                    "More information")))))
                        removed-packages))))))
           (div
            (@ (class "row"))
            (div
             (@ (class "col-sm-12"))
             (h3 "Version changes")
             ,(if
               (null? version-changes)
               '(p "No version changes")
               `(table
                 (@ (class "table"))
                 (thead
                  (tr
                   (th (@ (class "col-md-3")) "Name")
                   (th (@ (class "col-md-9")) "Versions")))
                 (tbody
                  ,@(map
                     (match-lambda
                       ((name . versions)
                        `(tr
                          (td ,name)
                          (td
                           (ul
                            (@ (class "list-unstyled"))
                            ,@(map
                               (match-lambda
                                 ((type . versions)
                                  `(li (@ (class ,(if (eq? type 'base)
                                                      "text-danger"
                                                      "text-success")))
                                       (ul
                                        (@ (class "list-inline")
                                           (style "display: inline-block;"))
                                        ,@(map
                                           (lambda (version)
                                             `(li (a (@ (href
                                                         ,(string-append
                                                           "/revision/"
                                                           (if (eq? type 'base)
                                                               base-commit
                                                               target-commit)
                                                           "/package/"
                                                           name "/" version)))
                                                     ,version)))
                                           (vector->list versions)))
                                       ,(if (eq? type 'base)
                                            " (old)"
                                            " (new)"))))
                               versions))))))
                     version-changes))))))
           (div
            (@ (class "row"))
            (div
             (@ (class "col-sm-12"))
             (h2 "Lint warnings")
             ,@(if
                (null? lint-warnings-data)
                '((p "No lint warning changes"))
                (map
                 (match-lambda
                   (((package-name package-version) . warnings)
                    `((h4 ,package-name " (version: " ,package-version ")")
                      (table
                       (@ (class "table"))
                       (thead
                        (tr
                         (th "")
                         (th "Linter")
                         (th "Message")))
                       (tbody
                        ,@(map (match-lambda
                                 ((lint-checker-name
                                   message
                                   lint-checker-description
                                   lint-checker-network-dependent
                                   file line column-number ;; TODO Maybe use the location?
                                   change)

                                  `(tr
                                    (td (@ (class ,(if (string=? change "new")
                                                       "text-danger"
                                                       "text-success"))
                                           (style "font-weight: bold"))
                                        ,(if (string=? change "new")
                                             "New warning"
                                             "Resolved warning"))
                                    (td (span (@ (style "font-family: monospace; display: block;"))
                                              ,lint-checker-name)
                                        (p (@ (style "font-size: small; margin: 6px 0 0px;"))
                                           ,lint-checker-description))
                                    (td ,message))))
                               warnings))))))
                 lint-warnings-data))))))))))

(define (compare/derivation query-parameters data)
  (define base
    '(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
              (style "font-size: 1.5em; padding-right: 0.4em;"))))

  (define target
    '(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
              (style "font-size: 1.5em; padding-right: 0.4em;"))))

  (layout
   #:title
   "Comparing derivations"
   #:body
   `(,(header)
     (div
      (@ (class "container"))
      (div
       (@ (class "row"))
       (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
                   (target-commit (assq-ref query-parameters 'target_commit)))
               (if (every string? (list base-commit target-commit))
                   `("Comparing "
                     (a (@ (href ,(string-append "/revision/" base-commit)))
                        (samp ,(string-take base-commit 8) "…"))
                     " and "
                     (a (@ (href ,(string-append "/revision/" target-commit)))
                        (samp ,(string-take target-commit 8) "…")))
                   '("Comparing derivations")))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-md-12"))
        (div
         (@ (class "well"))
         (form
          (@ (method "get")
             (action "")
             (class "form-horizontal"))
          ,(form-horizontal-control
            "Base derivation" query-parameters
            #:required? #t
            #:help-text "The derivation to use as the basis for the comparison."
            #:font-family "monospace")
          ,(form-horizontal-control
            "Target derivation" query-parameters
            #:required? #t
            #:help-text "The derivation to compare against the base commit."
            #:font-family "monospace")
          (div (@ (class "form-group form-group-lg"))
               (div (@ (class "col-sm-offset-2 col-sm-10"))
                    (button (@ (type "submit")
                               (class "btn btn-lg btn-primary"))
                            "Update results")))
          (a (@ (class "btn btn-default btn-lg pull-right")
                (href ,(let ((query-parameter-string
                              (query-parameters->string query-parameters)))
                         (string-append
                          "/compare/derivation.json"
                          (if (string-null? query-parameter-string)
                              ""
                              (string-append "?" query-parameter-string))))))
             "View JSON")))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h2 "Outputs")
        ,@(let ((outputs (assq-ref data 'outputs)))
            `((table
               (@ (class "table"))
               (thead
                (tr
                 (th "")
                 (th "Name")
                 (th "Path")
                 (th "Hash algorithm")
                 (th "Hash")
                 (th "Recursive")))
               (tbody
                ,@(append-map
                   (lambda (label items)
                     (map
                      (lambda (alist)
                        `(tr
                          (td ,label)
                          (td ,(assq-ref alist 'output-name))
                          (td (a (@ (href ,(assq-ref alist 'path)))
                                 ,(display-store-item (assq-ref alist 'path))))
                          (td ,(assq-ref alist 'hash-algorithm))
                          (td ,(assq-ref alist 'hash))
                          (td ,(assq-ref alist 'recursive))))
                      (or (and=> items vector->list) '())))
                   (list base target "Common")
                   (list (assq-ref outputs 'base)
                         (assq-ref outputs 'target)
                         (assq-ref outputs 'common)))))))
        (h2 "Inputs")
        ,@(let ((inputs (assq-ref data 'inputs)))
            `((table
               (@ (class "table"))
               (thead
                (tr
                 (th "")
                 (th "Derivation")
                 (th "Outputs")))
               (tbody
                ,@(append-map
                   (lambda (label items)
                     (map
                      (lambda (alist)
                        `(tr
                          (td ,label)
                          (td (a (@ (href ,(assq-ref alist 'derivation_file_name)))
                                 ,(display-store-item (assq-ref alist 'derivation_file_name))))
                          (td ,(assq-ref alist 'derivation_output_name))))
                      (or (and=> items vector->list) '())))
                   (list base target)
                   (list (assq-ref inputs 'base)
                         (assq-ref inputs 'target)))))))
        (p "Common inputs are omitted.")
        (h2 "Sources")
        ,@(let ((sources (assq-ref data 'sources)))
            `((table
               (@ (class "table"))
               (thead
                (tr
                 (th "")
                 (th "Derivation")))
               (tbody
                ,@(append-map
                   (lambda (label items)
                     (map
                      (lambda (alist)
                        `(tr
                          (td ,label)
                          (td (a (@ (href ,(assq-ref alist 'store_path)))
                                 ,(display-store-item (assq-ref alist 'store_path))))))
                      (or (and=> items vector->list) '())))
                   (list base target "Common")
                   (list (assq-ref sources 'base)
                         (assq-ref sources 'target)
                         (assq-ref sources 'common)))))))
        (h2 "System")
        ,@(let ((system (assq-ref data 'system)))
            (let ((common-system (assq-ref system 'common)))
              (if common-system
                  (list common-system)
                  `(table
                    (@ (class "table"))
                    (thead
                     (tr
                      (th "")
                      (th "System")))
                    (tbody
                     ,@(let ((base-system (assq-ref system 'base))
                             (target-system (assq-ref system 'target)))
                         `((tr
                            (td ,base)
                            (td ,base-system))
                           (tr
                            (td ,target)
                            (td ,target-system)))))))))
        (h2 "Builder and arguments")
        ,(let ((builder (assq-ref data 'builder))
               (arguments (assq-ref data 'arguments)))
           (let ((common-builder (assq-ref builder 'common))
                 (common-args (assq-ref arguments 'common)))
             (if (and common-builder
                      common-args)
                 `(table
                   (@ (class "table"))
                   (thead
                    (th "Builder")
                    (th "Arguments"))
                   (tbody
                    (tr
                     (td ,(display-possible-store-item common-builder))
                     (td (ol
                          ,@(map (lambda (arg)
                                   `(li ,(display-possible-store-item arg)))
                                 common-args))))))
                 `(table
                   (@ (class "table"))
                   (thead
                    (tr
                     (th "")
                     (th "Builder")
                     (th "Arguments")))
                   (tbody
                    ,@(let ((base-builder (assq-ref builder 'base))
                            (target-builder (assq-ref builder 'target))
                            (base-args (assq-ref arguments 'base))
                            (target-args (assq-ref arguments 'target)))
                        `((tr
                           (td ,base)
                           (td ,(display-possible-store-item
                                 (or base-builder
                                     common-builder)))
                           (td (ol
                                ,@(map (lambda (arg)
                                         `(li ,(display-possible-store-item arg)))
                                       (or (and=> common-args vector->list)
                                           (vector->list base-args))))))
                          (tr
                           (td ,target)
                           (td ,(display-possible-store-item
                                 (or target-builder
                                     common-builder)))
                           (td (ol
                                ,@(map (lambda (arg)
                                         `(li ,(display-possible-store-item arg)))
                                       (or (and=> common-args vector->list)
                                           (vector->list target-args)))))))))))))
        (h2 "Environment variables")
        ,(let ((environment-variables (assq-ref data 'environment-variables)))
           `(table
             (@ (class "table"))
             (thead
              (th "Name"))
             (tbody
              ,@(append-map
                 (match-lambda
                   ((name . values)
                    (let ((common-value (assq-ref values 'common)))
                      (if common-value
                          `((tr
                             (td ,name)
                             (td ,(display-possible-store-item common-value))))
                          (let ((base-value (assq-ref values 'base))
                                (target-value (assq-ref values 'target)))
                            (if (and base-value target-value)
                                `((tr
                                   (td (@ (rowspan 2))
                                       ,name)
                                   (td ,base ,(display-possible-store-item
                                               base-value)))
                                  (tr
                                   (td ,target ,(display-possible-store-item
                                                 target-value))))
                                `((tr
                                   (td ,name)
                                   (td ,@(if base-value
                                             (list base
                                                   (display-possible-store-item
                                                    base-value))
                                             (list target
                                                   (display-possible-store-item
                                                    target-value))))))))))))
                 environment-variables))))))))))

(define* (compare/package-derivations query-parameters
                                      mode
                                      valid-systems
                                      valid-targets
                                      valid-build-statuses
                                      build-server-urls
                                      derivation-changes
                                      #:optional
                                      base-revision-details
                                      target-revision-details)
  (define field-options
    (map
     (lambda (field)
       (cons field
             (hyphenate-words
              (remove-brackets
               (string-downcase field)))))
     '("(no additional fields)" "Builds")))

  (define fields
    (assq-ref query-parameters 'field))

  (define page-header "Package derivation changes")

  (layout
   #:title
   page-header
   #:body
   `(,(header)
     (div
      (@ (class "container"))
      (div
       (@ (class "row"))
       ,@(cond
          ((any-invalid-query-parameters? query-parameters)
           '((h3 "Comparing package derivations")))
          ((eq? mode 'revision)
           (let ((base-commit (assq-ref query-parameters 'base_commit))
                 (target-commit (assq-ref query-parameters 'target_commit)))
             `((h3
                (a (@ (href ,(string-append
                              "/compare?base_commit="
                              base-commit
                              "&target_commit="
                              target-commit)))
                   "Comparing "
                   (samp ,(string-take base-commit 8) "…")
                   " and "
                   (samp ,(string-take target-commit 8) "…"))))))
          ((eq? mode 'datetime)
           (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)))
             `((h3
                (a (@ (href ,(string-append
                              "/compare-by-datetime?"
                              (query-parameters->string
                               (filter (match-lambda
                                         ((key . _)
                                          (member key '(base_branch
                                                        base_datetime
                                                        target_branch
                                                        target_datetime))))
                                       query-parameters)))))
                   "Comparing "
                   (br)
                   (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
                         ,base-branch
                         ,@(map (lambda _ '(*ENTITY* nbsp))
                                (iota (max
                                       0
                                       (- (string-length target-branch)
                                          (string-length base-branch))))))
                   " at " ,(date->string base-datetime "~1 ~3")
                   " to "
                   (br)
                   (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
                         ,target-branch
                         ,@(map (lambda _ '(*ENTITY* nbsp))
                                (iota (max 0
                                           (- (string-length base-branch)
                                              (string-length target-branch))))))
                   " at " ,(date->string target-datetime "~1 ~3"))))))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-md-12"))
        (div
         (@ (class "well"))
         (form
          (@ (method "get")
             (action "")
             (class "form-horizontal"))
          ,@(compare-form-controls-for-mode mode query-parameters)
          ,(form-horizontal-control
            "System" query-parameters
            #:options valid-systems
            #:help-text "Only include derivations for this system."
            #:font-family "monospace")
          ,(form-horizontal-control
            "Target" query-parameters
            #:options valid-targets
            #:help-text "Only include derivations that are build for this system."
            #:font-family "monospace")
          ,(form-horizontal-control
            "Build change" query-parameters
            #:options '(("(none specified)" . "")
                        ("Broken"           . "broken")
                        ("Fixed"            . "fixed")
                        ("Still working"    . "still-working")
                        ("Still failing"    . "still-failing")
                        ("Unknown"          . "unknown"))
            #:help-text '("Filter by the changes to the builds:"
                          (dl
                           (@ (class "dl-horizontal"))
                           (dt "Broken")
                           (dd
                            "There was a successful build against the base
derivation, but no successful build for the target derivation, and there's at
least one failed build.")
                           (dt "Fixed")
                           (dd
                            "No successful build for the base derivation and
at least one failed build, plus at least one successful build for the target
derivation")
                           (dt "Still working")
                           (dd
                            "At least one successful build for both the base
and target derivations")
                           (dt "Still failing")
                           (dd
                            "No successful builds and at least one failed builds for both the base and target derivations")
                           (dt "Unknown")
                           (dd
                            "No base and target derivation to compare, or not
enough builds to determine a change")))
            #:allow-selecting-multiple-options #f)
          ,(form-horizontal-control
            "Fields" query-parameters
            #:name "field"
            #:options field-options
            #:help-text "Fields to return in the response.")
          ,(form-horizontal-control
            "After name" query-parameters
            #:help-text
            "List packages that are alphabetically after the given name.")
          ,(form-horizontal-control
            "Limit results" query-parameters
            #:help-text "The maximum number of results to return.")
          ,(form-horizontal-control
            "All results" query-parameters
            #:type "checkbox"
            #:help-text "Return all results.")
          (div (@ (class "form-group form-group-lg"))
               (div (@ (class "col-sm-offset-2 col-sm-10"))
                    (button (@ (type "submit")
                               (class "btn btn-lg btn-primary"))
                            "Update results")))
          (a (@ (class "btn btn-default btn-lg pull-right")
                (href ,(let ((query-parameter-string
                              (query-parameters->string query-parameters)))
                         (string-append
                          "/"
                          (cond
                           ((eq? mode 'revision) "compare")
                           ((eq? mode 'datetime) "compare-by-datetime"))
                          "/package-derivations.json"
                          (if (string-null? query-parameter-string)
                              ""
                              (string-append "?" query-parameter-string))))))
             "View JSON")))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h1 ,page-header)
        ,@(if (not (null? derivation-changes))
              (match (vector-fold
                      (lambda (_ result change)
                        (match result
                          ((names . new-drvs-count)
                           (let ((count
                                  (or
                                   (and=> (assq-ref change 'target)
                                          vector-length)
                                   0)))
                             (cons
                              (if (= 0 count)
                                  names
                                  (cons (assq-ref change 'name)
                                        names))
                              (+ new-drvs-count count))))))
                      (cons '() 0)
                      derivation-changes)
                ((names . new-drvs-count)
                 (let ((distinct-packages
                        (length
                         (delete-duplicates/sort! names string<?))))
                   `((p
                      ,(simple-format #f "Showing ~A new derivations across ~A packages"
                                      new-drvs-count
                                      distinct-packages))))))
              '())
        ,(if
          (null? derivation-changes)
          '(p "No derivation changes")
          `(table
            (@ (class "table")
               (style "table-layout: fixed;"))
            (thead
             (tr
              (th "Name")
              (th "Version")
              (th "System")
              (th "Target")
              (th (@ (class "col-xs-5")) "Derivations (with build statuses)")
              (th "")))
            (tbody
             ,@(append-map
                (match-lambda
                  ((('name . name)
                    ('version . version)
                    ('base . base-derivations)
                    ('target . target-derivations))
                   (let* ((system-and-versions
                           (delete-duplicates
                            (append (map (lambda (details)
                                           (cons (assq-ref details 'system)
                                                 (assq-ref details 'target)))
                                         (vector->list base-derivations))
                                    (map (lambda (details)
                                           (cons (assq-ref details 'system)
                                                 (assq-ref details 'target)))
                                         (vector->list target-derivations)))))
                          (data-columns
                           (map
                            (match-lambda
                              ((system . target)
                               (let* ((base-entry
                                       (find (lambda (details)
                                               (and (string=? (assq-ref details 'system) system)
                                                    (string=? (assq-ref details 'target) target)))
                                             (vector->list base-derivations)))
                                      (base-derivation-file-name
                                       (assq-ref base-entry 'derivation-file-name))
                                      (base-builds
                                       (assq-ref base-entry 'builds))
                                      (target-entry
                                       (find (lambda (details)
                                               (and (string=? (assq-ref details 'system) system)
                                                    (string=? (assq-ref details 'target) target)))
                                             (vector->list target-derivations)))
                                      (target-derivation-file-name
                                       (assq-ref target-entry 'derivation-file-name))
                                      (target-builds
                                       (assq-ref target-entry 'builds)))
                                 `((td (samp (@ (style "white-space: nowrap;"))
                                             ,system))
                                   (td (samp (@ (style "white-space: nowrap;"))
                                             ,target))
                                   (td ,@(if base-derivation-file-name
                                             `((a (@ (style "display: block;")
                                                     (href ,base-derivation-file-name))
                                                  (span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
                                                           (style "font-size: 1.5em; padding-right: 0.4em;")))
                                                  ,@(build-statuses->build-status-labels
                                                     (vector->list base-builds))
                                                  ,(display-store-item-short base-derivation-file-name)))
                                             '())
                                       ,@(if target-derivation-file-name
                                             `((a (@ (style "display: block; clear: left;")
                                                     (href ,target-derivation-file-name))
                                                  (span (@ (class "text-success glyphicon glyphicon-plus pull-left")
                                                           (style "font-size: 1.5em; padding-right: 0.4em;")))
                                                  ,@(build-statuses->build-status-labels
                                                     (vector->list target-builds))
                                                  ,(display-store-item-short target-derivation-file-name)))
                                             '()))
                                   (td (@ (style "vertical-align: middle;"))
                                       ,@(if (and base-derivation-file-name
                                                  target-derivation-file-name)
                                             `((a (@ (class "btn btn-sm btn-default")
                                                     (title "Compare")
                                                     (href
                                                      ,(string-append
                                                        "/compare/derivation?"
                                                        "base_derivation="
                                                        base-derivation-file-name
                                                        "&target_derivation="
                                                        target-derivation-file-name)))
                                                  "⇕ Compare"))
                                             '()))))))
                            system-and-versions)))

                     `((tr (td (@ (rowspan , (length system-and-versions)))
                               ,name)
                           (td (@ (rowspan , (length system-and-versions)))
                               ,version)
                           ,@(car data-columns))
                       ,@(map (lambda (data-row)
                                `(tr ,data-row))
                              (cdr data-columns))))))
                (vector->list derivation-changes)))))))))))

(define (compare/packages query-parameters
                          base-packages-vhash
                          target-packages-vhash)
  (define base-commit
    (assq-ref query-parameters 'base_commit))

  (define target-commit
    (assq-ref query-parameters 'target_commit))

  (define query-params
    (string-append "?base_commit=" base-commit
                   "&target_commit=" target-commit))

  (define page-header
    (string-append "Comparing "
                   (string-take base-commit 8) " and "
                   (string-take target-commit 8)))

  (layout
   #:title
   page-header
   #:body
   `(,(header)
     (div
      (@ (class "container"))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h1 "Comparing "
            (a (@ (href ,(string-append "/revision/" base-commit)))
               (samp ,(string-take base-commit 8) "…"))
            " and "
            (a (@ (href ,(string-append "/revision/" target-commit)))
               (samp ,(string-take target-commit 8) "…")))
        (a (@ (class "btn btn-default btn-lg")
              (href ,(string-append
                      "/compare/packages.json" query-params)))
           "View JSON")))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h3 "Base ("
            (samp ,base-commit)
            ")")
        (p "Packages found in the base revision.")
        (table
         (@ (class "table"))
         (thead
          (tr
           (th (@ (class "col-md-4")) "Name")
           (th (@ (class "col-md-4")) "Version")
           (th (@ (class "col-md-4")) "")))
         (tbody
          ,@(map
             (match-lambda
               ((name version)
                `(tr
                  (td ,name)
                  (td ,version)
                  (td (@ (class "text-right"))
                      (a (@ (href ,(string-append
                                    "/revision/" base-commit
                                    "/package/" name "/" version)))
                         "More information")))))
             (delete-duplicates
              (map (lambda (data)
                     (take data 2))
                   (vlist->list base-packages-vhash))))))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h3 "Target ("
            (samp ,target-commit)
            ")")
        (p "Packages found in the target revision.")
        (table
         (@ (class "table"))
         (thead
          (tr
           (th (@ (class "col-md-4")) "Name")
           (th (@ (class "col-md-4")) "Version")
           (th (@ (class "col-md-4")) "")))
         (tbody
          ,@(map
             (match-lambda
               ((name version)
                `(tr
                  (td ,name)
                  (td ,version)
                  (td (@ (class "text-right"))
                      (a (@ (href ,(string-append
                                    "/revision/" target-commit
                                    "/package/" name "/" version)))
                         "More information")))))
             (delete-duplicates
              (map (lambda (data)
                     (take data 2))
                   (vlist->list target-packages-vhash))))))))))))

(define* (compare/system-test-derivations query-parameters
                                          mode
                                          valid-systems
                                          build-server-urls
                                          base-git-repositories
                                          target-git-repositories
                                          changes
                                          #:optional
                                          base-revision-details
                                          target-revision-details)
  (define page-header "System test derivation changes")

  (layout
   #:title
   page-header
   #:body
   `(,(header)
     (div
      (@ (class "container-fluid"))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-md-12"))
        ,@(cond
           ((any-invalid-query-parameters? query-parameters)
            '((h3 "Comparing system test derivations")))
           ((eq? mode 'revision)
            (let ((base-commit (assq-ref query-parameters 'base_commit))
                  (target-commit (assq-ref query-parameters 'target_commit)))
              `((h3
                 (a (@ (href ,(string-append
                               "/compare?base_commit="
                               base-commit
                               "&target_commit="
                               target-commit)))
                    "Comparing "
                    (samp ,(string-take base-commit 8) "…")
                    " and "
                    (samp ,(string-take target-commit 8) "…"))))))
           ((eq? mode 'datetime)
            (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)))
              `((h3
                 (a (@ (href ,(string-append
                               "/compare-by-datetime?"
                               (query-parameters->string
                                (filter (match-lambda
                                          ((key . _)
                                           (member key '(base_branch
                                                         base_datetime
                                                         target_branch
                                                         target_datetime))))
                                        query-parameters)))))
                    "Comparing "
                    (br)
                    (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
                          ,base-branch
                          ,@(map (lambda _ '(*ENTITY* nbsp))
                                 (iota (max
                                        0
                                        (- (string-length target-branch)
                                           (string-length base-branch))))))
                    " at " ,(date->string base-datetime "~1 ~3")
                    " to "
                    (br)
                    (samp (*ENTITY* nbsp) (*ENTITY* nbsp)
                          ,target-branch
                          ,@(map (lambda _ '(*ENTITY* nbsp))
                                 (iota (max 0
                                            (- (string-length base-branch)
                                               (string-length target-branch))))))
                    " at " ,(date->string target-datetime "~1 ~3")))))))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-md-12"))
        (div
         (@ (class "well"))
         (form
          (@ (method "get")
             (action "")
             (class "form-horizontal"))
          ,@(compare-form-controls-for-mode mode query-parameters)
          ,(form-horizontal-control
            "System" query-parameters
            #:options valid-systems
            #:allow-selecting-multiple-options #f
            #:help-text "Only include derivations for this system."
            #:font-family "monospace")
          (div (@ (class "form-group form-group-lg"))
               (div (@ (class "col-sm-offset-2 col-sm-10"))
                    (button (@ (type "submit")
                               (class "btn btn-lg btn-primary"))
                            "Update results")))
          (a (@ (class "btn btn-default btn-lg pull-right")
                (href ,(let ((query-parameter-string
                              (query-parameters->string query-parameters)))
                         (string-append
                          "/"
                          (cond
                           ((eq? mode 'revision) "compare")
                           ((eq? mode 'datetime) "compare-by-datetime"))
                          "/system-test-derivations.json"
                          (if (string-null? query-parameter-string)
                              ""
                              (string-append "?" query-parameter-string))))))
             "View JSON")))))
      (div
       (@ (class "row"))
       (div
        (@ (class "col-sm-12"))
        (h1 ,page-header)
        ,(if
          (null? changes)
          '(p "No system test derivation changes")
          `(table
            (@ (class "table")
               (style "table-layout: fixed;"))
            (thead
             (tr
              (th (@ (class "col-sm-2"))
                  "Name")
              (th (@ (class "col-sm-2"))
                  "Description")
              (th (@ (class "col-sm-2"))
                  "Location")
              (th "Derivation")
              (th (@ (class "col-sm-1"))
                  "")))
            (tbody
             ,@(append-map
                (match-lambda
                  ((('name        . name)
                    ('description . description-data)
                    ('derivation  . derivation-data)
                    ('location    . location-data)
                    ('builds      . builds-data))

                   (define (render-location git-repositories commit-hash
                                            data)
                     (map
                      (match-lambda
                        ((id label url cgit-url-base)
                         (if
                          (and cgit-url-base
                               (not (string-null? cgit-url-base)))
                          (match data
                            ((('file          . file)
                              ('line          . line)
                              ('column_number . column-number))
                             `(a (@ (href
                                     ,(string-append
                                       cgit-url-base "tree/"
                                       file "?id=" commit-hash
                                       "#n" (number->string line))))
                                 ,file
                                 " (line: " ,line
                                 ", column: " ,column-number ")")))
                          '())))
                      git-repositories))

                   (define cells
                     (list
                      (if (list? description-data)
                          (cons
                           `(td ,(let ((description
                                        (assq-ref description-data 'base)))
                                   (if (eq? description 'null)
                                       ""
                                       description)))
                           `(td ,(let ((description
                                        (assq-ref description-data 'target)))
                                   (if (eq? description 'null)
                                       ""
                                       description))))
                          (cons
                           `(td (@ (rowspan 2))
                                ,description-data)
                           ""))
                      (if (assq-ref location-data 'base)
                          (cons
                           (if (list? (assq-ref location-data 'base))
                               `(td ,(render-location
                                      base-git-repositories
                                      (if (eq? mode 'revision)
                                          (assq-ref query-parameters
                                                    'base_commit)
                                          (second base-revision-details))
                                      (assq-ref location-data 'base)))
                               "")
                           (if (list? (assq-ref location-data 'target))
                               `(td ,(render-location
                                      target-git-repositories
                                      (if (eq? mode 'revision)
                                          (assq-ref query-parameters
                                                    'target_commit)
                                          (second target-revision-details))
                                      (assq-ref location-data 'target)))
                               ""))
                          (cons
                           `(td (@ (rowspan 2))
                                ,(render-location
                                  target-git-repositories
                                  (if (eq? mode 'revision)
                                      (assq-ref query-parameters
                                                'target_commit)
                                      (second target-revision-details))
                                  location-data))
                           ""))
                      (cons
                       (let ((base-derivation (assq-ref derivation-data 'base)))
                         (if (string? base-derivation)
                             `(td
                               (a (@ (style "display: block;")
                                     (href ,base-derivation))
                                  (span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
                                           (style "font-size: 1.5em; padding-right: 0.4em;")))
                                  ,@(build-statuses->build-status-labels
                                     (vector->list (assq-ref builds-data 'base)))
                                  ,(display-store-item-short base-derivation)))
                             ""))
                       (let ((target-derivation (assq-ref derivation-data 'target)))
                         (if (string? target-derivation)
                             `(td
                               (a (@ (style "display: block;")
                                     (href ,target-derivation))
                                  (span (@ (class "text-success glyphicon glyphicon-plus pull-left")
                                           (style "font-size: 1.5em; padding-right: 0.4em;")))
                                  ,@(build-statuses->build-status-labels
                                     (vector->list (assq-ref builds-data 'target)))
                                  ,(display-store-item-short target-derivation)))
                             "")))
                      (cons
                       (if (and (string? (assq-ref derivation-data 'base))
                                (string? (assq-ref derivation-data 'target)))
                           `(td (@ (style "vertical-align: middle;")
                                   (rowspan 2))
                                (a (@ (class "btn btn-sm btn-default")
                                      (title "Compare")
                                      (href
                                       ,(string-append
                                         "/compare/derivation?"
                                         "base_derivation="
                                         (assq-ref derivation-data 'base)
                                         "&target_derivation="
                                         (assq-ref derivation-data 'target))))
                                   "⇕ Compare"))
                           "")
                       "")))

                   `((tr
                      (td (@ (rowspan 2))
                          ,name)
                      ,@(map car cells))
                     (tr
                      ,@(map cdr cells)))))
                changes))))))))))