mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Make it possible to query builds servers for specific outputs
This commit is contained in:
parent
6f97cec962
commit
9c7310f8e3
|
@ -119,6 +119,7 @@ initial connection on which HTTP requests are sent."
|
||||||
(make-parameter #f))
|
(make-parameter #f))
|
||||||
|
|
||||||
(define* (query-build-servers conn build-server-ids revision-commits
|
(define* (query-build-servers conn build-server-ids revision-commits
|
||||||
|
outputs
|
||||||
#:key verbose?)
|
#:key verbose?)
|
||||||
(parameterize
|
(parameterize
|
||||||
((verbose-output? verbose?))
|
((verbose-output? verbose?))
|
||||||
|
@ -134,7 +135,7 @@ initial connection on which HTTP requests are sent."
|
||||||
(simple-format #t "\nQuerying ~A\n" url)
|
(simple-format #t "\nQuerying ~A\n" url)
|
||||||
(catch #t
|
(catch #t
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(query-build-server conn id url revision-commits))
|
(query-build-server conn id url revision-commits outputs))
|
||||||
(lambda (key . args)
|
(lambda (key . args)
|
||||||
(simple-format
|
(simple-format
|
||||||
(current-error-port)
|
(current-error-port)
|
||||||
|
@ -142,11 +143,40 @@ initial connection on which HTTP requests are sent."
|
||||||
key args)))))))
|
key args)))))))
|
||||||
build-servers)))))
|
build-servers)))))
|
||||||
|
|
||||||
(define (query-build-server conn id url revision-commits)
|
(define (query-build-server conn id url revision-commits outputs)
|
||||||
|
(define (fetch-derivation-output-details-set-id output)
|
||||||
|
(match (exec-query
|
||||||
|
conn
|
||||||
|
"
|
||||||
|
SELECT derivations_by_output_details_set.derivation_output_details_set_id
|
||||||
|
FROM derivations_by_output_details_set
|
||||||
|
INNER JOIN derivation_outputs
|
||||||
|
ON derivation_outputs.derivation_id =
|
||||||
|
derivations_by_output_details_set.derivation_id
|
||||||
|
INNER JOIN derivation_output_details
|
||||||
|
ON derivation_outputs.derivation_output_details_id =
|
||||||
|
derivation_output_details.id
|
||||||
|
WHERE derivation_output_details.path = $1"
|
||||||
|
(list output))
|
||||||
|
(((id))
|
||||||
|
(string->number id))
|
||||||
|
(() #f)))
|
||||||
|
|
||||||
(simple-format #t "\nFetching pending builds\n")
|
(simple-format #t "\nFetching pending builds\n")
|
||||||
(process-pending-builds conn id url)
|
(process-pending-builds conn id url)
|
||||||
(simple-format #t "\nFetching unseen derivations\n")
|
(simple-format #t "\nFetching unseen derivations\n")
|
||||||
(process-derivation-outputs conn id url revision-commits)
|
(process-derivation-outputs
|
||||||
|
conn id url
|
||||||
|
(if outputs
|
||||||
|
(fold (lambda (output result)
|
||||||
|
(vhash-cons output
|
||||||
|
(fetch-derivation-output-details-set-id output)
|
||||||
|
result))
|
||||||
|
vlist-null
|
||||||
|
outputs)
|
||||||
|
(select-derivation-outputs-with-no-known-build conn
|
||||||
|
id
|
||||||
|
revision-commits)))
|
||||||
(simple-format #t "\nFetching narinfo files\n")
|
(simple-format #t "\nFetching narinfo files\n")
|
||||||
(fetch-narinfo-files conn id url revision-commits))
|
(fetch-narinfo-files conn id url revision-commits))
|
||||||
|
|
||||||
|
@ -216,12 +246,8 @@ initial connection on which HTTP requests are sent."
|
||||||
(usleep 200)))
|
(usleep 200)))
|
||||||
(select-pending-builds conn build-server-id)))
|
(select-pending-builds conn build-server-id)))
|
||||||
|
|
||||||
(define (process-derivation-outputs conn build-server-id url revision-commits)
|
(define (process-derivation-outputs conn build-server-id url
|
||||||
(define derivation-output-paths-and-details-sets-ids
|
derivation-output-paths-and-details-sets-ids)
|
||||||
(select-derivation-outputs-with-no-known-build conn
|
|
||||||
build-server-id
|
|
||||||
revision-commits))
|
|
||||||
|
|
||||||
(simple-format (current-error-port) "Fetching ~A derivation outputs\n"
|
(simple-format (current-error-port) "Fetching ~A derivation outputs\n"
|
||||||
(vlist-length derivation-output-paths-and-details-sets-ids))
|
(vlist-length derivation-output-paths-and-details-sets-ids))
|
||||||
(fetch-builds-by-output
|
(fetch-builds-by-output
|
||||||
|
@ -244,9 +270,12 @@ initial connection on which HTTP requests are sent."
|
||||||
build-server-id
|
build-server-id
|
||||||
derivation
|
derivation
|
||||||
#:derivation-output-details-set-id
|
#:derivation-output-details-set-id
|
||||||
(cdr
|
(match
|
||||||
(vhash-assoc output
|
(vhash-assoc
|
||||||
derivation-output-paths-and-details-sets-ids)))))
|
output
|
||||||
|
derivation-output-paths-and-details-sets-ids)
|
||||||
|
((key . value) value)
|
||||||
|
(#f #f)))))
|
||||||
(insert-build-statuses-from-data
|
(insert-build-statuses-from-data
|
||||||
conn
|
conn
|
||||||
build-server-id
|
build-server-id
|
||||||
|
|
|
@ -50,12 +50,15 @@
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(error "unrecognized option" name))
|
(error "unrecognized option" name))
|
||||||
(lambda (arg result)
|
(lambda (arg result)
|
||||||
(alist-cons
|
(let ((type (if (string-prefix? "/gnu/store/" arg)
|
||||||
'revision-commits
|
'outputs
|
||||||
(cons arg
|
'revision-commits)))
|
||||||
(or (assoc-ref result 'revision-commits)
|
(alist-cons
|
||||||
'()))
|
type
|
||||||
(alist-delete 'revision-commits result)))
|
(cons arg
|
||||||
|
(or (assoc-ref result type)
|
||||||
|
'()))
|
||||||
|
(alist-delete type result))))
|
||||||
%default-options))
|
%default-options))
|
||||||
|
|
||||||
(let ((opts (parse-options (cdr (program-arguments)))))
|
(let ((opts (parse-options (cdr (program-arguments)))))
|
||||||
|
@ -65,4 +68,5 @@
|
||||||
(query-build-servers conn
|
(query-build-servers conn
|
||||||
(assq-ref opts 'build-server-ids)
|
(assq-ref opts 'build-server-ids)
|
||||||
(assq-ref opts 'revision-commits)
|
(assq-ref opts 'revision-commits)
|
||||||
|
(assq-ref opts 'outputs)
|
||||||
#:verbose? (assq-ref opts 'verbose)))))
|
#:verbose? (assq-ref opts 'verbose)))))
|
||||||
|
|
Loading…
Reference in a new issue