diff options
| -rw-r--r-- | guix-data-service/comparison.scm | 83 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 72 | ||||
| -rw-r--r-- | guix-data-service/model/package.scm | 44 | ||||
| -rw-r--r-- | guix-data-service/model/utils.scm | 10 | ||||
| -rw-r--r-- | guix-data-service/web/compare/controller.scm | 52 | ||||
| -rw-r--r-- | guix-data-service/web/compare/html.scm | 59 | ||||
| -rw-r--r-- | guix-data-service/web/repository/controller.scm | 36 | ||||
| -rw-r--r-- | guix-data-service/web/repository/html.scm | 154 | ||||
| -rw-r--r-- | sqitch/deploy/package_derivations_by_guix_revision_range.sql | 17 | ||||
| -rw-r--r-- | sqitch/revert/package_derivations_by_guix_revision_range.sql | 7 | ||||
| -rw-r--r-- | sqitch/sqitch.plan | 1 | ||||
| -rw-r--r-- | sqitch/verify/package_derivations_by_guix_revision_range.sql | 7 |
12 files changed, 538 insertions, 4 deletions
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm index 9aa8863..0c7c208 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,84 @@ 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)) + + `((inputs + . ,(group-to-alist + (match-lambda + ((file-name output-name groups) + (cons (if (eq? (length groups) 2) + 'common + (first groups)) + (list file-name output-name)))) + (derivation-inputs-differences-data conn + (string->number + (first base-derivation)) + (string->number + (first target-derivation))))))) + +(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* (package-differences-data conn base_guix_revision_id target_guix_revision_id diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 86c3a78..643df0a 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -975,6 +975,75 @@ ORDER BY packages.name, packages.version" #t) +(define (update-package-derivations-table conn git-repository-id commit) + ;; Lock the table to wait for other transactions to commit before updating + ;; the table + (exec-query + conn + " +LOCK TABLE ONLY package_derivations_by_guix_revision_range + IN SHARE ROW EXCLUSIVE MODE") + + (for-each + (match-lambda + ((branch-name) + (log-time + (simple-format #f "deleting package derivation entries for ~A" branch-name) + (lambda () + (exec-query + conn + " +DELETE FROM package_derivations_by_guix_revision_range +WHERE git_repository_id = $1 AND branch_name = $2" + (list git-repository-id + branch-name)))) + (log-time + (simple-format #f "inserting package derivation entries for ~A" branch-name) + (lambda () + (exec-query + conn + " +INSERT INTO package_derivations_by_guix_revision_range +SELECT DISTINCT + $1::integer AS git_repository_id, + $2 AS branch_name, + packages.name AS package_name, + packages.version AS package_version, + revision_packages.derivation_id AS derivation_id, + revision_packages.system AS system, + revision_packages.target AS target, + first_value(guix_revisions.id) + OVER package_version AS first_guix_revision_id, + last_value(guix_revisions.id) + OVER package_version AS last_guix_revision_id +FROM packages +INNER JOIN ( + SELECT DISTINCT package_derivations.package_id, + package_derivations.derivation_id, + package_derivations.system, + package_derivations.target, + guix_revision_package_derivations.revision_id + FROM package_derivations + INNER JOIN guix_revision_package_derivations + ON package_derivations.id = guix_revision_package_derivations.package_derivation_id +) AS revision_packages ON packages.id = revision_packages.package_id +INNER JOIN guix_revisions ON revision_packages.revision_id = guix_revisions.id +INNER JOIN git_branches ON guix_revisions.commit = git_branches.commit +WHERE git_branches.name = $2 +WINDOW package_version AS ( + PARTITION BY packages.name, packages.version, revision_packages.derivation_id + ORDER BY git_branches.datetime + RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING +) +ORDER BY packages.name, packages.version" + (list git-repository-id branch-name)))))) + (exec-query + conn + "SELECT name FROM git_branches WHERE commit = $1 AND git_repository_id = $2" + (list commit git-repository-id))) + + #t) + (define (load-new-guix-revision conn git-repository-id commit) (let ((store-item (store-item-for-git-repository-id-and-commit @@ -983,7 +1052,8 @@ ORDER BY packages.name, packages.version" (and (extract-information-from conn git-repository-id commit store-item) - (update-package-versions-table conn git-repository-id commit)) + (update-package-versions-table conn git-repository-id commit) + (update-package-derivations-table conn git-repository-id commit)) (begin (simple-format #t "Failed to generate store item for ~A\n" commit) diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm index c1cd2ae..0253a5a 100644 --- a/guix-data-service/model/package.scm +++ b/guix-data-service/model/package.scm @@ -12,7 +12,8 @@ inferior-packages->package-ids select-package-versions-for-revision - package-versions-for-branch)) + package-versions-for-branch + package-derivations-for-branch)) (define (select-existing-package-entries package-entries) (string-append "SELECT id, packages.name, packages.version, " @@ -236,3 +237,44 @@ ORDER BY first_datetime DESC, package_version DESC" (number->string git-repository-id) branch-name))) +(define (package-derivations-for-branch conn + git-repository-id + branch-name + system + target + package-name) + (exec-query + conn + " +SELECT package_version, + derivations.file_name, + first_guix_revisions.commit AS first_guix_revision_commit, + first_git_branches.datetime AS first_datetime, + last_guix_revisions.commit AS last_guix_revision_commit, + last_git_branches.datetime AS last_datetime +FROM package_derivations_by_guix_revision_range +INNER JOIN derivations + ON package_derivations_by_guix_revision_range.derivation_id = derivations.id +INNER JOIN guix_revisions AS first_guix_revisions + ON first_guix_revision_id = first_guix_revisions.id +INNER JOIN git_branches AS first_git_branches + ON first_guix_revisions.git_repository_id = first_git_branches.git_repository_id + AND first_guix_revisions.commit = first_git_branches.commit +INNER JOIN guix_revisions AS last_guix_revisions + ON last_guix_revision_id = last_guix_revisions.id +INNER JOIN git_branches AS last_git_branches + ON last_guix_revisions.git_repository_id = last_git_branches.git_repository_id + AND last_guix_revisions.commit = last_git_branches.commit +WHERE package_name = $1 +AND package_derivations_by_guix_revision_range.git_repository_id = $2 +AND package_derivations_by_guix_revision_range.branch_name = $3 +AND first_git_branches.name = $3 +AND last_git_branches.name = $3 +AND package_derivations_by_guix_revision_range.system = $4 +AND package_derivations_by_guix_revision_range.target = $5 +ORDER BY first_datetime DESC, package_version DESC" + (list package-name + (number->string git-repository-id) + branch-name + system + target))) diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm index 7798e74..a1cd432 100644 --- a/guix-data-service/model/utils.scm +++ b/guix-data-service/model/utils.scm @@ -11,6 +11,7 @@ non-empty-string-or-false exec-query->vhash two-lists->vhash + parse-postgresql-array-string deduplicate-strings group-list-by-first-n-fields insert-missing-data-and-return-all-ids)) @@ -47,6 +48,15 @@ l1 l2)) +(define (parse-postgresql-array-string s) + (if (string=? s "{}") + '() + (string-split + (string-drop-right + (string-drop s 1) + 1) + #\,))) + (define (deduplicate-strings strings) (pair-fold (lambda (pair result) 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..2055a8d 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,64 @@ 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")) + (h3 "Foo") + ,@(let ((inputs (assq-ref data 'inputs))) + (assq-ref inputs 'target)))))))) + (define (compare/derivations query-parameters valid-systems valid-build-statuses diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index 23e3559..cdc89d6 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -111,6 +111,42 @@ branch-name package-name package-versions)))))) + (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history") + (let ((package-derivations + (package-derivations-for-branch conn + (string->number repository-id) + branch-name + "x86_64-linux" + "x86_64-linux" + package-name))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((versions . ,(list->vector + (map (match-lambda + ((package-version derivation-file-name + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime) + `((version . ,package-version) + (derivation . ,derivation-file-name) + (first_revision + . ((commit . ,first-guix-revision-commit) + (datetime . ,first-datetime))) + (last_revision + . ((commit . ,last-guix-revision-commit) + (datetime . ,last-datetime)))))) + package-versions)))))) + (else + (render-html + #:sxml (view-branch-package-derivations + repository-id + branch-name + package-name + package-derivations)))))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") (let ((commit-hash (latest-processed-commit-for-branch conn repository-id branch-name))) diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm index 43f3df7..129279d 100644 --- a/guix-data-service/web/repository/html.scm +++ b/guix-data-service/web/repository/html.scm @@ -23,7 +23,8 @@ #:export (view-git-repository view-branches view-branch - view-branch-package)) + view-branch-package + view-branch-package-derivations)) (define* (view-git-repository git-repository-id label url cgit-url-base @@ -277,3 +278,154 @@ (rationalize margin-left 1) (rationalize width 1))))))))))) versions-by-revision-range)))))))))) + +(define (view-branch-package-derivations git-repository-id + branch-name + package-name + derivations-by-revision-range) + (define versions-list + (pair-fold (match-lambda* + (((last) (count result ...)) + (cons (cons last count) + result)) + (((a b rst ...) (count result ...)) + (peek a b) + (if (string=? a b) + (cons (+ 1 count) + (cons #f result)) + (cons 1 + (cons (cons a count) + result))))) + '(1) + (reverse + (map first derivations-by-revision-range)))) + + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (a (@ (href ,(string-append "/repository/" git-repository-id))) + (h3 "Repository")) + (a (@ (href ,(string-append "/repository/" git-repository-id + "/branch/" branch-name))) + (h3 ,(string-append branch-name " branch"))) + (a (@ (class "btn btn-default btn-lg pull-right") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + ".json"))) + "View JSON") + (h1 (@ (style "white-space: nowrap;")) + (samp ,package-name)))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th (@ (class "col-sm-3")) "Version") + (th (@ (class "col-sm-5")) "Derivation") + (th (@ (class "col-sm-4")) "From") + (th (@ (class "col-sm-4")) "To"))) + (tbody + ,@(let* ((times-in-seconds + (map (lambda (d) + (time-second + (date->time-monotonic + (string->date d "~Y-~m-~d ~H:~M:~S")))) + (append (map fourth derivations-by-revision-range) + (map sixth derivations-by-revision-range)))) + (earliest-date-seconds + (apply min + times-in-seconds)) + (latest-date-seconds + (apply max + times-in-seconds)) + (min-to-max-seconds + (- latest-date-seconds + earliest-date-seconds))) + (map + (match-lambda* + ((version-column-entry + (package-version derivation-file-name + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime)) + `((tr + (@ (style "border-bottom: 0;")) + ,@(match version-column-entry + (#f '()) + ((package-version . rowspan) + `((td (@ (rowspan ,(* 2 ; To account for the extra rows + rowspan))) + ,package-version)))) + (td + (a (@ (href ,derivation-file-name)) + ,(display-store-item-short derivation-file-name))) + (td (a (@ (href ,(string-append + "/revision/" first-guix-revision-commit))) + ,first-datetime) + (br) + (a (@ (href ,(string-append + "/revision/" + first-guix-revision-commit + "/package/" + package-name "/" package-version))) + "(More information)")) + (td (a (@ (href ,(string-append + "/revision/" last-guix-revision-commit))) + ,last-datetime) + (br) + (a (@ (href ,(string-append + "/revision/" + last-guix-revision-commit + "/package/" + package-name "/" package-version))) + "(More information)"))) + (tr + (td + (@ (colspan 3) + (style "border-top: 0; padding-top: 0;")) + (div + (@ + (style + ,(let* ((start-seconds + (time-second + (date->time-monotonic + (string->date first-datetime + "~Y-~m-~d ~H:~M:~S")))) + (end-seconds + (time-second + (date->time-monotonic + (string->date last-datetime + "~Y-~m-~d ~H:~M:~S")))) + (margin-left + (min + (* (/ (- start-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + 98)) + (width + (max + (- (* (/ (- end-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + margin-left) + 2))) + (simple-format + #f + "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;" + (rationalize margin-left 1) + (rationalize width 1))))))))))) + versions-list + derivations-by-revision-range)))))))))) diff --git a/sqitch/deploy/package_derivations_by_guix_revision_range.sql b/sqitch/deploy/package_derivations_by_guix_revision_range.sql new file mode 100644 index 0000000..e84c641 --- /dev/null +++ b/sqitch/deploy/package_derivations_by_guix_revision_range.sql @@ -0,0 +1,17 @@ +-- Deploy guix-data-service:package_derivations_by_guix_revision_range to pg + +BEGIN; + +CREATE TABLE package_derivations_by_guix_revision_range ( + git_repository_id integer NOT NULL REFERENCES git_repositories (id), + branch_name varchar NOT NULL, + package_name varchar NOT NULL, + package_version varchar NOT NULL, + derivation_id integer NOT NULL, + system varchar NOT NULL, + target varchar NOT NULL, + first_guix_revision_id integer NOT NULL REFERENCES guix_revisions (id), + last_guix_revision_id integer NOT NULL REFERENCES guix_revisions (id) +); + +COMMIT; diff --git a/sqitch/revert/package_derivations_by_guix_revision_range.sql b/sqitch/revert/package_derivations_by_guix_revision_range.sql new file mode 100644 index 0000000..1cc648d --- /dev/null +++ b/sqitch/revert/package_derivations_by_guix_revision_range.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:package_derivations_by_guix_revision_range from pg + +BEGIN; + +DROP TABLE package_derivations_by_guix_revision_range; + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index 14a5478..327dcc7 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -25,3 +25,4 @@ index_on_load_new_guix_revision_job_events_job_id 2019-09-29T10:39:04Z Christoph fix_null_values_in_git_branches 2019-09-29T11:06:12Z Christopher Baines <mail@cbaines.net> # Fix the NULL values in git_branches add_retry_value_to_job_event_enum 2019-10-02T19:13:52Z Christopher Baines <mail@cbaines.net> # Add retry value to job_event enum remove_guix_revision_duplicates 2019-10-05T08:00:14Z Christopher Baines <mail@cbaines.net> # Remove duplicates in the guix_revisions table +package_derivations_by_guix_revision_range 2019-11-08T19:09:48Z Christopher Baines <mail@cbaines.net> # Add package_derivations_by_guix_revision_range diff --git a/sqitch/verify/package_derivations_by_guix_revision_range.sql b/sqitch/verify/package_derivations_by_guix_revision_range.sql new file mode 100644 index 0000000..149abf6 --- /dev/null +++ b/sqitch/verify/package_derivations_by_guix_revision_range.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:package_derivations_by_guix_revision_range on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; |