aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/web/controller.scm95
-rw-r--r--guix-data-service/web/view/html.scm163
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)