Add a script to fetch builds from the Guix Data Service

As that is an easy way to find things to build.

4 files changed, 176 insertions, 1 deletions

diff --git a/.gitignore b/.gitignore
index eab2a38..2dc6ec7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,5 +26,6 @@ data/
 
 scripts/guix-build-coordinator
 scripts/guix-build-coordinator-agent
+scripts/guix-build-coordinator-queue-builds-from-guix-data-service
 
 guix-build-coordinator/config.scm
diff --git a/Makefile.am b/Makefile.am
index fc34fbe..9b7be08 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -2,7 +2,8 @@ include guile.am
 
 bin_SCRIPTS =						\
   scripts/guix-build-coordinator			\
-  scripts/guix-build-coordinator-agent
+  scripts/guix-build-coordinator-agent			\
+  scripts/guix-build-coordinator-queue-builds-from-guix-data-service
 
 SOURCES =						\
   guix-build-coordinator/agent-messaging/http.scm	\
diff --git a/configure.ac b/configure.ac
index d1f7c1a..86e90b2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -26,5 +26,9 @@ AC_CONFIG_FILES(
   [scripts/guix-build-coordinator-agent],
   [chmod +x scripts/guix-build-coordinator-agent]
 )
+AC_CONFIG_FILES(
+  [scripts/guix-build-coordinator-queue-builds-from-guix-data-service],
+  [chmod +x scripts/guix-build-coordinator-queue-builds-from-guix-data-service]
+)
 
 AC_OUTPUT
diff --git a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
new file mode 100644
index 0000000..0899538
--- /dev/null
+++ b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
@@ -0,0 +1,169 @@
+#!@GUILE@ --no-auto-compile
+-*- scheme -*-
+-*- geiser-scheme-implementation: guile -*-
+!#
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; guix-data-service is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; guix-data-service is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-11)
+             (ice-9 match)
+             (ice-9 textual-ports)
+             (rnrs bytevectors)
+             (json)
+             (web uri)
+             (web client))
+
+(define %guix-data-service-host "data.guix.gnu.org")
+
+(define %processed-commits-file "processed-revisions")
+
+;; This gets populated from a file on startup
+(define processed-commits-hash
+  (make-hash-table 1024))
+
+(when (file-exists? %processed-commits-file)
+  (call-with-input-file %processed-commits-file
+    (lambda (port)
+      (let ((commits
+             (string-split (get-string-all port) #\newline)))
+        (for-each (lambda (commit)
+                    (unless (string-null? commit)
+                      (simple-format #t "marking ~A as already processed\n"
+                                     commit)
+                      (hash-set! processed-commits-hash
+                                 commit
+                                 #t)))
+                  commits)))))
+
+(define processed-derivations-hash
+  (make-hash-table 102400))
+
+(define* (guix-data-service-request path #:optional (query-parameters '()))
+  (define uri
+    (string->uri (string-append
+                  "https://"
+                  %guix-data-service-host
+                  path
+                  (if (null? query-parameters)
+                      ""
+                      (string-append
+                       "?"
+                       (string-join
+                        (map (match-lambda
+                               ((key . value)
+                                (simple-format #f "~A=~A" key value)))
+                             query-parameters)
+                        "&"))))))
+
+  (let-values (((response body) (http-get uri)))
+    (json-string->scm (utf8->string body))))
+
+(define (unseen-revisions)
+  (let ((data (guix-data-service-request "/repository/1/branch/master.json")))
+    (filter-map (lambda (entry)
+                  (let ((commit (assoc-ref entry "commit-hash")))
+                    (and (not (hash-ref processed-commits-hash
+                                        commit))
+                         (assoc-ref entry "data_available")
+                         commit)))
+                (vector->list
+                 (assoc-ref data "revisions")))))
+
+(define (record-revision-as-processed commit)
+  (let ((port (open-file "processed-revisions" "a")))
+    (simple-format port "~A\n" commit)
+    (close-port port))
+
+  (hash-set! processed-commits-hash commit #t))
+
+(define (channel-instance-derivations-for-commit commit system)
+  (let ((data (guix-data-service-request
+               (string-append "/revision/" commit "/channel-instances.json"))))
+    (filter-map (lambda (entry)
+                  (if (string=? system
+                                (assoc-ref entry "system"))
+                      (assoc-ref entry "derivation")
+                      #f))
+                (vector->list
+                 (assoc-ref data "channel_instances")))))
+
+(define (package-derivations-for-commit commit)
+  (let ((data (guix-data-service-request
+               (string-append "/revision/" commit "/package-derivations.json")
+               '((system      . "x86_64-linux")
+                 (target      . "none")
+                 (field       . "(no-additional-fields)")
+                 (all_results . "on")))))
+    (map (lambda (entry)
+           (assoc-ref entry "derivation"))
+         (vector->list
+          (assoc-ref data "derivations")))))
+
+(define (record-derivations-as-processed derivations)
+  (for-each (lambda (derivation)
+              (hash-set! processed-derivations-hash
+                         derivation
+                         #t))
+            derivations))
+
+(define* (submit-build derivation #:key (priority 0))
+  (system* "guix-build-coordinator" "build"
+           ;; Currently submitting builds performs an allocation. Ideally this
+           ;; would just mark the plan as dirty to avoid repeatedly
+           ;; re-allocating builds. Until that point, pass this flag to skip
+           ;; allocating builds.
+           "--defer-allocation"
+           ;; For the use case of providing substitutes, just build each
+           ;; derivation once.
+           "--ignore-if-build-for-derivation-exists"
+           ;; The Guix Build Coordinator will automatically add builds for
+           ;; inputs if the required output isn't available, but to ensure
+           ;; this derivation, and all the related derivations have been built
+           ;; and the outputs stored, instruct the Guix Build Coordinator to
+           ;; add the builds upfront.
+           "--ensure-all-related-derivations-have-builds"
+           (simple-format #f "--priority=~A" priority)
+           derivation))
+
+(define (submit-builds-for-revision commit)
+  (simple-format #t "looking at revision ~A\n" commit)
+  (for-each (lambda (derivation)
+              (submit-build derivation #:priority 1000))
+            (channel-instance-derivations-for-commit commit "x86_64-linux"))
+
+  (let ((unprocessed-package-derivations
+         (filter (lambda (derivation)
+                   (not (hash-ref processed-derivations-hash derivation)))
+                 (package-derivations-for-commit commit))))
+
+    (for-each submit-build unprocessed-package-derivations)
+    (record-derivations-as-processed unprocessed-package-derivations)))
+
+(define (main)
+  (while #t
+    (for-each (lambda (commit)
+                (submit-builds-for-revision commit)
+                (record-revision-as-processed commit))
+              (unseen-revisions))
+
+    (sleep 3600)))
+
+(main)