diff options
Diffstat (limited to 'guix-data-service/web/view/html.scm')
| -rw-r--r-- | guix-data-service/web/view/html.scm | 638 |
1 files changed, 0 insertions, 638 deletions
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 0972063..ae9fe0e 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -44,11 +44,6 @@ view-builds view-derivation view-store-item - compare - compare/derivations - compare-by-datetime/derivations - compare/packages - compare-invalid-parameters error-page)) (define* (header) @@ -581,610 +576,6 @@ ,(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 @@ -1194,35 +585,6 @@ (h1 ,header-text) (p ,body))))) -(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 |