Add a hook for publishing to a S3 compatible endpoint

This is helpful if you don't have local storage for nars. There's nothing
special about S3 beyond it's something I wanted to be able to use. I'm hoping
to support other useful ways of publishing substitutes as well.

1 files changed, 73 insertions, 10 deletions

diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index d419365..8fe73ae 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -25,11 +25,13 @@
   #: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)
   #:export (default-build-success-hook
             build-success-publish-hook
+            build-success-s3-publish-hook
             default-build-failure-hook
             default-build-missing-inputs-hook))
 
@@ -42,12 +44,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 +66,19 @@
                 (nar-location
                  (build-output-file-location datastore build-id
                                              output-name))
-                (nar-destination
-                 (string-append publish-directory
-                                "/nar/lzip/"
+                (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 publish-directory
-                                "/"
-                                (string-take (basename output-filename) 32)
-                                ".narinfo")))
+                 (string-append publish-directory "/"
+                                narinfo-filename)))
 
            (copy-file nar-location nar-destination)
 
@@ -91,9 +97,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)))