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