diff options
| -rw-r--r-- | nar-herder/cached-compression.scm | 62 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 10 |
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 |