;;; Guix Build Coordinator ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of the guix-build-coordinator. ;;; ;;; The Guix Build Coordinator 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. ;;; ;;; The Guix Build Coordinator 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 ;;; . (define-module (guix-build-coordinator agent) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) #:use-module (web http) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix base32) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator agent-messaging http) #:export (run-agent)) (define (run-agent uuid coordinator-uri password substitute-urls) (while #t (let* ((details (submit-status coordinator-uri uuid password 'idle)) (builds (let ((already-allocated-builds (vector->list (assoc-ref details "builds")))) (if (null? already-allocated-builds) (fetch-builds-for-agent coordinator-uri uuid password) already-allocated-builds)))) (simple-format #t "received allocated builds (~A)\n" (length builds)) (for-each (lambda (build) (simple-format #t "processing build: ~A\n" (assoc-ref build "uuid")) (let ((derivation-name (assoc-ref build "derivation-name"))) (simple-format #t "setting up to build: ~A\n" derivation-name) (let ((pre-build-status (pre-build-process substitute-urls derivation-name))) (if (eq? (assq-ref pre-build-status 'result) 'success) (begin (simple-format #t "setup successful, building: ~A\n" derivation-name) (let ((result (perform-build derivation-name))) (and=> (derivation-log-file derivation-name) (lambda (log-file) (simple-format #t "uploading log file ~A\n" log-file) (submit-log-file coordinator-uri uuid password (assoc-ref build "uuid") log-file))) ((if result post-build-success post-build-failure) uuid coordinator-uri password (assoc-ref build "uuid") derivation-name))) (begin (simple-format #t "failure: ~A\n" pre-build-status) (report-setup-failure coordinator-uri uuid password (assoc-ref build "uuid") pre-build-status)))))) builds) (when (null? builds) (sleep 5))))) (define (pre-build-process substitute-urls derivation-name) (define (find-missing-inputs inputs) (let* ((output-paths (append-map derivation-input-output-paths inputs)) (missing-paths (remove file-exists? output-paths)) (path-substitutes (with-store store (set-build-options store #:substitute-urls substitute-urls) (map (lambda (file) (and (has-substiutes-no-cache? substitute-urls file) (if (has-substitutes? store file) #t (begin (simple-format #t "warning: a substitute should be available for ~A, but the daemon claims it's not\n" file) #f)))) missing-paths)))) (if (null? missing-paths) '() (if (member #f path-substitutes) (fold (lambda (file substitute-available? result) (if substitute-available? result (cons file result))) '() missing-paths path-substitutes) (begin ;; Download the substitutes (with-store store (set-build-options store #:substitute-urls substitute-urls) (build-things store missing-paths)) ;; Double check everything is actually present. (let ((missing-files (remove file-exists? output-paths))) (if (null? missing-files) '() (begin (simple-format (current-error-port) "error: failed to fetch substitutes for: ~A" missing-files) missing-files)))))))) (define (delete-outputs derivation) (let* ((outputs (derivation-outputs derivation)) (output-file-names (map derivation-output-path (map cdr outputs)))) (if (any file-exists? output-file-names) (catch #t (lambda () (with-store store (delete-paths store output-file-names)) #t) (lambda (key args) (simple-format (current-error-port) "error: delete-outputs: ~A ~A\n" key args) #f)) #t))) (let ((derivation (if (file-exists? derivation-name) (read-derivation-from-file derivation-name) (begin (retry-on-error (lambda () (substitute-derivation derivation-name #:substitute-urls substitute-urls)) #:times 12 #:delay 20) (read-derivation-from-file derivation-name))))) (match (delete-outputs derivation) (#t (let ((missing-inputs (find-missing-inputs (derivation-inputs derivation)))) (if (null? missing-inputs) '((result . success)) `((result . failure) (failure_reason . missing_inputs) (missing_inputs . ,(list->vector missing-inputs)))))) (failure '((result . failure) (failure_reason . could_not_delete_outputs)))))) (define (perform-build derivation-name) (with-store store (set-build-options store #:use-substitutes? #f) (parameterize ((current-build-output-port (%make-void-port "w"))) (catch #t (lambda () (build-things store (list derivation-name)) #t) (lambda (key . args) (simple-format (current-error-port) "error: build: ~A ~A\n" key args) #f))))) (define (post-build-failure uuid coordinator-uri password build-id derivation) (simple-format #t "build ~A failed, reporting to coordinator\n" build-id) (submit-build-result coordinator-uri uuid password build-id '((result . failure)))) (define (post-build-success uuid coordinator-uri password build-id derivation) (simple-format #t "build ~A successful, reporting to coordinator\n" build-id) (let ((output-details (map (match-lambda ((output-name . output) (simple-format #t "submitting output ~A\n" (derivation-output-path output)) (submit-output coordinator-uri uuid password build-id output-name (derivation-output-path output)) (let ((path-info (with-store store (query-path-info store (derivation-output-path output))))) `((name . ,output-name) (hash . ,(bytevector->nix-base32-string (path-info-hash path-info))) (size . ,(path-info-nar-size path-info)) (references . ,(list->vector (map basename (path-info-references path-info)))))))) (derivation-outputs (read-derivation-from-file derivation))))) (simple-format #t "finished submitting outputs, reporting result\n") (submit-build-result coordinator-uri uuid password build-id `((result . success) (outputs . ,(list->vector output-details))))))