[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/04: Support finding fixed output derivations for packages
|
From: |
Christopher Baines |
|
Subject: |
04/04: Support finding fixed output derivations for packages |
|
Date: |
Sat, 26 Dec 2020 08:41:47 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit f58fe208fd680fa4480f0f363209dc5ee5faa8bb
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sat Dec 26 13:40:09 2020 +0000
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