Add a thread to refresh data for branches

2 files changed, 88 insertions, 1 deletions

diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
index 7724ea7..9720bab 100644
--- a/guix-qa-frontpage/server.scm
+++ b/guix-qa-frontpage/server.scm
@@ -50,7 +50,8 @@
   #:use-module (guix-qa-frontpage view issue)
   #:export (start-guix-qa-frontpage-web-server
 
-            start-refresh-patch-branches-data-thread))
+            start-refresh-patch-branches-data-thread
+            start-refresh-non-patch-branches-data-thread))
 
 (define (make-controller assets-directory database metrics-registry)
 
@@ -549,3 +550,88 @@ port. Also, the port used can be changed by passing the --port option.\n"
                               "warning: refreshing data is behind\n")
                (sleep
                 (- frequency time-taken)))))))))
+
+(define (start-refresh-non-patch-branches-data-thread database)
+  (define (refresh-data)
+    (simple-format (current-error-port)
+                   "refreshing non-patch branches data...\n")
+    (update-repository!)
+
+    (let ((branches
+           (with-sqlite-cache
+            database
+            'branches
+            (lambda ()
+              (remove
+               (lambda (branch)
+                 (string=? (assoc-ref branch "name")
+                           "master"))
+               (list-branches
+                (list-branches-url 2))))
+            #:ttl 0)))
+
+      (n-par-for-each
+       2
+       (lambda (branch)
+         (let ((branch-name
+                (assoc-ref branch "name")))
+           (simple-format (current-error-port)
+                          "refreshing data for ~A branch\n"
+                          branch-name)
+
+           (let ((derivation-changes
+                  (with-exception-handler
+                      (lambda (exn)
+                        (simple-format
+                         (current-error-port)
+                         "failed fetching derivation changes for branch ~A: ~A\n"
+                         branch-name
+                         exn)
+
+                        #f)
+                    (lambda ()
+                      (let ((derivation-changes-url
+                             (branch-derivation-changes-url
+                              branch-name
+                              #:systems %systems-to-submit-builds-for)))
+
+                        (with-sqlite-cache
+                         database
+                         'branch-derivation-changes
+                         branch-derivation-changes
+                         #:args
+                         (list derivation-changes-url)
+                         #:ttl 0)))
+                    #:unwind? #t)))
+             #f)))
+       branches)))
+
+  (call-with-new-thread
+   (lambda ()
+     (define frequency
+       (* 30 60))
+
+     (while #t
+       (let ((start-time (current-time)))
+         (with-exception-handler
+             (lambda (exn)
+               (simple-format
+                (current-error-port)
+                "exception in branch data refresh thread: ~A\n"
+                exn))
+           (lambda ()
+             (with-time-logging "refreshing branch data"
+               (with-throw-handler #t
+                 refresh-data
+                 (lambda args
+                   (display (backtrace) (current-error-port))
+                   (newline (current-error-port))))))
+           #:unwind? #t)
+
+         (let ((time-taken
+                (- (current-time) start-time)))
+           (if (>= time-taken frequency)
+               (simple-format (current-error-port)
+                              "warning: refreshing branch data is behind\n")
+               (sleep
+                (- frequency time-taken)))))))))
diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
index 38a52a5..5cc5b5f 100644
--- a/scripts/guix-qa-frontpage.in
+++ b/scripts/guix-qa-frontpage.in
@@ -122,6 +122,7 @@
                             metrics-registry)))
 
       (start-refresh-patch-branches-data-thread database)
+      (start-refresh-non-patch-branches-data-thread database)
 
       (when (assq-ref opts 'submit-builds)
         (start-submit-patch-builds-thread database