;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2019 Christopher Baines ;;; ;;; 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 ;;; . (define-module (guix-data-service web view html) #:use-module (guix-data-service config) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (texinfo) #:use-module (texinfo html) #:use-module (json) #:export (layout header form-horizontal-control display-store-item-short build-status-span index readme general-not-found unknown-revision view-statistics view-git-repository view-branches view-branch view-branch-package view-builds view-derivation view-store-item compare compare/derivations compare-by-datetime/derivations compare/packages compare-invalid-parameters error-page)) (define* (header) `(nav (@ (id "header") (class "navbar navbar-default")) (div (@ (class "container-fluid")) (div (@ (class "navbar-header")) (div (@ (class "navbar-brand")) (a (@ (href "/") (class "logo")))))))) (define* (layout #:key (head '()) (body '()) (title "Guix Data Service")) `((doctype "html") (html (head (title ,title) (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8"))) (meta (@ (http-equiv "Content-Language") (content "en"))) (meta (@ (name "author") (content "Christopher Baines"))) (meta (@ (name "viewport") (content "width=device-width, initial-scale=1"))) (link (@ (rel "stylesheet") (media "screen") (type "text/css") (href "/assets/css/reset.css"))) (link (@ (rel "stylesheet") (media "screen") (type "text/css") (href "/assets/css/bootstrap.css"))) ,@head (link (@ (rel "stylesheet") (media "screen") (type "text/css") (href "/assets/css/screen.css")))) (body (a (@ (id "top"))) ,@body (footer (p "Copyright © 2016—2019 by the GNU Guix community." (br) "Now with even more " (span (@ (class "lambda")) "λ") "! ") (p "This is free software. Download the " (a (@ (href "https://git.savannah.gnu.org/cgit/guix/data-service.git/")) "source code here") ".")))))) (define* (form-horizontal-control label query-parameters #:key name help-text required? options font-family (type "text")) (define (value->text value) (match value (#f "") ((? date? date) (date->string date "~1 ~3")) (other other))) (let* ((input-id (hyphenate-words (string-downcase label))) (help-span-id (string-append input-id "-help-text")) (input-name (or name (underscore-join-words (string-downcase label)))) (has-error? (invalid-query-parameter? (assq-ref query-parameters (string->symbol input-name)))) (show-help-span? (or help-text has-error? required?))) `(div (@ (class ,(string-append "form-group form-group-lg" (if has-error? " has-error" "")))) (label (@ (for ,input-id) (class "col-sm-2 control-label")) ,label) (div (@ (class "col-sm-9")) ,(if options `(select (@ (class "form-control") (style ,(if font-family (string-append "font-family: " font-family ";") "")) (multiple #t) (id ,input-id) ,@(if show-help-span? `((aria-describedby ,help-span-id)) '()) (name ,input-name)) ,@(let ((selected-options (match (assq (string->symbol input-name) query-parameters) ((_key . value) value) (_ '())))) (map (match-lambda ((option-label . option-value) `(option (@ ,@(if (member option-value selected-options) '((selected "")) '()) (value ,option-value)) ,(value->text option-label))) (option-value `(option (@ ,@(if (member option-value selected-options) '((selected "")) '())) ,(value->text option-value)))) options))) `(input (@ (class "form-control") (style ,(if font-family (string-append "font-family: " font-family ";") "")) (id ,input-id) (type ,type) ,@(if required? '((required #t)) '()) ,@(if show-help-span? `((aria-describedby ,help-span-id)) '()) (name ,input-name) ,@(match (assq (string->symbol input-name) query-parameters) (#f '()) ((_key . ($ value)) (if (string=? type "checkbox") (if value '((checked #t)) '()) `((value ,(value->text value))))) ((_key . value) (if (string=? type "checkbox") (if value '((checked #t)) '()) `((value ,(value->text value))))))))) ,@(if show-help-span? `((span (@ (id ,help-span-id) (class "help-block")) ,@(if has-error? (let ((message (invalid-query-parameter-message (assq-ref query-parameters (string->symbol input-name))))) `((p (strong ,(string-append "Error: " (if message message "invalid value.")))))) '()) ,@(if required? '((strong "Required. ")) '()) ,@(if help-text (list help-text) '()))) '()))))) (define (readme contents) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h1 "The README document"))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (raw ,contents))))))) (define (index git-repositories-and-revisions) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h1 (@ (style "display: inline-block;")) "Guix Data Service") (div (@ (class "btn-group pull-right") (style "margin-top: 1.3rem;") (role "group")) (a (@ (class "btn btn-lg btn-default") (href "/statistics") (role "button")) "Statistics") (a (@ (class "btn btn-lg btn-default") (href "/jobs") (role "button")) "Jobs")))) ,@(map (match-lambda (((repository-id label url cgit-url-base) . branches-with-most-recent-commits) `(div (@ (class "row")) (div (@ (class "col-sm-12")) (h3 (@ (style "display: inline-block;")) ,url) ,@(if (string-null? cgit-url-base) '() `((a (@ (style "padding-left: 0.8em;") (href ,cgit-url-base)) "(View cgit)"))) ,(if (null? branches-with-most-recent-commits) '(p "No branches") (table/branches-with-most-recent-commits repository-id (filter (lambda (data) (not (string-null? (second data)))) branches-with-most-recent-commits))))))) git-repositories-and-revisions))))) (define (view-statistics guix-revisions-count derivations-count) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-md-6")) (h3 "Guix revisions") (strong (@ (class "text-center") (style "font-size: 2em; display: block;")) ,guix-revisions-count)) (div (@ (class "col-md-6")) (h3 "Derivations") (strong (@ (class "text-center") (style "font-size: 2em; display: block;")) ,derivations-count))))))) (define (table/branches-with-most-recent-commits git-repository-id branches-with-most-recent-commits) `(table (@ (class "table table-responsive")) (thead (tr (th (@ (class "col-md-3")) "Name") (th (@ (class "col-md-2")) "Date") (th (@ (class "col-md-7")) "Commit"))) (tbody ,@(map (match-lambda ((name commit date revision-exists? job-events) `(tr (td (a (@ (href ,(string-append "/repository/" (number->string git-repository-id) "/branch/" name))) ,name)) (td ,date) (td ,@(if (string=? commit "") '((samp "branch deleted")) `((a (@ (href ,(string-append "/revision/" commit))) (samp ,commit)) " " ,(cond (revision-exists? '(span (@ (class "label label-success")) "✓")) ((member "failure" job-events) '(span (@ (class "label label-danger")) "Failed to import data")) (else '(span (@ (class "label label-default")) "No information yet"))))))))) branches-with-most-recent-commits)))) (define* (view-git-repository git-repository-id label url cgit-url-base branches-with-most-recent-commits) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-md-12")) (h1 ,url))) (div (@ (class "row")) (div (@ (class "col-md-12")) (h3 "Branches") ,(table/branches-with-most-recent-commits git-repository-id branches-with-most-recent-commits))))))) (define (view-branch git-repository-id branch-name query-parameters branch-commits) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-md-12")) (a (@ (href ,(string-append "/repository/" git-repository-id))) (h3 "Repository")) (h1 (@ (style "white-space: nowrap;")) (samp ,branch-name) " branch"))) (div (@ (class "row")) (div (@ (class "col-md-12")) (div (@ (class "well")) (form (@ (method "get") (action "") (class "form-horizontal")) ,(form-horizontal-control "After date" query-parameters #:help-text "Only show the branch history after this date.") ,(form-horizontal-control "Before date" query-parameters #:help-text "Only show the branch history before this date.") ,(form-horizontal-control "Limit results" query-parameters #:help-text "The maximum number of results to return.") (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"))))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (a (@ (class "btn btn-default btn-lg pull-right") (href ,(string-append "/repository/" git-repository-id "/branch/" branch-name "/latest-processed-revision"))) "Latest processed revision"))) (div (@ (class "row")) (div (@ (class "col-md-12")) (table (@ (class "table") (style "table-layout: fixed;")) (thead (tr (th (@ (class "col-sm-3")) "Date") (th (@ (class "col-sm-7")) "Commit") (th (@ (class "col-sm-1"))))) (tbody ,@(map (match-lambda* (((commit date revision-exists? job-events) (previous-commit previous-revision-exists?)) `(tr (td ,date) (td ,@(if (string=? commit "") '((samp "branch deleted")) `((a (@ (href ,(string-append "/revision/" commit))) (samp ,commit)) " " ,(cond (revision-exists? '(span (@ (class "label label-success")) "✓")) ((member "failure" job-events) '(span (@ (class "label label-danger")) "Failed to import data")) (else '(span (@ (class "label label-default")) "No information yet")))))) ,@(if (and previous-commit revision-exists? previous-revision-exists?) `((td (@ (style "vertical-align: middle;") (rowspan "2")) (div (@ (class "btn-group") (role "group")) (a (@ (class "btn btn-sm btn-default") (title "Compare") (href ,(string-append "/compare" "?base_commit=" previous-commit "&target_commit=" commit))) "⇕ Compare")))) '())))) branch-commits (append (map (match-lambda ((commit date revision-exists? job-events) (list commit revision-exists?))) (cdr branch-commits)) '((#f #f)))))))))))) (define (view-branch-package git-repository-id branch-name package-name versions-by-revision-range) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-md-12")) (a (@ (href ,(string-append "/repository/" git-repository-id))) (h3 "Repository")) (a (@ (href ,(string-append "/repository/" git-repository-id "/branch/" branch-name))) (h3 ,(string-append branch-name " branch"))) (a (@ (class "btn btn-default btn-lg pull-right") (href ,(string-append "/repository/" git-repository-id "/branch/" branch-name "/package/" package-name ".json"))) "View JSON") (h1 (@ (style "white-space: nowrap;")) (samp ,package-name)))) (div (@ (class "row")) (div (@ (class "col-md-12")) (table (@ (class "table") (style "table-layout: fixed;")) (thead (tr (th (@ (class "col-sm-4")) "Version") (th (@ (class "col-sm-4")) "From") (th (@ (class "col-sm-4")) "To"))) (tbody ,@(let* ((times-in-seconds (map (lambda (d) (time-second (date->time-monotonic (string->date d "~Y-~m-~d ~H:~M:~S")))) (append (map third versions-by-revision-range) (map fifth versions-by-revision-range)))) (earliest-date-seconds (apply min times-in-seconds)) (latest-date-seconds (apply max times-in-seconds)) (min-to-max-seconds (- latest-date-seconds earliest-date-seconds))) (map (match-lambda ((package-version first-guix-revision-commit first-datetime last-guix-revision-commit last-datetime) `((tr (@ (style "border-bottom: 0;")) (td ,package-version) (td (a (@ (href ,(string-append "/revision/" first-guix-revision-commit))) ,first-datetime) (br) (a (@ (href ,(string-append "/revision/" first-guix-revision-commit "/package/" package-name "/" package-version))) "(More information)")) (td (a (@ (href ,(string-append "/revision/" last-guix-revision-commit))) ,last-datetime) (br) (a (@ (href ,(string-append "/revision/" last-guix-revision-commit "/package/" package-name "/" package-version))) "(More information)"))) (tr (td (@ (colspan 3) (style "border-top: 0; padding-top: 0;")) (div (@ (style ,(let* ((start-seconds (time-second (date->time-monotonic (string->date first-datetime "~Y-~m-~d ~H:~M:~S")))) (end-seconds (time-second (date->time-monotonic (string->date last-datetime "~Y-~m-~d ~H:~M:~S")))) (margin-left (min (* (/ (- start-seconds earliest-date-seconds) min-to-max-seconds) 100) 98)) (width (max (- (* (/ (- end-seconds earliest-date-seconds) min-to-max-seconds) 100) margin-left) 2))) (simple-format #f "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;" (rationalize margin-left 1) (rationalize width 1))))))))))) versions-by-revision-range)))))))))) (define (view-builds stats builds) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h1 "Builds") (table (@ (class "table")) (thead (tr (th (@ (class "col-md-2")) "Status") (th (@ (class "col-md-2")) "Count"))) (tbody ,@(map (match-lambda ((status count) `(tr (td ,(build-status-span status)) (td ,count)))) stats))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (table (@ (class "table")) (thead (tr (th (@ (class "col-xs-2")) "Status") (th (@ (class "col-xs-9")) "Derivation") (th (@ (class "col-xs-1")) "Started at") (th (@ (class "col-xs-1")) "Finished at") (th (@ (class "col-xs-1")) ""))) (tbody ,@(map (match-lambda ((build-id build-server-url derivation-file-name status-fetched-at starttime stoptime status) `(tr (td (@ (class "text-center")) ,(build-status-span status)) (td (a (@ (href ,derivation-file-name)) ,(display-store-item-short derivation-file-name))) (td ,starttime) (td ,stoptime) (td (a (@ (href ,(simple-format #f "~Abuild/~A" build-server-url build-id))) "View build on " ,build-server-url))))) builds))))))))) (define (build-status-value->display-string value) (assoc-ref '(("scheduled" . "Scheduled") ("started" . "Started") ("succeeded" . "Succeeded") ("failed" . "Failed") ("failed-dependency" . "Failed (dependency)") ("failed-other" . "Failed (other)") ("canceled" . "Canceled") ("" . "Unknown")) value)) (define (build-status-span status) `(span (@ (class ,(string-append "label label-" (assoc-ref '(("scheduled" . "info") ("started" . "primary") ("succeeded" . "success") ("failed" . "danger") ("failed-dependency" . "warning") ("failed-other" . "danger") ("canceled" . "default") ("" . "default")) status))) (style "display: inline-block; font-size: 1.2em; margin-top: 0.4em;")) ,(build-status-value->display-string status))) (define (display-store-item-short item) `((span (@ (style "font-size: small; font-family: monospace; display: block;")) ,(string-take item 44)) (span (@ (style "font-size: x-large; font-family: monospace; display: block;")) ,(string-drop item 44)))) (define (display-store-item item) `((span (@ (style "font-size: small; font-family: monospace; white-space: nowrap;")) ,(string-take item 44)) (span (@ (style "font-size: x-large; font-family: monospace; white-space: nowrap;")) ,(string-drop item 44)))) (define (display-store-item-title item) `(h1 (span (@ (style "font-size: 1em; font-family: monospace; display: block;")) ,(string-take item 44)) (span (@ (style "line-height: 1.7em; font-size: 1.5em; font-family: monospace;")) ,(string-drop item 44)))) (define (display-file-in-store-item filename) (match (string-split filename #\/) (("" "gnu" "store" item fileparts ...) `(,(let ((full-item (string-append "/gnu/store/" item))) `(a (@ (href ,full-item)) ,(display-store-item-short full-item))) ,(string-append "/" (string-join fileparts "/")))))) (define (view-store-item filename derivations derivations-using-store-item-list) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-12")) ,(display-store-item-title filename))) ,@(map (lambda (derivation derivations-using-store-item) `((div (@ (class "row")) (div (@ (class "col-sm-12")) (h4 "Derivation: ") ,(match derivation ((file-name output-id) `(a (@ (href ,file-name)) ,(display-store-item file-name)))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h2 "Derivations using this store item " ,(let ((count (length derivations-using-store-item))) (if (eq? count 100) "(> 100)" (simple-format #f "(~A)" count)))) (ul (@ (class "list-unstyled")) ,(map (match-lambda ((file-name) `(li (a (@ (href ,file-name)) ,(display-store-item file-name))))) derivations-using-store-item)))))) derivations derivations-using-store-item-list))))) (define (view-derivation derivation derivation-inputs derivation-outputs builds) (layout #:body `(,(header) (div (@ (class "container")) ,(match derivation ((id file-name builder args env-vars system) `(div (@ (class "row")) (div (@ (class "col-sm-12")) ,(display-store-item-title file-name))))) (div (@ (class "row")) (div (@ (class "col-md-4")) (h3 "Inputs") ,(if (null? derivation-inputs) "No inputs" `(table (@ (class "table")) (thead (tr (th "File name"))) (tdata ,@(map (match-lambda ((file-name output-name path) `(tr (td (a (@ (href ,file-name)) ,(display-store-item-short path)))))) derivation-inputs))))) (div (@ (class "col-md-4")) (h3 "Derivation details") ,(match derivation ((id file-name builder args env-vars system) `(table (@ (class "table")) (tbody (tr (td "Builder") (td ,(if (string=? "builtin:download" builder) "builtin:download" `(a (@ (href ,builder)) ,(display-file-in-store-item builder))))) (tr (td "System") (td (samp ,system))))))) (h3 "Build status") ,@(if (null? builds) `((div (@ (class "text-center")) ,(build-status-span ""))) (map (match-lambda ((build-id build-server-url status-fetched-at starttime stoptime status) `(div (@ (class "text-center")) (div ,(build-status-span status)) (a (@ (style "display: inline-block; margin-top: 0.4em;") (href ,(simple-format #f "~Abuild/~A" build-server-url build-id))) "View build on " ,build-server-url)))) builds))) (div (@ (class "col-md-4")) (h3 "Outputs") (table (@ (class "table")) (thead (tr (th "File name"))) (tdata ,@(map (match-lambda ((output-name path hash-algorithm hash recursive?) `(tr (td (a (@ (href ,path)) ,(display-store-item-short path)))))) derivation-outputs))))))))) (define (compare query-parameters cgit-url-bases new-packages removed-packages version-changes lint-warnings-data) (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)) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-8")) (h1 "Comparing " (samp ,(string-take base-commit 8) "…") " and " (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-4")) (div (@ (class "btn-group-vertical btn-group-lg pull-right") (style "margin-top: 2em;") (role "group")) (a (@ (class "btn btn-default") (href ,(string-append "/compare/packages" query-params))) "Compare packages") (a (@ (class "btn btn-default") (href ,(string-append "/compare/derivations" query-params))) "Compare derivations")))) (div (@ (class "row") (style "clear: left;")) (div (@ (class "col-sm-12")) (a (@ (class "btn btn-default btn-lg") (href ,(string-append "/compare.json" query-params))) "View JSON"))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h3 (@ (style "clear: both;")) "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 ,@(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/derivations query-parameters valid-systems valid-build-statuses derivation-changes) (layout #: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 " (samp ,(string-take base-commit 8) "…") " and " (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 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") ,(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-systems #:help-text "Only include derivations that are build 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 "/compare/derivations.json" (if (string-null? query-parameter-string) "" (string-append "?" query-parameter-string)))))) "View JSON"))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h3 "Package derivation changes") ,(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"))) (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-derivation-file-name (assq-ref (find (lambda (details) (and (string=? (assq-ref details 'system) system) (string=? (assq-ref details 'target) target))) (vector->list base-derivations)) 'derivation-file-name)) (target-derivation-file-name (assq-ref (find (lambda (details) (and (string=? (assq-ref details 'system) system) (string=? (assq-ref details 'target) target))) (vector->list target-derivations)) 'derivation-file-name))) `((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;"))) ,(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;"))) ,(and=> target-derivation-file-name display-store-item-short))) '())))))) 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-by-datetime/derivations query-parameters valid-systems valid-build-statuses base-revision-details target-revision-details derivation-changes) (layout #: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 " (samp ,(string-take base-commit 8) "…") " and " (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 branch" query-parameters #:required? #t #:help-text "The branch to compare from." #:font-family "monospace") ,(form-horizontal-control "Base datetime" query-parameters #:required? #t #:help-text "The date and time to compare from." #: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 #:required? #t #:help-text "The date and time to compare to." #:font-family "monospace") ,(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-systems #:help-text "Only include derivations that are build 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 "/compare/derivations.json" (if (string-null? query-parameter-string) "" (string-append "?" query-parameter-string)))))) "View JSON"))))) (div (@ (class "row")) (div (@ (class "col-sm-12")) (div (a (@ (href ,(string-append "/revision/" (second base-revision-details)))) "Base revision: " ,(second base-revision-details))) (div (a (@ (href ,(string-append "/revision/" (second target-revision-details)))) "Target revision: " ,(second target-revision-details))) (h3 "Package derivation changes") ,(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"))) (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-derivation-file-name (assq-ref (find (lambda (details) (and (string=? (assq-ref details 'system) system) (string=? (assq-ref details 'target) target))) (vector->list base-derivations)) 'derivation-file-name)) (target-derivation-file-name (assq-ref (find (lambda (details) (and (string=? (assq-ref details 'system) system) (string=? (assq-ref details 'target) target))) (vector->list target-derivations)) 'derivation-file-name))) `((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;"))) ,(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;"))) ,(and=> target-derivation-file-name display-store-item-short))) '())))))) 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)) (layout #:body `(,(header) (div (@ (class "container")) (div (@ (class "row")) (div (@ (class "col-sm-12")) (h1 "Comparing " (samp ,(string-take base-commit 8) "…") " and " (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 (general-not-found header-text body) (layout #:body `(,(header) (div (@ (class "container")) (h1 ,header-text) (p ,body))))) (define (unknown-revision commit-hash job git-repositories-and-branches jobs-and-events) (layout #:body `(,(header) (div (@ (class "container")) ,@(match job (() `((h1 "Unknown revision") (p "No known revision with commit " (strong (samp ,commit-hash))))) ((jobs ...) `((div (@ (class "row")) (div (@ (class "col-md-12")) (h1 (@ (style "white-space: nowrap;")) "Revision " (samp ,commit-hash)))) (div (@ (class "row")) (div (@ (class "col-md-6")) (h2 "Packages") (strong (@ (class "text-center") (style "font-size: 2em; display: block;")) "Unknown") ,@(if (null? git-repositories-and-branches) '() (view-revision/git-repositories git-repositories-and-branches commit-hash)) ,@(view-revision/jobs-and-events jobs-and-events)) (div (@ (class "col-md-6")) (h3 "Derivations") (strong (@ (class "text-center") (style "font-size: 2em; display: block;")) "Unknown")))))))))) (define (compare-invalid-parameters query-parameters base-job target-job) (define base-commit (assq-ref query-parameters 'base_commit)) (define target-commit (peek (assq-ref query-parameters 'target_commit))) (layout #:body `(,(header) (div (@ (class "container")) (h1 "Unknown commit") ,(if (invalid-query-parameter? base-commit) `(p "No known revision with commit " (strong (samp ,(invalid-query-parameter-value base-commit))) ,(if (null? base-job) " and it is not currently queued for processing" " but it is queued for processing")) '()) ,(if (invalid-query-parameter? target-commit) `(p "No known revision with commit " (strong (samp ,(invalid-query-parameter-value target-commit))) ,(if (null? target-job) " and it is not currently queued for processing" " but it is queued for processing")) '()))))) (define (error-page message) (layout #:body `(,(header) (div (@ (class "container")) (h1 "Error") (p "An error occurred. Sorry about that!") ,message (p (a (@ (href "/")) "Try something else?"))))))