aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2019-11-10 21:28:10 +0000
committerChristopher Baines <mail@cbaines.net>2019-11-10 21:28:10 +0000
commitb5ce2b216612294ff5ab51f76e2dff074c993f73 (patch)
tree99b6b041df3ef6cf8617dcb71a30213284ac1655
parentab51599057464aec3f08c078405dd48148c9a880 (diff)
downloaddata-service-wip-derivation-comparison.tar
data-service-wip-derivation-comparison.tar.gz
-rw-r--r--guix-data-service/comparison.scm209
-rw-r--r--guix-data-service/web/compare/controller.scm52
-rw-r--r--guix-data-service/web/compare/html.scm100
3 files changed, 360 insertions, 1 deletions
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 9aa8863..a706a41 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -4,8 +4,11 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (squee)
+ #:use-module (guix-data-service model utils)
#:use-module (guix-data-service model derivation)
- #:export (package-data->package-data-vhashes
+ #:export (derivation-differences-data
+
+ package-data->package-data-vhashes
package-differences-data
package-data-vhash->derivations
package-data->names-and-versions
@@ -17,6 +20,210 @@
lint-warning-differences-data))
+(define (group-to-alist process lst)
+ (fold (lambda (element result)
+ (match (process element)
+ ((key . value)
+ (match (assoc key result)
+ ((_ . existing-values)
+ `((,key . ,(cons value existing-values))
+ ,@result))
+ (#f
+ `((,key . (,value))
+ ,@result))))))
+ '()
+ lst))
+
+(define (derivation-differences-data conn
+ base-derivation-file-name
+ target-derivation-file-name)
+ (define base-derivation
+ (select-derivation-by-file-name conn base-derivation-file-name))
+
+ (define target-derivation
+ (select-derivation-by-file-name conn target-derivation-file-name))
+
+ (define group-by-last-element
+ (lambda (vals)
+ (let ((groups (last vals)))
+ (cons (if (eq? (length groups) 2)
+ 'common
+ (first groups))
+ (drop-right vals 1)))))
+
+ `((outputs
+ . ,(group-to-alist
+ group-by-last-element
+ (derivation-outputs-differences-data conn
+ (first base-derivation)
+ (first target-derivation))))
+ (inputs
+ . ,(group-to-alist
+ group-by-last-element
+ (derivation-inputs-differences-data conn
+ (first base-derivation)
+ (first target-derivation))))
+ (sources
+ . ,(group-to-alist
+ group-by-last-element
+ (derivation-sources-differences-data conn
+ (first base-derivation)
+ (first target-derivation))))
+ ,@(match base-derivation
+ ((_ _ base-builder base-args base-env-vars base-system)
+ (match target-derivation
+ ((_ _ target-builder target-args target-env-vars target-system)
+ `((system
+ . ,(if (string=? base-system target-system)
+ `((common . ,base-system))
+ `((base . ,base-system)
+ (target . ,target-system))))
+ (builder
+ . ,(if (string=? base-builder target-builder)
+ `((common . ,base-builder))
+ `((base . ,base-builder)
+ (target . ,target-builder))))
+ (arguments
+ . ,(if (eq? base-args target-args)
+ `((common . ,base-args))
+ `((base . ,base-args)
+ (target . ,target-args))))
+ (environment-variables
+ . ,(map (lambda (key)
+ (let ((base-value (assq-ref base-env-vars key))
+ (target-value (assq-ref target-env-vars key)))
+ (if (and base-value target-value)
+ `(,key
+ . ,(if (string=? base-value target-value)
+ `((common . ,base-value))
+ `((base . ,base-value)
+ (target . target-value))))
+ (if base-value
+ `(,key . ((base . ,base-value)))
+ `(,key . ((target . ,target-value)))))))
+ (delete-duplicates
+ (map (lambda (env-var)
+ (assq-ref env-var 'key))
+ (append base-env-vars
+ target-env-vars))
+ string=?))))))))))
+
+(define (derivation-outputs-differences-data conn
+ base-derivation-id
+ target-derivation-id)
+ (define query
+ (string-append
+ "
+SELECT derivation_outputs.name,
+ derivation_output_details.path,
+ derivation_output_details.hash_algorithm,
+ derivation_output_details.hash,
+ derivation_output_details.recursive,
+ ARRAY_AGG(derivation_outputs.derivation_id) AS derivation_ids
+FROM derivation_outputs
+INNER JOIN derivation_output_details
+ ON derivation_output_details_id = derivation_output_details.id
+WHERE derivation_outputs.derivation_id IN ("
+ (simple-format #f "~A,~A"
+ base-derivation-id
+ target-derivation-id) "
+)
+GROUP BY 1, 2, 3, 4, 5"))
+
+ (map (match-lambda
+ ((output-name path hash-algorithm hash recursive
+ derivation_ids)
+ (let ((parsed-derivation-ids
+ (map string->number
+ (parse-postgresql-array-string derivation_ids))))
+ (list output-name
+ path
+ hash-algorithm
+ hash
+ recursive
+ (append (if (memq base-derivation-id
+ parsed-derivation-ids)
+ '(base)
+ '())
+ (if (memq target-derivation-id
+ parsed-derivation-ids)
+ '(target)
+ '()))))))
+ (exec-query conn query)))
+
+(define (derivation-inputs-differences-data conn
+ base-derivation-id
+ target-derivation-id)
+ (define query
+ (string-append
+ "
+SELECT derivations.file_name,
+ derivation_outputs.name,
+ relevant_derivation_inputs.derivation_ids
+FROM derivation_outputs
+INNER JOIN (
+ SELECT derivation_output_id,
+ ARRAY_AGG(derivation_id) AS derivation_ids
+ FROM derivation_inputs
+ WHERE derivation_id IN (" (simple-format #f "~A,~A"
+ base-derivation-id
+ target-derivation-id)
+ ") GROUP BY derivation_output_id
+) AS relevant_derivation_inputs
+ ON derivation_outputs.id = relevant_derivation_inputs.derivation_output_id
+INNER JOIN derivations ON derivation_outputs.derivation_id = derivations.id
+"))
+
+ (map (match-lambda
+ ((derivation_file_name derivation_output_name
+ derivation_ids)
+ (let ((parsed-derivation-ids
+ (map string->number
+ (parse-postgresql-array-string derivation_ids))))
+ (list derivation_file_name
+ derivation_output_name
+ (append (if (memq base-derivation-id
+ parsed-derivation-ids)
+ '(base)
+ '())
+ (if (memq target-derivation-id
+ parsed-derivation-ids)
+ '(target)
+ '()))))))
+ (exec-query conn query)))
+
+(define (derivation-sources-differences-data conn
+ base-derivation-id
+ target-derivation-id)
+ (define query
+ (string-append
+ "
+SELECT derivation_source_files.store_path, ARRAY_AGG(derivation_sources.derivation_id)
+FROM derivation_source_files
+INNER JOIN derivation_sources
+ ON derivation_source_files.id = derivation_sources.derivation_source_file_id
+WHERE derivation_sources.derivation_id IN (" (simple-format #f "~A,~A"
+ base-derivation-id
+ target-derivation-id)
+")
+GROUP BY derivation_source_files.store_path"))
+
+ (map (match-lambda
+ ((store_path derivation_ids)
+ (let ((parsed-derivation-ids
+ (map string->number
+ (parse-postgresql-array-string derivation_ids))))
+ (list store_path
+ (append (if (memq base-derivation-id
+ parsed-derivation-ids)
+ '(base)
+ '())
+ (if (memq target-derivation-id
+ parsed-derivation-ids)
+ '(target)
+ '()))))))
+ (exec-query conn query)))
+
(define* (package-differences-data conn
base_guix_revision_id
target_guix_revision_id
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm
index 381d25b..902b18c 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
+ data
+ #: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 86be5a9..90f4968 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,105 @@
warnings))))))
lint-warnings-data))))))))
+(define (compare/derivation query-parameters data)
+ (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)))
+ (peek outputs))
+ (h2 "Inputs")
+ ,@(let ((inputs (assq-ref data 'inputs)))
+ `((table
+ (@ (class "table"))
+ (thead
+ (tr
+ (th "")
+ (th "Derivation")
+ (th "Outputs")))
+ (tbody
+ ,@(let ((base-inputs (assq-ref inputs 'base))
+ (target-inputs (assq-ref inputs 'target))
+ (common-inputs (assq-ref inputs 'common)))
+ (append-map
+ (lambda (label items)
+ (map
+ (match-lambda
+ ((derivation outputs)
+ `(tr
+ (td ,label)
+ (td ,derivation)
+ (td ,outputs))))
+ items))
+ (list "Base" "Target")
+ (list (assq-ref inputs 'base)
+ (assq-ref inputs 'target))))))))
+ (h2 "Sources")
+ ,@(let ((sources (assq-ref data 'sources)))
+ sources)
+ (h2 "System")
+ ,@(let ((system (assq-ref data 'system)))
+ system)
+ (h2 "Builder")
+ ,@(let ((builder (assq-ref data 'builder)))
+ builder)
+ (h2 "Arguments")
+ ,@(let ((arguments (assq-ref data 'arguments)))
+ arguments)
+ (h2 "Environment variables")
+ ,(let ((environment-variables (assq-ref data 'environment-variables)))
+ environment-variables)))))))
+
(define (compare/derivations query-parameters
valid-systems
valid-build-statuses