#!@GUILE@ --no-auto-compile -*- scheme -*- -*- geiser-scheme-implementation: guile -*- !# ;;; Guix Build Coordinator ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; 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 ;;; . (use-modules (srfi srfi-1) (srfi srfi-11) (srfi srfi-37) (ice-9 match) (ice-9 textual-ports) (rnrs bytevectors) (json) (web uri) (web client) (guix-build-coordinator utils) (guix-build-coordinator client-communication)) (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) "&")))))) (retry-on-error (lambda () (let-values (((response body) (http-get uri))) (json-string->scm (utf8->string body)))) #:times 6 #:delay 30)) (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-commits-file "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 #:key system target) (let ((data (guix-data-service-request (string-append "/revision/" commit "/package-derivations.json") `((system . ,system) (target . ,target) (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)) (retry-on-error (lambda () (let ((response (send-submit-build-request "http://127.0.0.1:8746" derivation (list (string-append "https://" %guix-data-service-host)) #f priority #t #t #t '()))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response (simple-format #t "skipped: ~A\n" no-build-submitted-response) (simple-format #t "build submitted as ~A\n" (assoc-ref response "build-submitted")))))) ;; The TTL Guix uses for transient failures fetching substitutes is 10 ;; minutes, so we need to retry for longer than that #:times 30 #:delay 30)) (define (submit-builds-for-revision commit systems-and-targets) (simple-format #t "looking at revision ~A\n" commit) (for-each (match-lambda ((system . target) (for-each (lambda (derivation) (submit-build derivation #:priority 1000)) (channel-instance-derivations-for-commit commit system)) (let ((unprocessed-package-derivations (filter (lambda (derivation) (not (hash-ref processed-derivations-hash derivation))) (package-derivations-for-commit commit #:system system #:target target)))) (for-each submit-build unprocessed-package-derivations) (record-derivations-as-processed unprocessed-package-derivations)))) systems-and-targets)) (define %options (list (option '("system") #t #f (lambda (opt name arg result) (alist-cons 'systems-and-targets `((,arg . "none") ,@(or (assq-ref result 'systems-and-targets) '())) (alist-delete 'systems-and-targets result)))) (option '("system-and-target") #t #f (lambda (opt name arg result) (alist-cons 'systems-and-targets (match (string-split arg #\=) ((system target) `((,system . ,target) ,@(or (assq-ref result 'systems-and-targets) '())))) (alist-delete 'systems-and-targets result)))))) (define %option-defaults '()) (define (parse-options options defaults args) (args-fold args options (lambda (opt name arg result) (error "unrecognized option" name)) (lambda (arg result) (alist-cons 'arguments (cons arg (or (assoc-ref result 'arguments) '())) (alist-delete 'arguments result))) defaults)) (define (main) (let* ((opts (parse-options %options %option-defaults (cdr (program-arguments)))) (systems-and-targets (assq-ref opts 'systems-and-targets))) (unless systems-and-targets (simple-format (current-error-port) "error: you must specify at least one system to fetch builds for\n") (exit 1)) (while #t (for-each (lambda (commit) (submit-builds-for-revision commit systems-and-targets) (record-revision-as-processed commit)) (unseen-revisions)) (simple-format #t "waiting before checking for new revisions...\n") (sleep 60)))) (main)