diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in | 169 |
1 files changed, 169 insertions, 0 deletions
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) |