From bc01605cd1b37d3f88a62c9af12f2f5b411bcfe6 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 7 May 2020 17:21:46 +0100 Subject: WIP --- guix-build-coordinator/config.scm.in | 53 +++++++++++------------- guix-build-coordinator/hooks.scm | 80 ++++++++++++++++++++++++++++++++---- guix-build-coordinator/utils.scm | 62 +++++++++++++++++++++++++++- 3 files changed, 156 insertions(+), 39 deletions(-) diff --git a/guix-build-coordinator/config.scm.in b/guix-build-coordinator/config.scm.in index de65835..2aa825f 100644 --- a/guix-build-coordinator/config.scm.in +++ b/guix-build-coordinator/config.scm.in @@ -23,35 +23,30 @@ %show-error-details)) (define %config - (let ((config - `((guix . "@guix@") - - (builds-dir . ,(let ((install-dir - "/var/lib/guix-build-coordinator/builds") - (dev-dir - (string-append (getcwd) "/data/builds"))) - (if (file-exists? install-dir) - install-dir - dev-dir))) - (build-logs-dir . ,(let ((install-dir - "/var/lib/guix-build-coordinator/build-logs") - (dev-dir - (string-append (getcwd) "/data/build-logs"))) - (if (file-exists? install-dir) - install-dir - dev-dir))) - - (sqitch . "@sqitch@") - (sqitch-psql . "@psql@") - (sqitch-sqlite . "@sqlite3@") - (sqitch-plan - . ,(let ((installed-plan - "@prefix@/share/guix-build-coordinator/sqitch/sqitch.plan") - (dev-plan - (string-append (getcwd) "/sqitch/sqitch.plan"))) - (if (file-exists? installed-plan) - installed-plan - dev-plan)))))) + (let* ((data-dir + (let ((install-dir + "/var/lib/guix-build-coordinator") + (dev-dir + (string-append (getcwd) "/data"))) + (if (file-exists? install-dir) + install-dir + dev-dir))) + (config + `((guix . "@guix@") + (data-dir . ,data-dir) + (builds-dir . ,(string-append data-dir "/builds")) + (build-logs-dir . ,(string-append data-dir "/build-logs")) + (sqitch . "@sqitch@") + (sqitch-psql . "@psql@") + (sqitch-sqlite . "@sqlite3@") + (sqitch-plan + . ,(let ((installed-plan + "@prefix@/share/guix-build-coordinator/sqitch/sqitch.plan") + (dev-plan + (string-append (getcwd) "/sqitch/sqitch.plan"))) + (if (file-exists? installed-plan) + installed-plan + dev-plan)))))) (lambda (key) (assoc-ref config key)))) diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm index d419365..9d9a5b1 100644 --- a/guix-build-coordinator/hooks.scm +++ b/guix-build-coordinator/hooks.scm @@ -25,6 +25,7 @@ #:use-module (guix pki) #:use-module (guix config) #: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) @@ -42,12 +43,12 @@ 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))) + (private-key (read-file-sexp %private-key-file)) + post-publish-hook) (mkdir-p (string-append publish-directory "/nar/lzip")) (lambda (datastore build-id) @@ -64,15 +65,19 @@ (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/lzip/" - (basename output-filename))) + nar-filename)) + (narinfo-filename + (string-append (string-take (basename output-filename) 32) + ".narinfo")) + (narinfo-location - (string-append publish-directory - "/" - (string-take (basename output-filename) 32) - ".narinfo"))) + (string-append publish-directory "/" + narinfo-filename))) (copy-file nar-location nar-destination) @@ -91,9 +96,66 @@ #:derivation derivation-name #:public-key public-key #:private-key private-key) - port))))) + port))) + + (when post-publish-hook + (post-publish-hook publish-directory + narinfo-filename + nar-filename)))) (datastore-list-build-outputs datastore build-id))))) +(define* (build-success-s3-publish-hook + s3-bucket + #:key + (command-line-arguments '()) + (public-key (read-file-sexp %public-key-file)) + (private-key (read-file-sexp %private-key-file))) + (define (s3-file-exists? name) + (if (null? + (retry-on-error + (lambda () + (s3-list-objects s3-bucket name + #: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 + #:public-key public-key + #:private-key private-key + #:post-publish-hook + (lambda (directory narinfo-filename nar-filename) + (unless (s3-file-exists? narinfo-filename) + (retry-on-error + (lambda () + (s3-cp s3-bucket + (string-append directory "/" nar-filename) + nar-filename + #:command-line-arguments + command-line-arguments)) + #:times 6 + #:delay 20) + (retry-on-error + (lambda () + (s3-cp s3-bucket + (string-append directory "/" narinfo-filename) + narinfo-filename + #:command-line-arguments + command-line-arguments)) + #:times 6 + #:delay 20)) + + (delete-file (string-append directory "/" narinfo-filename)) + (delete-file (string-append directory "/" nar-filename)))))) + (define (default-build-failure-hook datastore build-id) (let ((agent-id (datastore-agent-for-build datastore build-id))) diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm index 0b9c8f7..244adc8 100644 --- a/guix-build-coordinator/utils.scm +++ b/guix-build-coordinator/utils.scm @@ -3,11 +3,14 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-60) #:use-module (ice-9 ftw) + #:use-module (ice-9 popen) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 threads) + #:use-module (ice-9 textual-ports) #:use-module (ice-9 rdelim) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) #:use-module (web uri) #:use-module (web http) @@ -19,6 +22,7 @@ #:use-module (gcrypt random) #:use-module (fibers) #:use-module (fibers channels) + #:use-module (json) #:use-module (guix pki) #:use-module (guix utils) #:use-module (guix config) @@ -41,7 +45,10 @@ narinfo-string - retry-on-error)) + retry-on-error + + s3-list-objects + s3-cp)) (define %worker-thread-args @@ -416,3 +423,56 @@ References: ~a~%" delay) (sleep delay) (loop (+ 1 attempt)))))))) + +(define* (s3-list-objects s3-bucket prefix + #:key (command-line-arguments '())) + (let ((command + `("aws" "s3api" + ,@command-line-arguments + "list-objects" + "--bucket" ,s3-bucket + "--prefix" ,prefix))) + (simple-format + #t + "running: ~A\n" + (string-join command)) + (let ((pipe (apply open-pipe* + OPEN_READ + command))) + + (let ((output (get-string-all pipe)) + (exit-code (status:exit-val + (close-pipe pipe)))) + (if (zero? (peek "EXIT" exit-code)) + (if (string-null? (peek "OUT" output)) + '() + (json-string->scm output)) + (raise-exception + (make-exception-with-message + output))))))) + +(define* (s3-cp s3-bucket source destination + #:key (command-line-arguments '())) + (let ((command + `("aws" "s3" + ,@command-line-arguments + "cp" + ,source + ,(simple-format #f "s3://~A/~A" + s3-bucket destination)))) + (simple-format + #t + "running: ~A\n" + (string-join command)) + (let ((exit-code + (status:exit-val + (apply system* command)))) + (unless (zero? exit-code) + (raise-exception + (make-exception-with-message + (simple-format + #f + "error: command failed (~A): ~A\n" + exit-code + command)))) + #t))) -- cgit v1.2.3