Be more flexible with cached compressions

Allow specifying where to fetch the source files from, enabling cached
compressions for mirrors.

2 files changed, 63 insertions, 9 deletions

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index e30469f..e6cf646 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -24,6 +24,10 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 threads)
+  #:use-module (logging logger)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module ((guix build utils)
@@ -170,7 +174,7 @@
 
 (define* (make-maybe-trigger-creation-of-compressed-nars
           database
-          canonical-storage
+          nar-source
           enabled-cached-compressions
           cached-compression-min-uses
           #:key (cached-compression-workers 2))
@@ -234,7 +238,7 @@
                  (let ((new-bytes
                         (make-compressed-nar
                          database
-                         canonical-storage
+                         nar-source
                          enabled-cached-compressions
                          narinfo-id
                          missing-compression)))
@@ -286,7 +290,7 @@
            #t))))))
 
 (define (make-compressed-nar database
-                             canonical-storage
+                             nar-source
                              enabled-cached-compressions
                              narinfo-id
                              target-compression)
@@ -297,14 +301,50 @@
     (database-select-narinfo-files-by-narinfo-id database
                                                  narinfo-id))
 
+  (log-msg 'DEBUG "making " target-compression " for "
+           (basename
+            (assq-ref (first narinfo-files) 'url)))
+
   (let* ((source-narinfo-file
           ;; There's no specific logic to this, it should be possible
           ;; to use any file
           (first narinfo-files))
          (source-filename
-          (string-append
-           canonical-storage
-           (assq-ref source-narinfo-file 'url))))
+          (cond
+           ((string-prefix? "http" nar-source)
+            (let* ((output-port (mkstemp "/tmp/nar-herder-source-nar-XXXXXX"))
+                   (filename
+                    (port-filename output-port))
+                   (uri
+                    (string->uri
+                     (string-append nar-source
+                                    (assq-ref source-narinfo-file 'url)))))
+
+              (log-msg 'DEBUG "downloading " (uri->string uri))
+              (with-port-timeouts
+               (lambda ()
+                 (call-with-values
+                     (lambda ()
+                       (http-get uri
+                                 #:decode-body? #f
+                                 #:streaming? #t))
+                   (lambda (response body)
+                     (unless (= (response-code response)
+                                200)
+                       (error "unknown response code"))
+
+                     (dump-port body output-port)))
+                 (close-port output-port)))
+
+              filename))
+           ((string-prefix? "/" nar-source)
+            (string-append
+             ;; If it's a filename, then it's the canonical path to
+             ;; the storage directory
+             nar-source
+             (assq-ref source-narinfo-file 'url)))
+           (else
+            (error "unknown nar source")))))
 
     (let* ((dest-directory
             (assq-ref cached-compression-details
@@ -312,8 +352,8 @@
            (dest-filename
             (string-append
              dest-directory
-             "/" (last
-                  (string-split source-filename #\/))))
+             "/" (basename
+                  (assq-ref source-narinfo-file 'url))))
            (tmp-dest-filename
             (string-append dest-filename ".tmp")))
 
@@ -343,6 +383,10 @@
        tmp-dest-filename
        dest-filename)
 
+      (when (string-prefix? "http" nar-source)
+        (log-msg 'DEBUG "deleting temporary file " source-filename)
+        (delete-file source-filename))
+
       (let ((bytes
              (stat:size (stat dest-filename))))
 
@@ -352,4 +396,6 @@
          bytes
          (symbol->string target-compression))
 
+        (log-msg 'DEBUG "created " dest-filename)
+
         bytes))))
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index e62f60f..f278ac2 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -182,6 +182,13 @@
                               (string->number arg)
                               result)))
 
+        (option '("cached-compression-nar-source") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'cached-compression-nar-source
+                              arg
+                              (alist-delete 'cached-compression-nar-source
+                                            result))))
+
         (option '("ttl") #t #f
                 (lambda (opt name arg result)
                   (let ((duration (string->duration arg)))
@@ -478,7 +485,8 @@
                  #f
                  (make-maybe-trigger-creation-of-compressed-nars
                   database
-                  canonical-storage
+                  (or (assq-ref opts 'cached-compression-nar-source)
+                      canonical-storage)
                   enabled-cached-compressions
                   cached-compression-min-uses
                   #:cached-compression-workers