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
(define (query-build-servers conn build-server-ids revision-commits)
(while #t
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations?)
(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 verbose-output?
(make-parameter #f))
(define* (query-build-servers conn build-server-ids revision-commits
#:key verbose?)
(parameterize
((verbose-output? verbose?))
(while #t
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations?)
(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)
(simple-format #t "\nFetching pending builds\n")
@ -213,19 +219,26 @@ initial connection on which HTTP requests are sent."
(fetch-builds-by-output
url
derivation-outputs
(lambda (data)
(lambda (data output)
(if data
(let ((build-id
(ensure-build-exists conn
build-server-id
(assoc-ref data "derivation"))))
(let* ((derivation
(assoc-ref data "derivation"))
(build-id
(ensure-build-exists conn
build-server-id
derivation)))
(insert-build-statuses-from-data
conn
build-server-id
build-id
(assoc-ref data "build"))
(display "-"))
(display ".")))))
(if (verbose-output?)
(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 derivations
@ -336,7 +349,12 @@ initial connection on which HTTP requests are sent."
(bytevector->string response-body
"utf-8")))
(else
#f)))))
#f))
(string-append
"/gnu/store"
(string-drop
(uri-path (request-uri request))
(string-length "/output"))))))
'()
(map (lambda (output-file-name)
(build-request

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

@ -35,7 +35,10 @@
(cons (string->number arg)
(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
;; Alist of default option values
@ -61,4 +64,5 @@
(lambda (conn)
(query-build-servers conn
(assq-ref opts 'build-server-ids)
(assq-ref opts 'revision-commits)))))
(assq-ref opts 'revision-commits)
#:verbose? (assq-ref opts 'verbose)))))