#!@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)) ;; This gets populated from a file on startup (define processed-commits-hash (make-hash-table 1024)) (define processed-derivations-hash (make-hash-table 102400)) (define* (guix-data-service-request guix-data-service path #:optional (query-parameters '())) (define uri (string->uri (string-append guix-data-service 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 (all-repository-ids guix-data-service) (let ((data (guix-data-service-request guix-data-service "/repositories.json"))) (map (lambda (entry) (assoc-ref entry "id")) (vector->list (assoc-ref data "repositories"))))) (define (all-repository-branches guix-data-service repository-id) (let ((data (guix-data-service-request guix-data-service (string-append "/repository/" (number->string repository-id) ".json")))) (map (lambda (entry) (assoc-ref entry "name")) (vector->list (assoc-ref data "branches"))))) (define (unseen-revisions guix-data-service repository-id branch) (let ((data (guix-data-service-request guix-data-service (string-append "/repository/" (number->string repository-id) "/branch/" branch ".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 processed-commits-file 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 guix-data-service commit system) (let ((data (guix-data-service-request guix-data-service (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 guix-data-service commit #:key system target) (let ((data (guix-data-service-request guix-data-service (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 coordinator guix-data-service derivation #:key (priority 0)) (retry-on-error (lambda () (let ((response (send-submit-build-request coordinator derivation (list guix-data-service) #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 (priority-for-derivation type system target) (cond ((eq? type 'channel-instance) (if (and (string=? system "x86_64-linux") (string=? target "none")) 1000 500)) ((eq? type 'package) (if (and (string=? system "x86_64-linux") (string=? target "none")) 500 0)) (else 0))) (define* (submit-builds-for-revision coordinator guix-data-service commit systems-and-targets #:key (submit-builds-for-channel-instances? #t)) (simple-format #t "looking at revision ~A\n" commit) (for-each (match-lambda ((system . target) (when (string=? target "none") (when submit-builds-for-channel-instances? (for-each (lambda (derivation) (submit-build coordinator guix-data-service derivation #:priority (priority-for-derivation 'channel-instance system target))) (channel-instance-derivations-for-commit guix-data-service commit system)))) (let ((unprocessed-package-derivations (filter (lambda (derivation) (not (hash-ref processed-derivations-hash derivation))) (package-derivations-for-commit guix-data-service commit #:system system #:target target)))) (for-each (lambda (derivation) (submit-build coordinator guix-data-service derivation #:priority (priority-for-derivation 'package system target))) 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)))) (option '("fetch-channel-instance-derivations") #t #f (lambda (opt name arg result) (alist-cons 'fetch-channel-instance-derivations (string=? arg "yes") (alist-delete 'fetch-channel-instance-derivations result)))) (option '("coordinator") #t #f (lambda (opt name arg result) (alist-cons 'coordinator arg (alist-delete 'coordinator result)))) (option '("guix-data-service") #t #f (lambda (opt name arg result) (alist-cons 'guix-data-service arg (alist-delete 'guix-data-service result)))) (option '("processed-commits-file") #t #f (lambda (opt name arg result) (alist-cons 'processed-commits-file arg (alist-delete 'processed-commits-file result)))))) (define %option-defaults '((coordinator . "http://127.0.0.1:8746") (guix-data-service . "https://data.guix.gnu.org") (processed-commits-file . "processed-revisions") (fetch-channel-instance-derivations . #t))) (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 (reverse (assq-ref opts 'systems-and-targets))) (guix-data-service (assq-ref opts 'guix-data-service)) (processed-commits-file (assq-ref opts 'processed-commits-file))) (unless systems-and-targets (simple-format (current-error-port) "error: you must specify at least one system to fetch builds for\n") (exit 1)) (let ((arguments (or (assq-ref opts 'arguments) '()))) (unless (null? arguments) (for-each (lambda (commit) (submit-builds-for-revision (assq-ref opts 'coordinator) guix-data-service commit systems-and-targets)) arguments) (exit 0))) (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))))) (while #t (for-each (lambda (repository-id) (for-each (lambda (branch) (for-each (lambda (commit) (submit-builds-for-revision (assq-ref opts 'coordinator) guix-data-service commit systems-and-targets #:submit-builds-for-channel-instances? (assq-ref opts 'fetch-channel-instance-derivations)) (record-revision-as-processed processed-commits-file commit)) (unseen-revisions guix-data-service repository-id branch))) (all-repository-branches guix-data-service repository-id))) (all-repository-ids guix-data-service)) (simple-format #t "waiting before checking for new revisions...\n") (sleep 60)))) (main)