branch master updated: Query substitutes for latest processed revisions periodically

[Christopher Baines]

This is an automated email from the git hooks/post-receive script.

cbaines pushed a commit to branch master
in repository data-service.

The following commit(s) were added to refs/heads/master by this push:
     new 8beab25  Query substitutes for latest processed revisions periodically
8beab25 is described below

commit 8beab2511cb3d4840f4479e3f99a59d37b9ecf73
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Tue Nov 16 19:08:46 2021 +0000

    Query substitutes for latest processed revisions periodically
    
    This is a step towards having up to date substitute availability data.
---
 guix-data-service/substitutes.scm | 86 ++++++++++++++++++++++++++++-----------
 scripts/guix-data-service.in      |  3 ++
 2 files changed, 66 insertions(+), 23 deletions(-)

diff --git a/guix-data-service/substitutes.scm 
b/guix-data-service/substitutes.scm
index 3328092..7c8c5e6 100644
--- a/guix-data-service/substitutes.scm
+++ b/guix-data-service/substitutes.scm
@@ -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))))))))
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index 7eae735..3e80f03 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -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";