From f58fe208fd680fa4480f0f363209dc5ee5faa8bb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 26 Dec 2020 13:40:09 +0000 Subject: [PATCH] Support finding fixed output derivations for packages This finds all the fixed output derivations in the graph of packages. I'm planning to use this to queue builds for these derivations on a regular basis, to monitor when fixed output derivations break (as the thing they download has disappeared for example). --- guix-data-service/web/revision/controller.scm | 117 ++++++++++++++ guix-data-service/web/revision/html.scm | 143 ++++++++++++++++++ 2 files changed, 260 insertions(+) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 8dc75a8..f9fd2db 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -58,6 +58,7 @@ render-revision-package-reproduciblity render-revision-package-substitute-availability render-revision-package-derivations + render-revision-fixed-output-package-derivations render-revision-package-derivation-outputs render-unknown-revision render-view-revision)) @@ -219,6 +220,32 @@ #:path-base path)) (render-unknown-revision mime-types commit-hash))) + (('GET "revision" commit-hash "fixed-output-package-derivations") + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) + (let ((parsed-query-parameters + (guard-against-mutually-exclusive-query-parameters + (parse-query-parameters + request + `((system ,parse-system #:default "x86_64-linux") + (target ,parse-target #:default "") + (latest_build_status ,parse-build-status) + (after_name ,identity) + (limit_results ,parse-result-limit + #:no-default-when (all_results) + #:default 50) + (all_results ,parse-checkbox-value))) + '((limit_results all_results))))) + + (render-revision-fixed-output-package-derivations + mime-types + commit-hash + parsed-query-parameters + #:path-base path)) + (render-unknown-revision mime-types + commit-hash))) (('GET "revision" commit-hash "package-derivation-outputs") (if (parallel-via-thread-pool-channel (with-thread-postgresql-connection @@ -1061,6 +1088,96 @@ #:header-text header-text #:header-link header-link)))))))))) +(define* (render-revision-fixed-output-package-derivations + mime-types + commit-hash + query-parameters + #:key + (path-base "/revision/") + (header-text + `("Revision " (samp ,commit-hash))) + (header-link + (string-append "/revision/" + commit-hash))) + (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 + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml (view-revision-fixed-output-package-derivations + commit-hash + query-parameters + systems + (valid-targets->options targets) + '() + '() + #f + #:path-base path-base + #:header-text header-text + #:header-link header-link))))) + (let ((limit-results + (assq-ref query-parameters 'limit_results)) + (all-results + (assq-ref query-parameters 'all_results)) + (search-query + (assq-ref query-parameters 'search_query)) + (fields + (assq-ref query-parameters 'field))) + (letpar& + ((derivations + (with-thread-postgresql-connection + (lambda (conn) + (select-fixed-output-package-derivations-in-revision + conn + commit-hash + (assq-ref query-parameters 'system) + (assq-ref query-parameters 'target) + #:latest-build-status (assq-ref query-parameters + 'latest_build_status) + #:limit-results limit-results + #:after-derivation-file-name + (assq-ref query-parameters 'after_name))))) + (build-server-urls + (with-thread-postgresql-connection + select-build-server-urls-by-id))) + (let ((show-next-page? + (if all-results + #f + (and (not (null? derivations)) + (>= (length derivations) + limit-results))))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((derivations . ,(list->vector derivations))))) + (else + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml (view-revision-fixed-output-package-derivations + commit-hash + query-parameters + systems + (valid-targets->options targets) + derivations + build-server-urls + show-next-page? + #:path-base path-base + #:header-text header-text + #:header-link header-link)))))))))) + (define* (render-revision-package-derivation-outputs mime-types commit-hash diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 8ed7eee..2a1008e 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -36,6 +36,7 @@ view-revision-packages view-revision-packages-translation-availability view-revision-package-derivations + view-revision-fixed-output-package-derivations view-revision-package-derivation-outputs view-revision-system-tests view-revision-channel-instances @@ -1682,6 +1683,148 @@ figure { "Next page"))) '()))))))) +(define* (view-revision-fixed-output-package-derivations + commit-hash + query-parameters + valid-systems + valid-targets + derivations + build-server-urls + show-next-page? + #:key (path-base "/revision/") + header-text + header-link) + (define build-status-options + '(("" . "") + ("Succeeded" . "succeeded") + ("Failed" . "failed") + ;;("Unknown" . "unknown") TODO + )) + + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 (a (@ (style "white-space: nowrap;") + (href ,header-link)) + ,@header-text)))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (style "padding-bottom: 0") + (class "form-horizontal")) + ,(form-horizontal-control + "System" query-parameters + #:options valid-systems + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Target" query-parameters + #:options valid-targets + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations that are build for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Latest build status" query-parameters + #:allow-selecting-multiple-options #f + #:options build-status-options + #:help-text "Only show derivations with this overall build status.") + ,(form-horizontal-control + "After name" query-parameters + #:help-text + "List derivations that are alphabetically after the given name.") + ,(form-horizontal-control + "Limit results" query-parameters + #:help-text "The maximum number of derivations to return.") + ,(form-horizontal-control + "All results" query-parameters + #:type "checkbox" + #:help-text "Return all results.") + (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"))))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (a (@ (class "btn btn-default btn-lg pull-right") + (href ,(let ((query-parameter-string + (query-parameters->string query-parameters))) + (string-append + path-base ".json" + (if (string-null? query-parameter-string) + "" + (string-append "?" query-parameter-string)))))) + "View JSON"))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (h1 "Fixed output package derivations") + (p "Showing " ,(length derivations) " results") + (table + (@ (class "table")) + (thead + (tr + (th "File name") + (th "Latest build"))) + (tbody + ,@(map + (lambda (row) + (let ((derivation-file-name (assq-ref row 'derivation_file_name)) + (latest-build (assq-ref row 'latest_build))) + `(tr + (td (a (@ (href ,derivation-file-name)) + ,(display-store-item-short derivation-file-name))) + (td + (dl + (@ (style "margin-bottom: 0;")) + ,@(if (eq? 'null latest-build) + '() + (let ((build-server-id + (assq-ref latest-build 'build_server_id))) + `((dt + (@ (style "font-weight: unset;")) + (a (@ (href + ,(assq-ref build-server-urls + build-server-id))) + ,(assq-ref build-server-urls + build-server-id))) + (dd + (a (@ (href ,(build-url + build-server-id + (assq-ref latest-build + 'build_server_build_id) + derivation-file-name))) + ,(build-status-alist->build-icon + latest-build))))))))))) + derivations))) + ,@(if show-next-page? + `((div + (@ (class "row")) + (a (@ (href + ,(next-page-link path-base + query-parameters + 'after_name + (assq-ref (last derivations) + 'derivation_file_name)))) + "Next page"))) + '()))))))) + (define* (view-revision-package-derivation-outputs commit-hash query-parameters derivation-outputs