[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
09/10: Consolidate the package derivation comparison code
|
From: |
Christopher Baines |
|
Subject: |
09/10: Consolidate the package derivation comparison code |
|
Date: |
Sat, 21 Nov 2020 16:11:45 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit 7e1cba3309f10fc29257704edbe491120c61415a
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sat Nov 21 21:00:40 2020 +0000
Consolidate the package derivation comparison code
---
guix-data-service/web/compare/controller.scm | 19 ++-
guix-data-service/web/compare/html.scm | 244 +++++++--------------------
2 files changed, 77 insertions(+), 186 deletions(-)
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)
- branch master updated (3e15900 -> e93da1a), Christopher Baines, 2020/11/21
- 01/10: Avoid crashing when no compare arguments are provided, Christopher Baines, 2020/11/21
- 04/10: Improve the comparison page interface, Christopher Baines, 2020/11/21
- 02/10: Avoid errors in form-horizontal-control, Christopher Baines, 2020/11/21
- 03/10: Specify an invalid parameter message in parse-datetime, Christopher Baines, 2020/11/21
- 05/10: Add default datetimes for compare-by-datetime, Christopher Baines, 2020/11/21
- 06/10: Fix some links on the compare page, Christopher Baines, 2020/11/21
- 09/10: Consolidate the package derivation comparison code,
Christopher Baines <=
- 08/10: Start merging the package derivation comparison code, Christopher Baines, 2020/11/21
- 07/10: Extract out the compare form controls, Christopher Baines, 2020/11/21
- 10/10: Fix the JSON link on the compare package derivations page, Christopher Baines, 2020/11/21