aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web')
-rw-r--r--guix-data-service/web/compare/controller.scm52
-rw-r--r--guix-data-service/web/compare/html.scm245
-rw-r--r--guix-data-service/web/view/html.scm1
3 files changed, 298 insertions, 0 deletions
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
index 381d25b..16dcf39 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -53,6 +53,13 @@
(make-invalid-query-parameter
s "unknown commit"))))
+(define (parse-derivation conn)
+ (lambda (file-name)
+ (if (select-derivation-by-file-name conn file-name)
+ file-name
+ (make-invalid-query-parameter
+ file-name "unknown derivation"))))
+
(define (compare-controller request
method-and-path-components
mime-types
@@ -79,6 +86,15 @@
(render-compare-by-datetime mime-types
conn
parsed-query-parameters)))
+ (('GET "compare" "derivation")
+ (let* ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((base_derivation ,(parse-derivation conn) #:required)
+ (target_derivation ,(parse-derivation conn) #:required)))))
+ (render-compare/derivation mime-types
+ conn
+ parsed-query-parameters)))
(('GET "compare" "derivations")
(let* ((parsed-query-parameters
(parse-query-parameters
@@ -287,6 +303,42 @@
lint-warnings-data)
#:extra-headers http-headers-for-unchanging-content)))))))))
+(define (render-compare/derivation mime-types
+ conn
+ query-parameters)
+ (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/derivation
+ query-parameters
+ '()))))
+
+ (let ((base-derivation (assq-ref query-parameters 'base_derivation))
+ (target-derivation (assq-ref query-parameters 'target_derivation)))
+ (let ((data
+ (derivation-differences-data conn
+ base-derivation
+ target-derivation)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ '((error . "unimplemented")) ; TODO
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (compare/derivation
+ query-parameters
+ data)
+ #:extra-headers http-headers-for-unchanging-content)))))))
+
(define (render-compare/derivations mime-types
conn
query-parameters)
diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm
index afb103d..92e76ff 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -22,6 +22,7 @@
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web view html)
#:export (compare
+ compare/derivation
compare/derivations
compare-by-datetime/derivations
compare/packages
@@ -232,6 +233,250 @@
warnings))))))
lint-warnings-data))))))))
+(define (compare/derivation query-parameters data)
+ (define base
+ '(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
+ (style "font-size: 1.5em; padding-right: 0.4em;"))))
+
+ (define target
+ '(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
+ (style "font-size: 1.5em; padding-right: 0.4em;"))))
+
+ (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 derivation" query-parameters
+ #:required? #t
+ #:help-text "The derivation to use as the basis for the comparison."
+ #:font-family "monospace")
+ ,(form-horizontal-control
+ "Target derivation" query-parameters
+ #:required? #t
+ #:help-text "The derivation to compare against the base commit."
+ #: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/derivation.json"
+ (if (string-null? query-parameter-string)
+ ""
+ (string-append "?" query-parameter-string))))))
+ "View JSON")))))
+ (div
+ (@ (class "row"))
+ (div
+ (@ (class "col-sm-12"))
+ (h2 "Outputs")
+ ,@(let ((outputs (assq-ref data 'outputs)))
+ `((table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "Name")
+ (th "Path")
+ (th "Hash algorithm")
+ (th "Hash")
+ (th "Recursive")))
+ (tbody
+ ,@(let ((base-outputs (assq-ref outputs 'base))
+ (target-outputs (assq-ref outputs 'target))
+ (common-outputs (assq-ref outputs 'common)))
+ (append-map
+ (lambda (label items)
+ (map
+ (match-lambda
+ ((name path hash-algorithm hash recursive)
+ `(tr
+ (td ,label)
+ (td ,name)
+ (td (a (@ (href ,path))
+ ,(display-store-item path)))
+ (td ,hash-algorithm)
+ (td ,hash)
+ (td ,recursive))))
+ (or items '())))
+ (list base target "Common")
+ (list (assq-ref outputs 'base)
+ (assq-ref outputs 'target)
+ (assq-ref outputs 'common))))))))
+ (h2 "Inputs")
+ ,@(let ((inputs (assq-ref data 'inputs)))
+ `((table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "Derivation")
+ (th "Outputs")))
+ (tbody
+ ,@(append-map
+ (lambda (label items)
+ (map
+ (match-lambda
+ ((derivation outputs)
+ `(tr
+ (td ,label)
+ (td (a (@ (href ,derivation))
+ ,(display-store-item derivation)))
+ (td ,outputs))))
+ (or items '())))
+ (list base target)
+ (list (assq-ref inputs 'base)
+ (assq-ref inputs 'target)))))))
+ (p "Common inputs are omitted.")
+ (h2 "Sources")
+ ,@(let ((sources (assq-ref data 'sources)))
+ `((table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "Derivation")))
+ (tbody
+ ,@(append-map
+ (lambda (label items)
+ (map
+ (match-lambda
+ ((file)
+ `(tr
+ (td ,label)
+ (td (a (@ (href ,file))
+ ,(display-store-item file))))))
+ (or items '())))
+ (list base target "Common")
+ (list (assq-ref sources 'base)
+ (assq-ref sources 'target)
+ (assq-ref sources 'common)))))))
+ (h2 "System")
+ ,@(let ((system (assq-ref data 'system)))
+ (let ((common-system (assq-ref system 'common)))
+ (if common-system
+ (list common-system)
+ `(table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "System")))
+ (tbody
+ ,@(let ((base-system (assq-ref system 'base))
+ (target-system (assq-ref system 'target)))
+ `((tr
+ (td ,base)
+ (td ,base-system))
+ (tr
+ (td ,target)
+ (td ,target-system)))))))))
+ (h2 "Builder and arguments")
+ ,(let ((builder (assq-ref data 'builder))
+ (arguments (assq-ref data 'arguments)))
+ (let ((common-builder (assq-ref builder 'common))
+ (common-args (assq-ref arguments 'common)))
+ (if (and common-builder
+ common-args)
+ `(table
+ (@ (class "table"))
+ (thead
+ (th "Builder")
+ (th "Arguments"))
+ (tbody
+ (tr
+ (td ,common-builder)
+ (td (ol
+ ,@(map (lambda (arg)
+ `(li ,arg))
+ common-args))))))
+ `(table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "Builder")
+ (th "Arguments")))
+ (tbody
+ ,@(let ((base-builder (assq-ref builder 'base))
+ (target-builder (assq-ref builder 'target))
+ (base-args (assq-ref arguments 'base))
+ (target-args (assq-ref arguments 'target)))
+ `((tr
+ (td ,base)
+ (td ,(or base-builder
+ common-builder))
+ (td (ol
+ ,@(map (lambda (arg)
+ `(li ,arg))
+ (or common-args
+ base-args)))))
+ (tr
+ (td ,target)
+ (td ,(or target-builder
+ common-builder))
+ (td (ol
+ ,@(map (lambda (arg)
+ `(li ,arg))
+ (or common-args
+ target-args))))))))))))
+ (h2 "Environment variables")
+ ,(let ((environment-variables (assq-ref data 'environment-variables)))
+ `(table
+ (@ (class "table"))
+ (thead
+ (th "Name"))
+ (tbody
+ ,@(append-map
+ (match-lambda
+ ((name . values)
+ (let ((common-value (assq-ref values 'common)))
+ (if common-value
+ `((tr
+ (td ,name)
+ (td ,common-value)))
+ (let ((base-value (assq-ref values 'base))
+ (target-value (assq-ref values 'target)))
+ (if (and base-value target-value)
+ `((tr
+ (td (@ (rowspan 2))
+ ,name)
+ (td ,base ,base-value))
+ (tr
+ (td ,target ,target-value)))
+ `((tr
+ (td ,name)
+ (td ,@(if base-value
+ (list base base-value)
+ (list target target-value)))))))))))
+ environment-variables))))))))))
+
(define (compare/derivations query-parameters
valid-systems
valid-build-statuses
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index b403890..9381b2b 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -32,6 +32,7 @@
header
form-horizontal-control
+ display-store-item
display-store-item-short
build-status-span
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-29 14:32:32 +0000