diff options
Diffstat (limited to 'guix')
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 155 |
1 files changed, 145 insertions, 10 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 2b447ce7f2..453a29a5ea 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix config) #:use-module (guix nar) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -30,6 +31,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (web uri) #:use-module (web client) @@ -47,6 +49,36 @@ ;;; ;;; Code: +(define %narinfo-cache-directory + ;; A local cache of narinfos, to avoid going to the network. + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute-binary")) + (string-append %state-directory "/substitute-binary/cache"))) + +(define %narinfo-ttl + ;; Number of seconds during which cached narinfo lookups are considered + ;; valid. + (* 24 3600)) + +(define %narinfo-negative-ttl + ;; Likewise, but for negative lookups---i.e., cached lookup failures. + (* 3 3600)) + +(define (with-atomic-file-output file proc) + "Call PROC with an output port for the file that is going to replace FILE. +Upon success, FILE is atomically replaced by what has been written to the +output port, and PROC's result is returned." + (let* ((template (string-append file ".XXXXXX")) + (out (mkstemp! template))) + (with-throw-handler #t + (lambda () + (let ((result (proc out))) + (close out) + (rename-file template file) + result)) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + (define (fields->alist port) "Read recutils-style record from PORT and return them as a list of key/value pairs." @@ -72,6 +104,17 @@ pairs." (let ((args (map (cut assoc-ref alist <>) keys))) (apply make args))) +(define (object->fields object fields port) + "Write OBJECT (typically a record) as a series of recutils-style fields to +PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." + (let loop ((fields fields)) + (match fields + (() + object) + (((field . get) rest ...) + (format port "~a: ~a~%" field (get object)) + (loop rest))))) + (define (fetch uri) "Return a binary input port to URI and the number of bytes it's expected to provide." @@ -161,22 +204,113 @@ failure." (_ deriver)) system))) +(define* (read-narinfo port #:optional url) + "Read a narinfo from PORT in its standard external form. If URL is true, it +must be a string used to build full URIs from relative URIs found while +reading PORT." + (alist->record (fields->alist port) + (narinfo-maker url) + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System"))) + +(define (write-narinfo narinfo port) + "Write NARINFO to PORT." + (define (empty-string-if-false x) + (or x "")) + + (define (number-or-empty-string x) + (if (number? x) + (number->string x) + "")) + + (object->fields narinfo + `(("StorePath" . ,narinfo-path) + ("URL" . ,(compose uri->string narinfo-uri)) + ("Compression" . ,narinfo-compression) + ("FileHash" . ,(compose empty-string-if-false + narinfo-file-hash)) + ("FileSize" . ,(compose number-or-empty-string + narinfo-file-size)) + ("NarHash" . ,(compose empty-string-if-false + narinfo-hash)) + ("NarSize" . ,(compose number-or-empty-string + narinfo-size)) + ("References" . ,(compose string-join narinfo-references)) + ("Deriver" . ,(compose empty-string-if-false + narinfo-deriver)) + ("System" . ,narinfo-system)) + port)) + +(define (narinfo->string narinfo) + "Return the external representation of NARINFO." + (call-with-output-string (cut write-narinfo narinfo <>))) + +(define (string->narinfo str) + "Return the narinfo represented by STR." + (call-with-input-string str (cut read-narinfo <>))) + (define (fetch-narinfo cache path) "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH." (define (download url) ;; Download the `nix-cache-info' from URL, and return its contents as an ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) + (false-if-exception (fetch (string->uri url)))) (and=> (download (string-append (cache-url cache) "/" (store-path-hash-part path) ".narinfo")) - (lambda (properties) - (alist->record properties (narinfo-maker (cache-url cache)) - '("StorePath" "URL" "Compression" - "FileHash" "FileSize" "NarHash" "NarSize" - "References" "Deriver" "System"))))) + (cute read-narinfo <> (cache-url cache)))) + +(define (lookup-narinfo cache path) + "Check locally if we have valid info about PATH, otherwise go to CACHE and +check what it has." + (define now + (current-time time-monotonic)) + + (define (->time seconds) + (make-time time-monotonic 0 seconds)) + + (define (obsolete? date ttl) + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (->time date))) + + (define cache-file + (string-append %narinfo-cache-directory "/" + (store-path-hash-part path))) + + (define (cache-entry narinfo) + `(narinfo (version 0) + (date ,(time-second now)) + (value ,(and=> narinfo narinfo->string)))) + + (let*-values (((valid? cached) + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 0) ('date date) + ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 0) ('date date) + ('value value)) + ;; A cached positive lookup + (if (obsolete? date %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value)))))))) + (lambda _ + (values #f #f))))) + (if valid? + cached ; including negative caches + (let ((narinfo (fetch-narinfo cache path))) + (with-atomic-file-output cache-file + (lambda (out) + (write (cache-entry narinfo) out))) + narinfo)))) (define (filtered-port command input) "Return an input port (and PID) where data drained from INPUT is filtered @@ -214,6 +348,7 @@ through COMMAND. INPUT must be a file input port." (define (guix-substitute-binary . args) "Implement the build daemon's substituter protocol." + (mkdir-p %narinfo-cache-directory) (match args (("--query") (let ((cache (open-cache %cache-url))) @@ -225,7 +360,7 @@ through COMMAND. INPUT must be a file input port." ;; Return the subset of PATHS available in CACHE. (let ((substitutable (if cache - (par-map (cut fetch-narinfo cache <>) + (par-map (cut lookup-narinfo cache <>) paths) '()))) (for-each (lambda (narinfo) @@ -237,7 +372,7 @@ through COMMAND. INPUT must be a file input port." ;; Reply info about PATHS if it's in CACHE. (let ((substitutable (if cache - (par-map (cut fetch-narinfo cache <>) + (par-map (cut lookup-narinfo cache <>) paths) '()))) (for-each (lambda (narinfo) @@ -263,7 +398,7 @@ through COMMAND. INPUT must be a file input port." (("--substitute" store-path destination) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. (let* ((cache (open-cache %cache-url)) - (narinfo (fetch-narinfo cache store-path)) + (narinfo (lookup-narinfo cache store-path)) (uri (narinfo-uri narinfo))) ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) |