aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--Makefile.am3
-rw-r--r--configure.ac4
-rw-r--r--scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in169
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)