cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Query substitutes for latest processed revisions periodically

Browse source 
This is a step towards having up to date substitute availability data.
This commit is contained in:
Christopher Baines 2021-11-16 19:08:46 +00:00
parent ba9bcbf735
commit 8beab2511c
2 changed files with 66 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

86
guix-data-service/substitutes.scm
View file

@ -19,12 +19,16 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (guix substitutes)
#:use-module (guix narinfo)
#:use-module (guix-data-service database)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model git-branch)
#:use-module (guix-data-service model git-repository)
#:use-module (guix-data-service model nar)
#:export (query-build-server-substitutes))
#:export (query-build-server-substitutes
start-substitute-query-thread))
(define verbose-output?
(make-parameter #f))
@ -34,28 +38,27 @@
#:key verbose?)
(parameterize
((verbose-output? verbose?))
(while #t
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations? lookup-builds?)
(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)
(catch #t
(lambda ()
(simple-format #t "\nFetching narinfo files\n")
(fetch-narinfo-files conn id url revision-commits
#:specific-outputs
outputs))
(lambda (key . args)
(simple-format
(current-error-port)
"exception in query-build-server: ~A ~A\n"
key args)))))))
build-servers)))))
(let ((build-servers (select-build-servers conn)))
(for-each
(match-lambda
((id url lookup-all-derivations? lookup-builds?)
(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)
(catch #t
(lambda ()
(simple-format #t "\nFetching narinfo files\n")
(fetch-narinfo-files conn id url revision-commits
#:specific-outputs
outputs))
(lambda (key . args)
(simple-format
(current-error-port)
"exception in query-build-server: ~A ~A\n"
key args)))))))
build-servers))))
(define %narinfo-max-size
(- (expt 2 (- (* 8 8) ;; 8 bytes
@ -110,3 +113,40 @@
conn
build-server-id
filtered-narinfos)))))))
(define (start-substitute-query-thread)
(call-with-new-thread
(lambda ()
(while #t
(with-exception-handler
(lambda (exn)
(simple-format (current-error-port)
"exception when querying substitutes: ~A\n"
exn))
(lambda ()
(with-postgresql-connection
"substitute-query-thread"
(lambda (conn)
(for-each
(match-lambda
((git-repository-id rest ...)
(for-each
(match-lambda
((branch-name rest ...)
(and=> (latest-processed-commit-for-branch
conn
(number->string git-repository-id)
branch-name)
(lambda (commit)
(query-build-server-substitutes
conn
#f ;; All build servers
(list commit)
#f)))))
(all-branches-with-most-recent-commit
conn
git-repository-id))))
(all-git-repositories conn))))
(simple-format #t "finished checking substitutes, now sleeping\n")
(sleep (* 60 30))))))))

3
scripts/guix-data-service.in
View file

@ -33,6 +33,7 @@
(guix pki)
(guix-data-service config)
(guix-data-service database)
(guix-data-service substitutes)
(guix-data-service web server)
(guix-data-service web controller)
(guix-data-service web nar controller))
@ -227,6 +228,8 @@
(%show-error-details
(assoc-ref opts 'show-error-details)))
(start-substitute-query-thread)
;; Provide some visual space between the startup output and the server
;; starting
(simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"