guix/data-service
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/data-service.git synced 2023-12-14 03:23:03 +01:00
Code Issues Releases Wiki Activity

Add verbose output to the query-build-servers script

Browse source
This commit is contained in:
Christopher Baines 2020-02-15 19:54:42 +00:00
parent 617af6c9d3
commit 33749786e4
2 changed files with 45 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
guix-data-service/builds.scm
View file

@ -114,19 +114,25 @@ initial connection on which HTTP requests are sent."
(_ (_
(loop tail (+ 1 processed) result)))))))))) ;keep going (loop tail (+ 1 processed) result)))))))))) ;keep going
(define (query-build-servers conn build-server-ids revision-commits) (define verbose-output?
(while #t (make-parameter #f))
(let ((build-servers (select-build-servers conn)))
(for-each (define* (query-build-servers conn build-server-ids revision-commits
(match-lambda #:key verbose?)
((id url lookup-all-derivations?) (parameterize
(when (or (or (not build-servers) ((verbose-output? verbose?))
(not build-server-ids)) (while #t
(member id build-server-ids)) (let ((build-servers (select-build-servers conn)))
(when lookup-all-derivations? (for-each
(simple-format #t "\nQuerying ~A\n" url) (match-lambda
(query-build-server conn id url revision-commits))))) ((id url lookup-all-derivations?)
build-servers)))) (when (or (or (not build-servers)
(not build-server-ids))
(member id build-server-ids))
(when lookup-all-derivations?
(simple-format #t "\nQuerying ~A\n" url)
(query-build-server conn id url revision-commits)))))
build-servers)))))
(define (query-build-server conn id url revision-commits) (define (query-build-server conn id url revision-commits)
(simple-format #t "\nFetching pending builds\n") (simple-format #t "\nFetching pending builds\n")
@ -213,19 +219,26 @@ initial connection on which HTTP requests are sent."
(fetch-builds-by-output (fetch-builds-by-output
url url
derivation-outputs derivation-outputs
(lambda (data) (lambda (data output)
(if data (if data
(let ((build-id (let* ((derivation
(ensure-build-exists conn (assoc-ref data "derivation"))
build-server-id (build-id
(assoc-ref data "derivation")))) (ensure-build-exists conn
build-server-id
derivation)))
(insert-build-statuses-from-data (insert-build-statuses-from-data
conn conn
build-server-id build-server-id
build-id build-id
(assoc-ref data "build")) (assoc-ref data "build"))
(display "-")) (if (verbose-output?)
(display "."))))) (simple-format #t "found build for: ~A (~A)\n"
output derivation)
(display "-")))
(if (verbose-output?)
(simple-format #t "no build found: ~A\n" output)
(display "."))))))
(define (process-derivations conn build-server-id url revision-commits) (define (process-derivations conn build-server-id url revision-commits)
(define derivations (define derivations
@ -336,7 +349,12 @@ initial connection on which HTTP requests are sent."
(bytevector->string response-body (bytevector->string response-body
"utf-8"))) "utf-8")))
(else (else
#f))))) #f))
(string-append
"/gnu/store"
(string-drop
(uri-path (request-uri request))
(string-length "/output"))))))
'() '()
(map (lambda (output-file-name) (map (lambda (output-file-name)
(build-request (build-request

8
scripts/guix-data-service-query-build-servers.in
View file

@ -35,7 +35,10 @@
(cons (string->number arg) (cons (string->number arg)
(or (assoc-ref result 'build-server-ids) (or (assoc-ref result 'build-server-ids)
'())) '()))
(alist-delete 'build-server-ids result)))))) (alist-delete 'build-server-ids result))))
(option '("verbose") #f #f
(lambda (opt name _ result)
(alist-cons 'verbose #t result)))))
(define %default-options (define %default-options
;; Alist of default option values ;; Alist of default option values
@ -61,4 +64,5 @@
(lambda (conn) (lambda (conn)
(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)
#:verbose? (assq-ref opts 'verbose)))))