WIP

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)))