diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 1a811d6..20f1f3d 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -645,10 +645,14 @@ '((error . "invalid query")))) (else (render-html - #:sxml (compare-by-datetime/package-derivations + #:sxml (compare/package-derivations query-parameters + 'datetime (parallel-via-thread-pool-channel (with-thread-postgresql-connection valid-systems)) + (valid-targets->options + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-targets))) build-status-strings '() '() @@ -708,14 +712,21 @@ derivation-changes)) (else (render-html - #:sxml (compare-by-datetime/package-derivations + #:sxml (compare/package-derivations query-parameters + 'datetime (parallel-via-thread-pool-channel (with-thread-postgresql-connection valid-systems)) + (valid-targets->options + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-targets))) build-status-strings + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + select-build-server-urls-by-id)) + derivation-changes base-revision-details - target-revision-details - derivation-changes)))))))))))) + target-revision-details)))))))))))) (define (render-compare/packages mime-types query-parameters) diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm index 2ae85a0..993137e 100644 --- a/guix-data-service/web/compare/html.scm +++ b/guix-data-service/web/compare/html.scm @@ -17,6 +17,7 @@ (define-module (guix-data-service web compare html) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (texinfo) @@ -652,13 +653,16 @@ target-value)))))))))))) environment-variables)))))))))) -(define (compare/package-derivations query-parameters - mode - valid-systems - valid-targets - valid-build-statuses - build-server-urls - derivation-changes) +(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) (layout #:body `(,(header) @@ -666,19 +670,57 @@ (@ (class "container")) (div (@ (class "row")) - (h3 ,@(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)) - `((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) "…"))) - '("Comparing package derivations"))))) + ,@(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 @@ -854,168 +896,6 @@ enough builds to determine a change"))) (cdr data-columns)))))) (vector->list derivation-changes))))))))))) -(define (compare-by-datetime/package-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 " - (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 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." - #: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." - #: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/package-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)