From b5ce2b216612294ff5ab51f76e2dff074c993f73 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 10 Nov 2019 21:28:10 +0000 Subject: WIP --- guix-data-service/comparison.scm | 209 ++++++++++++++++++++++++++- guix-data-service/web/compare/controller.scm | 52 +++++++ guix-data-service/web/compare/html.scm | 100 +++++++++++++ 3 files changed, 360 insertions(+), 1 deletion(-) 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 -- cgit v1.2.3