diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 95 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 163 |
2 files changed, 258 insertions, 0 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index cad1db5..cda058e 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -601,6 +601,84 @@ derivation-changes) #:extra-headers http-headers-for-unchanging-content))))))))) +(define (render-compare-by-datetime/derivations mime-types + conn + query-parameters) + (define (derivations->alist derivations) + (map (match-lambda + ((file-name system target buildstatus) + `((file_name . ,file-name) + (system . ,system) + (target . ,target) + (build_status . ,(if (string=? buildstatus "") + "unknown" + buildstatus))))) + derivations)) + + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare-by-datetime/derivations + query-parameters + (valid-systems conn) + build-status-strings + '())))) + + (let ((base-branch (assq-ref query-parameters 'base_branch)) + (base-datetime (assq-ref query-parameters 'base_datetime)) + (target-branch (assq-ref query-parameters 'target_branch)) + (target-datetime (assq-ref query-parameters 'target_datetime)) + (systems (assq-ref query-parameters 'system)) + (targets (assq-ref query-parameters 'target)) + (build-statuses (assq-ref query-parameters 'build_status))) + (let* + ((base-revision-details + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime)) + (target-revision-details + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime)) + (data + (package-differences-data conn + (first base-revision-details) + (first target-revision-details) + #:systems systems + #:targets targets)) + (names-and-versions + (package-data->names-and-versions data))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes data))) + (let ((derivation-changes + (package-data-derivation-changes names-and-versions + base-packages-vhash + target-packages-vhash))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + derivation-changes + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare-by-datetime/derivations + query-parameters + (valid-systems conn) + build-status-strings + base-revision-details + target-revision-details + derivation-changes) + #:extra-headers http-headers-for-unchanging-content))))))))) + (define (render-compare/packages mime-types conn query-parameters) @@ -1112,6 +1190,23 @@ (render-compare/derivations mime-types conn parsed-query-parameters))) + (('GET "compare-by-datetime" "derivations") + (let* ((parsed-query-parameters + (guard-against-mutually-exclusive-query-parameters + (parse-query-parameters + request + `((base_branch ,identity #:required) + (base_datetime ,parse-datetime #:required) + (target_branch ,identity #:required) + (target_datetime ,parse-datetime #:required) + (system ,parse-system #:multi-value) + (target ,parse-system #:multi-value) + (build_status ,parse-build-status #:multi-value))) + '((base_commit base_datetime) + (target_commit target_datetime))))) + (render-compare-by-datetime/derivations mime-types + conn + parsed-query-parameters))) (('GET "compare" "packages") (let* ((parsed-query-parameters (parse-query-parameters diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index b49c254..ff815c4 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -50,6 +50,7 @@ view-job compare compare/derivations + compare-by-datetime/derivations compare/packages compare-invalid-parameters error-page)) @@ -2061,6 +2062,168 @@ (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) |