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-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (guix substitutes) #:use-module (guix substitutes)
#:use-module (guix narinfo) #:use-module (guix narinfo)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service model build-server) #: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) #:use-module (guix-data-service model nar)
#:export (query-build-server-substitutes)) #:export (query-build-server-substitutes
start-substitute-query-thread))
(define verbose-output? (define verbose-output?
(make-parameter #f)) (make-parameter #f))
@ -34,28 +38,27 @@
#:key verbose?) #:key verbose?)
(parameterize (parameterize
((verbose-output? verbose?)) ((verbose-output? verbose?))
(while #t (let ((build-servers (select-build-servers conn)))
(let ((build-servers (select-build-servers conn))) (for-each
(for-each (match-lambda
(match-lambda ((id url lookup-all-derivations? lookup-builds?)
((id url lookup-all-derivations? lookup-builds?) (when (or (or (not build-servers)
(when (or (or (not build-servers) (not build-server-ids))
(not build-server-ids)) (member id build-server-ids))
(member id build-server-ids)) (when lookup-all-derivations?
(when lookup-all-derivations? (simple-format #t "\nQuerying ~A\n" url)
(simple-format #t "\nQuerying ~A\n" url) (catch #t
(catch #t (lambda ()
(lambda () (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 #:specific-outputs
#:specific-outputs outputs))
outputs)) (lambda (key . args)
(lambda (key . args) (simple-format
(simple-format (current-error-port)
(current-error-port) "exception in query-build-server: ~A ~A\n"
"exception in query-build-server: ~A ~A\n" key args)))))))
key args))))))) build-servers))))
build-servers)))))
(define %narinfo-max-size (define %narinfo-max-size
(- (expt 2 (- (* 8 8) ;; 8 bytes (- (expt 2 (- (* 8 8) ;; 8 bytes
@ -110,3 +113,40 @@
conn conn
build-server-id build-server-id
filtered-narinfos))))))) 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 pki)
(guix-data-service config) (guix-data-service config)
(guix-data-service database) (guix-data-service database)
(guix-data-service substitutes)
(guix-data-service web server) (guix-data-service web server)
(guix-data-service web controller) (guix-data-service web controller)
(guix-data-service web nar controller)) (guix-data-service web nar controller))
@ -227,6 +228,8 @@
(%show-error-details (%show-error-details
(assoc-ref opts 'show-error-details))) (assoc-ref opts 'show-error-details)))
(start-substitute-query-thread)
;; Provide some visual space between the startup output and the server ;; Provide some visual space between the startup output and the server
;; starting ;; starting
(simple-format #t "\n\nStarting the server on http://~A:~A/\n\n" (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"