;;; 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 hooks) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 exceptions) #:use-module (gcrypt pk-crypto) #:use-module (zlib) #:use-module (lzlib) #:use-module (guix pki) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix config) #:use-module (guix derivations) #:use-module (guix serialization) #:use-module ((guix utils) #:select (default-keyword-arguments)) #:use-module (guix build utils) #:use-module (guix-build-coordinator config) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator datastore) #:use-module (guix-build-coordinator coordinator) #:use-module (guix-build-coordinator guix-data-service) #:export (default-build-submitted-hook default-build-started-hook default-build-success-hook build-success-publish-hook build-success-s3-publish-hook default-build-failure-hook default-build-canceled-hook build-failure-retry-hook build-recompress-log-file-hook default-build-missing-inputs-hook default-build-submit-outputs-hook %default-hooks build-submitted-send-event-to-guix-data-service-hook build-started-send-event-to-guix-data-service-hook build-success-send-event-to-guix-data-service-hook build-failure-send-event-to-guix-data-service-hook build-canceled-send-event-to-guix-data-service-hook)) (define (default-build-submitted-hook build-coordinator build-id) (display (simple-format #f "build ~A submtited\n" build-id) (current-error-port))) (define (default-build-started-hook build-coordinator build-id agent-id) (display (simple-format #f "build ~A started on agent ~A\n" build-id agent-id) (current-error-port))) (define (default-build-success-hook build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((agent-id (datastore-agent-for-build datastore build-id))) (display (simple-format #f "build ~A succeeded (on agent ~A)\n" build-id agent-id) (current-error-port)))) (define* (build-success-publish-hook publish-directory #:key (public-key (read-file-sexp %public-key-file)) (private-key (read-file-sexp %private-key-file)) (narinfo-directory publish-directory) (skip-publishing-proc (lambda (narinfo-filename narinfo-directory) (file-exists? (string-append narinfo-directory "/" narinfo-filename)))) post-publish-hook combined-post-publish-hook (publish-referenced-derivation-source-files? #t) derivation-substitute-urls) (mkdir-p (string-append publish-directory "/nar/lzip")) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (define (process-referenced-derivation-source-files drv-name) (let* ((build-outputs (datastore-list-build-outputs datastore build-id)) (potential-referenced-source-files ;; Just subtract the inputs from the output references (lset-difference string=? (delete-duplicates (append-map (lambda (output) ;; References don't include the store path (or (and=> (assq-ref output 'references) vector->list) '())) build-outputs) string=?) (map basename (datastore-find-recursive-derivation-input-outputs datastore drv-name))))) (unless (null? potential-referenced-source-files) (display (simple-format #f "build-success-publish-hook (~A): looking at potential referenced source files: ~A\n" build-id potential-referenced-source-files) (current-error-port))) (if (null? potential-referenced-source-files) '() (with-store/non-blocking store (unless (valid-path? store drv-name) ;; TODO This isn't ideal as it can be blocked by GC (with-port-timeouts (lambda () (substitute-derivation store drv-name #:substitute-urls derivation-substitute-urls))) (add-temp-root store drv-name)) (let* ((drv (read-derivation-from-file* drv-name)) (drv-sources (derivation-sources drv)) (referenced-source-files (filter (lambda (source) (if (member (basename source) potential-referenced-source-files) source #f)) drv-sources))) (filter-map (lambda (source-filename) (let* ((nar-filename (string-append "nar/lzip/" (basename source-filename))) (nar-destination (string-append publish-directory "/" nar-filename)) (tmp-nar-destination (string-append publish-directory "/" nar-filename ".tmp")) (narinfo-filename (string-append (string-take (basename source-filename) 32) ".narinfo")) (narinfo-location (string-append narinfo-directory "/" narinfo-filename)) (path-info (query-path-info store source-filename))) (if (skip-publishing-proc narinfo-filename narinfo-directory) #f (begin (call-with-output-file tmp-nar-destination (lambda (out) (call-with-lzip-output-port out (lambda (port) (write-file source-filename port)) #:level 9))) (rename-file tmp-nar-destination nar-destination) (call-with-output-file narinfo-location (lambda (port) (display (narinfo-string source-filename (bytevector->nix-base32-string (path-info-hash path-info)) (path-info-nar-size path-info) (map basename (path-info-references path-info)) `((lzip ,(stat:size (stat nar-destination #f)))) #:public-key public-key #:private-key private-key) port))) (when post-publish-hook (with-exception-handler (lambda (exn) ;; Rollback narinfo creation, to make this more ;; transactional (delete-file narinfo-location) (raise-exception exn)) (lambda () (post-publish-hook publish-directory narinfo-filename nar-filename)) #:unwind? #t)) (cons narinfo-filename nar-filename))))) referenced-source-files)))))) (define (process-output drv-name output) (let* ((output-name (assq-ref output 'name)) (output-filename (assq-ref output 'output)) (nar-location (build-output-file-location datastore build-id output-name)) (nar-filename (string-append "nar/lzip/" (basename output-filename))) (nar-destination (string-append publish-directory "/" nar-filename)) (narinfo-filename (string-append (string-take (basename output-filename) 32) ".narinfo")) (narinfo-location (string-append narinfo-directory "/" narinfo-filename))) (if (skip-publishing-proc narinfo-filename narinfo-directory) #f (begin (copy-file nar-location nar-destination) (call-with-output-file narinfo-location (lambda (port) (display (narinfo-string output-filename (assq-ref output 'hash) (assq-ref output 'size) (vector->list (assq-ref output 'references)) `((lzip ,(stat:size (stat nar-location #f)))) #:system (datastore-find-derivation-system datastore drv-name) #:derivation drv-name #:public-key public-key #:private-key private-key) port))) (when post-publish-hook (with-exception-handler (lambda (exn) ;; Rollback narinfo creation, to make this more ;; transactional (delete-file narinfo-location) (raise-exception exn)) (lambda () (post-publish-hook publish-directory narinfo-filename nar-filename)) #:unwind? #t)) (cons narinfo-filename nar-filename))))) (let* ((build-details (datastore-find-build datastore build-id)) (drv-name (assq-ref build-details 'derivation-name)) (narinfos-and-nars (append (if publish-referenced-derivation-source-files? (process-referenced-derivation-source-files drv-name) '()) (filter-map (lambda (output) (process-output drv-name output)) (datastore-list-build-outputs datastore build-id))))) (when (and combined-post-publish-hook (not (null? narinfos-and-nars))) (with-exception-handler (lambda (exn) ;; Rollback narinfo creation, to make this more ;; transactional (for-each (match-lambda ((narinfo-filename . _) (delete-file (string-append narinfo-directory "/" narinfo-filename)))) narinfos-and-nars) (raise-exception exn)) (lambda () (combined-post-publish-hook publish-directory narinfos-and-nars)) #:unwind? #t))))) (define* (build-success-s3-publish-hook s3-bucket #:key (aws-command "aws") (command-line-arguments '()) (narinfo-directory #f) (public-key (read-file-sexp %public-key-file)) (private-key (read-file-sexp %private-key-file)) post-publish-hook) (define (s3-file-exists? name) (if (null? (retry-on-error (lambda () (s3-list-objects s3-bucket name #:command aws-command #:command-line-arguments command-line-arguments)) #:times 6 #:delay 20)) #f #t)) (let ((temp-dir (string-append (%config 'data-dir) "/temp-s3-uploads"))) (unless (file-exists? temp-dir) (mkdir temp-dir)) (build-success-publish-hook temp-dir #:narinfo-directory (or narinfo-directory temp-dir) #:public-key public-key #:private-key private-key #:post-publish-hook (lambda (directory narinfo-filename nar-filename) (let ((narinfo-full-filename (string-append (or narinfo-directory temp-dir) "/" narinfo-filename))) (unless (s3-file-exists? narinfo-filename) (retry-on-error (lambda () (s3-cp s3-bucket (string-append directory "/" nar-filename) nar-filename #:command aws-command #:command-line-arguments command-line-arguments)) #:times 6 #:delay 20) (when post-publish-hook (post-publish-hook directory narinfo-filename nar-filename)) (retry-on-error (lambda () (s3-cp s3-bucket narinfo-full-filename narinfo-filename #:command aws-command #:command-line-arguments command-line-arguments)) #:times 6 #:delay 20)) (unless narinfo-directory (delete-file narinfo-full-filename)) (delete-file (string-append directory "/" nar-filename))))))) (define (default-build-failure-hook build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((agent-id (datastore-agent-for-build datastore build-id))) (display (simple-format #f "build ~A failed (on agent ~A)\n" build-id agent-id) (current-error-port)))) (define (default-build-canceled-hook build-coordinator build-id) (display (simple-format #f "build ~A canceled\n" build-id) (current-error-port))) (define* (build-failure-retry-hook #:key (retries 2)) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let* ((build-details (datastore-find-build datastore build-id)) (derivation-name (assq-ref build-details 'derivation-name)) (all-builds-for-derivation-count (datastore-count-builds-for-derivation datastore derivation-name #:include-canceled? #f)) (retries-list (if (procedure? retries) (retries #:build-details build-details #:derivation-details (datastore-find-derivation datastore derivation-name) #:builds-for-derivation-count all-builds-for-derivation-count) (if (= 1 all-builds-for-derivation-count) (make-list retries '()) '())))) (unless (null? retries-list) (display (simple-format #f "~A: submitting ~A retries for\n ~A\n" build-id (length retries-list) derivation-name)) (for-each (lambda (retry-arguments index) (let ((details (apply submit-build build-coordinator derivation-name (default-keyword-arguments retry-arguments (list #:priority (assq-ref build-details 'priority) #:tags (datastore-fetch-build-tags datastore build-id)))))) (display (simple-format #f "~A: submitted retry ~A as ~A\n" build-id index (assq-ref details 'build-submitted))))) retries-list (iota (length retries-list) 1)))))) (define* (build-recompress-log-file-hook #:key recompress-to (timeout 60)) (define* (call-with-compressed-input-file name compression proc) (cond ((eq? compression 'gzip) (call-with-input-file name (lambda (compressed-input-port) (call-with-gzip-input-port compressed-input-port proc)))) ((eq? compression 'bzip2) (let ((pipe (open-pipe* OPEN_READ (%config 'bzip2) "-dc" name))) (dynamic-wind (const #f) (lambda () (proc pipe)) (lambda () (close-pipe pipe))))) (else (error (simple-format #f "unsupported compression ~A" compression))))) (define* (call-with-compressed-output-file name compression proc #:key (compression-level 9)) (cond ((eq? compression 'gzip) (call-with-output-file name (lambda (uncompressed-output-port) (call-with-gzip-output-port uncompressed-output-port proc)))) ((eq? compression 'bzip2) (let ((pipe (open-pipe OPEN_WRITE (simple-format #f "~A --compress -~A > ~A" (%config 'bzip2) compression-level name)))) (dynamic-wind (const #f) (lambda () (proc pipe)) (lambda () (close-pipe pipe))))) (else (error (simple-format #f "unsupported compression ~A" compression))))) (lambda (build-coordinator build-id) (let* ((source-log-file (build-log-file-location build-id)) (source-compression (cond ((string-suffix? ".gz" source-log-file) 'gzip) ((string-suffix? ".bz2" source-log-file) 'bzip2) (else (error "unknown source compression")))) (output-log-file (build-log-file-destination build-id (symbol->string recompress-to))) (tmp-output-log-file (string-append output-log-file ".tmp"))) (unless (eq? source-compression recompress-to) (when (file-exists? tmp-output-log-file) (delete-file tmp-output-log-file)) (with-timeout timeout (raise-exception (make-exception-with-message "timeout recompressing log file")) (call-with-compressed-input-file source-log-file source-compression (lambda (input-port) (call-with-compressed-output-file tmp-output-log-file recompress-to (lambda (output-port) (dump-port input-port output-port)))))) (rename-file tmp-output-log-file output-log-file) (delete-file source-log-file))))) (define (default-build-missing-inputs-hook build-coordinator build-id missing-inputs) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build (datastore-find-build datastore build-id))) (simple-format #t "missing-inputs: ~A\n~A\n" build-id (string-join (map (lambda (input) (string-append " - " input)) missing-inputs) "\n")) (for-each (lambda (missing-input) (let ((input-derivation (datastore-find-derivation-for-output datastore (assq-ref build 'derivation-name) missing-input))) (if input-derivation (let* ((builds-for-output (datastore-list-builds-for-output datastore missing-input)) (successful-builds (filter (lambda (build-details) (and (assq-ref build-details 'processed) (string=? (assq-ref build-details 'result) "success"))) builds-for-output)) (pending-builds (filter (lambda (build-details) (and (not (assq-ref build-details 'processed)) (not (assq-ref build-details 'canceled)))) builds-for-output))) (if (and (null? successful-builds) (null? pending-builds)) (begin (simple-format #t "submitting build for ~A\n" input-derivation) (submit-build build-coordinator input-derivation #:tags (datastore-fetch-build-tags datastore build-id))) (simple-format #t "~A builds exist for ~A, skipping\n" (length builds-for-output) missing-input))) (begin (simple-format (current-error-port) "warning: default-build-missing-inputs-hook: couldn't find a derivation for ~A\n" missing-input))))) missing-inputs))) (define (default-build-submit-outputs-hook build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let* ((build (datastore-find-build datastore build-id)) (unbuilt-outputs (datastore-list-unbuilt-derivation-outputs datastore (assq-ref build 'derivation-name)))) (not (null? unbuilt-outputs)))) (define %default-hooks `((build-submitted . ,default-build-submitted-hook) (build-started . ,default-build-started-hook) (build-success . ,default-build-success-hook) (build-failure . ,default-build-failure-hook) (build-canceled . ,default-build-canceled-hook) (build-missing-inputs . ,default-build-missing-inputs-hook) (build-submit-outputs . ,default-build-submit-outputs-hook))) (define (build-submitted-send-event-to-guix-data-service-hook target-url) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build-details (datastore-find-build datastore build-id))) (send-build-event-to-guix-data-service target-url `((type . build) (event . scheduled) (build_id . ,build-id) (derivation . ,(assq-ref build-details 'derivation-name)) ,@(or (and=> (datastore-find-derivation-output-details datastore (assq-ref build-details 'derivation-name)) (lambda (output-details) `((derivation_outputs . ,(list->vector (map (lambda (output-details) `((output . ,(assq-ref output-details 'output)) (name . ,(assq-ref output-details 'name)) ,@(if (assq-ref output-details 'hash) `((hash_algorithm . ,(assq-ref output-details 'hash-algorithm)) (hash . ,(assq-ref output-details 'hash))) '()) (recursive . ,(assq-ref output-details 'recursive?)))) output-details)))))) '()) ,@(let ((created-at (assq-ref build-details 'created-at))) (if created-at `((timestamp . ,(string->number (strftime "%s" (assq-ref build-details 'created-at))))) '()))))))) (define (build-started-send-event-to-guix-data-service-hook target-url) (lambda (build-coordinator build-id agent-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build-details (datastore-find-build datastore build-id)) (timestamp (string->number (strftime "%s" (assq-ref (first (filter (lambda (start-time-and-agent) (string=? agent-id (assq-ref start-time-and-agent 'agent-id))) (datastore-find-build-starts datastore build-id))) 'start-time))))) (send-build-event-to-guix-data-service target-url `((type . build) (event . started) (build_id . ,build-id) (derivation . ,(assq-ref build-details 'derivation-name)) (timestamp . ,timestamp)))))) (define (build-success-send-event-to-guix-data-service-hook target-url) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build-details (datastore-find-build datastore build-id))) (send-build-event-to-guix-data-service target-url `((type . build) (event . succeeded) (build_id . ,build-id) (derivation . ,(assq-ref build-details 'derivation-name)) ,@(let ((end-time (assq-ref build-details 'end-time))) (if end-time `((timestamp . ,(string->number (strftime "%s" (assq-ref build-details 'end-time))))) '()))))))) (define (build-failure-send-event-to-guix-data-service-hook target-url) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build-details (datastore-find-build datastore build-id))) (send-build-event-to-guix-data-service target-url `((type . build) (event . failed) (build_id . ,build-id) (derivation . ,(assq-ref build-details 'derivation-name)) ,@(let ((end-time (assq-ref build-details 'end-time))) (if end-time `((timestamp . ,(string->number (strftime "%s" (assq-ref build-details 'end-time))))) '()))))))) (define (build-canceled-send-event-to-guix-data-service-hook target-url) (lambda (build-coordinator build-id) (define datastore (build-coordinator-datastore build-coordinator)) (let ((build-details (datastore-find-build datastore build-id))) (send-build-event-to-guix-data-service target-url `((type . build) (event . canceled) (build_id . ,build-id) (derivation . ,(assq-ref build-details 'derivation-name)) ;; TODO Maybe the time of the actual cancelation should be stored or ;; included in the event (timestamp . ,(current-time)))))))