diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 36 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 120 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 182 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 250 |
7 files changed, 575 insertions, 90 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 339ad0d06f..0bf154dd41 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -43,12 +43,11 @@ When SOURCE? is true, return the derivations of the package sources." (let ((p (read/eval-package-expression str))) (if source? - (let ((source (package-source p)) - (loc (package-location p))) + (let ((source (package-source p))) (if source (package-source-derivation (%store) source) - (leave (_ "~a: error: package `~a' has no source~%") - (location->string loc) (package-name p)))) + (leave (_ "package `~a' has no source~%") + (package-name p)))) (package-derivation (%store) p system)))) @@ -169,7 +168,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (add-indirect-root (%store) root)) ((paths ...) (fold (lambda (path count) - (let ((root (string-append root "-" (number->string count)))) + (let ((root (string-append root + "-" + (number->string count)))) (symlink path root) (add-indirect-root (%store) root)) (+ 1 count)) @@ -177,8 +178,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) paths)))) (lambda args (leave (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) - (exit 1))))) + root (strerror (system-error-errno args))))))) (define newest-available-packages (memoize find-newest-available-packages)) @@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (_ #f)) opts))) - (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?)) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) ;; TODO: Add more options. (set-build-options (%store) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 7c00312c74..220211e6b8 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -21,30 +21,15 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix base32) - #:use-module ((guix download) #:select (%mirrors)) - #:use-module (guix build download) + #:use-module (guix download) #:use-module (web uri) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:export (guix-download)) -(define (fetch-and-store store fetch name) - "Call FETCH for URI, and pass it the name of a file to write to; eventually, -copy data from that port to STORE, under NAME. Return the resulting -store path." - (call-with-temporary-output-file - (lambda (temp port) - (let ((result - (parameterize ((current-output-port (current-error-port))) - (fetch temp)))) - (close port) - (and result - (add-to-store store name #f "sha256" temp)))))) ;;; ;;; Command-line options. @@ -55,11 +40,14 @@ store path." `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (_ "Usage: guix download [OPTION]... URL + (display (_ "Usage: guix download [OPTION] URL Download the file at URL, add it to the store, and print its store path -and the hash of its contents.\n")) +and the hash of its contents. + +Supported formats: 'nix-base32' (default), 'base32', and 'base16' +('hex' and 'hexadecimal' can be used as well).\n")) (format #t (_ " - -f, --format=FMT write the hash in the given format (default: `nix-base32')")) + -f, --format=FMT write the hash in the given format")) (newline) (display (_ " -h, --help display this help and exit")) @@ -114,20 +102,18 @@ and the hash of its contents.\n")) (store (open-connection)) (arg (assq-ref opts 'argument)) (uri (or (string->uri arg) - (leave (_ "guix-download: ~a: failed to parse URI~%") + (leave (_ "~a: failed to parse URI~%") arg))) (path (case (uri-scheme uri) ((file) (add-to-store store (basename (uri-path uri)) #f "sha256" (uri-path uri))) (else - (fetch-and-store store - (cut url-fetch arg <> - #:mirrors %mirrors) - (basename (uri-path uri)))))) + (download-to-store store (uri->string uri) + (basename (uri-path uri)))))) (hash (call-with-input-file (or path - (leave (_ "guix-download: ~a: download failed~%") + (leave (_ "~a: download failed~%") arg)) (compose sha256 get-bytevector-all))) (fmt (assq-ref opts 'format))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 3d918923f8..7625bc46e6 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -87,9 +87,8 @@ interpreted." ("TB" (expt 10 12)) ("" 1) (_ - (leave (_ "error: unknown unit: ~a~%") unit) - (exit 1)))) - (leave (_ "error: invalid number: ~a") numstr)))) + (leave (_ "unknown unit: ~a~%") unit)))) + (leave (_ "invalid number: ~a~%") numstr)))) (define %options ;; Specification of the command-line options. @@ -110,7 +109,7 @@ interpreted." (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (leave (_ "error: invalid amount of storage: ~a~%") + (leave (_ "invalid amount of storage: ~a~%") arg)))) (#f result))))) (option '(#\d "delete") #f #f diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm new file mode 100644 index 0000000000..ad05a4e66f --- /dev/null +++ b/guix/scripts/hash.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts hash) + #:use-module (guix base32) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (rnrs io ports) + #:use-module (rnrs files) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-hash)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((format . ,bytevector->nix-base32-string))) + +(define (show-help) + (display (_ "Usage: guix hash [OPTION] FILE +Return the cryptographic hash of FILE. + +Supported formats: 'nix-base32' (default), 'base32', and 'base16' +('hex' and 'hexadecimal' can be used as well).\n")) + (format #t (_ " + -f, --format=FMT write the hash in the given format")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (define fmt-proc + (match arg + ("nix-base32" + bytevector->nix-base32-string) + ("base32" + bytevector->base32-string) + ((or "base16" "hex" "hexadecimal") + bytevector->base16-string) + (x + (leave (_ "unsupported hash format: ~a~%") + arg)))) + + (alist-cons 'format fmt-proc + (alist-delete 'format result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix hash"))))) + + + +;;; +;;; Entry point. +;;; + +(define (guix-hash . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "unrecognized option: ~a~%") + name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts))) + (fmt (assq-ref opts 'format))) + + (match args + ((file) + (catch 'system-error + (lambda () + (format #t "~a~%" + (call-with-input-file file + (compose fmt sha256 get-bytevector-all)))) + (lambda args + (leave (_ "~a~%") + (strerror (system-error-errno args)))))) + (_ + (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ac99d16497..c5656efc14 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -208,7 +208,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (switch-symlinks profile previous-profile)) (cond ((not (file-exists? profile)) ; invalid profile - (leave (_ "error: profile `~a' does not exist~%") + (leave (_ "profile `~a' does not exist~%") profile)) ((zero? number) ; empty profile (format (current-error-port) @@ -266,19 +266,42 @@ matching packages." (assoc-ref (derivation-outputs drv) sub-drv)))) `(,name ,out)))))) +(define %sigint-prompt + ;; The prompt to jump to upon SIGINT. + (make-prompt-tag "interruptible")) + +(define (call-with-sigint-handler thunk handler) + "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal +number in the context of the continuation of the call to this function, and +return its return value." + (call-with-prompt %sigint-prompt + (lambda () + (sigaction SIGINT + (lambda (signum) + (sigaction SIGINT SIG_DFL) + (abort-to-prompt %sigint-prompt signum))) + (thunk)) + (lambda (k signum) + (handler signum)))) + (define-syntax-rule (waiting exp fmt rest ...) "Display the given message while EXP is being evaluated." (let* ((message (format #f fmt rest ...)) (blank (make-string (string-length message) #\space))) (display message (current-error-port)) (force-output (current-error-port)) - (let ((result exp)) - ;; Clear the line. - (display #\cr (current-error-port)) - (display blank (current-error-port)) - (display #\cr (current-error-port)) - (force-output (current-error-port)) - exp))) + (call-with-sigint-handler + (lambda () + (let ((result exp)) + ;; Clear the line. + (display #\cr (current-error-port)) + (display blank (current-error-port)) + (display #\cr (current-error-port)) + (force-output (current-error-port)) + exp)) + (lambda (signum) + (format (current-error-port) " interrupted by signal ~a~%" SIGINT) + #f)))) (define (check-package-freshness package) "Check whether PACKAGE has a newer version available upstream, and report @@ -328,7 +351,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -r, --remove=PACKAGE remove PACKAGE")) (display (_ " - -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) + -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " --roll-back roll back to the previous generation")) (newline) @@ -379,7 +402,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\r "remove") #t #f (lambda (opt name arg result) (alist-cons 'remove arg result))) - (option '(#\u "upgrade") #t #f + (option '(#\u "upgrade") #f #t (lambda (opt name arg result) (alist-cons 'upgrade arg result))) (option '("roll-back") #f #f @@ -454,8 +477,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define (ensure-output p sub-drv) (if (member sub-drv (package-outputs p)) p - (leave (_ "~a: error: package `~a' lacks output `~a'~%") - (location->string (package-location p)) + (leave (_ "package `~a' lacks output `~a'~%") (package-full-name p) sub-drv))) @@ -602,7 +624,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (let* ((installed (manifest-packages (profile-manifest profile))) (upgrade-regexps (filter-map (match-lambda (('upgrade . regexp) - (make-regexp regexp)) + (make-regexp (or regexp ""))) (_ #f)) opts)) (upgrade (if (null? upgrade-regexps) @@ -674,7 +696,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (ensure-default-profile)) (show-what-to-remove/install remove* install* dry-run?) - (show-what-to-build (%store) drv dry-run?) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) (or dry-run? (and (build-derivations (%store) drv) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm new file mode 100644 index 0000000000..da318b07ad --- /dev/null +++ b/guix/scripts/refresh.scm @@ -0,0 +1,182 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts refresh) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gnu-maintenance) + #:use-module (gnu packages) + #:use-module ((gnu packages base) #:select (%final-inputs)) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs io ports) + #:export (guix-refresh)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + '()) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\s "select") #t #f + (lambda (opt name arg result) + (match arg + ((or "core" "non-core") + (alist-cons 'select (string->symbol arg) + result)) + (x + (leave (_ "~a: invalid selection; expected `core' or `non-core'") + arg))))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix refresh"))))) + +(define (show-help) + (display (_ "Usage: guix refresh [OPTION]... PACKAGE... +Update package definitions to match the latest upstream version. + +When PACKAGE... is given, update only the specified packages. Otherwise +update all the packages of the distribution, or the subset thereof +specified with `--select'.\n")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + -s, --select=SUBSET select all the packages in SUBSET, one of + `core' or `non-core'")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-refresh . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (let* ((opts (parse-options)) + (dry-run? (assoc-ref opts 'dry-run?)) + (packages (match (concatenate + (filter-map (match-lambda + (('argument . value) + (let ((p (find-packages-by-name value))) + (unless p + (leave (_ "~a: no package by that name") + value)) + p)) + (_ #f)) + opts)) + (() ; default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + ;; TODO: Keep only the newest of each package. + (fold-packages (lambda (package result) + (if (select? package) + (cons package result) + result)) + '()))) + (some ; user-specified packages + some)))) + (with-error-handling + (if dry-run? + (for-each (lambda (package) + (match (false-if-exception (package-update-path package)) + ((new-version . directory) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (format (current-error-port) + (_ "~a: ~a would be upgraded from ~a to ~a~%") + (location->string loc) + (package-name package) (package-version package) + new-version))) + (_ #f))) + packages) + (let ((store (open-connection))) + (for-each (lambda (package) + (let-values (((version tarball) + (catch #t + (lambda () + (package-update store package)) + (lambda _ + (values #f #f)))) + ((loc) + (or (package-field-location package + 'version) + (package-location package)))) + (when version + (format (current-error-port) + (_ "~a: ~a: updating from version ~a to version ~a...~%") + (location->string loc) (package-name package) + (package-version package) version) + (let ((hash (call-with-input-file tarball + (compose sha256 get-bytevector-all)))) + (update-package-source package version hash))))) + packages)))))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 2b447ce7f2..87561db4b3 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -22,18 +22,20 @@ #: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) #:use-module (ice-9 threads) #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #: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) - #:use-module (web response) + #:use-module (guix web) #:export (guix-substitute-binary)) ;;; Comment: @@ -47,6 +49,40 @@ ;;; ;;; 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 %narinfo-expired-cache-entry-removal-delay + ;; How often we want to remove files corresponding to expired cache entries. + (* 7 24 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 +108,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." @@ -80,28 +127,7 @@ provide." (let ((port (open-input-file (uri-path uri)))) (values port (stat:size (stat port))))) ((http) - (let*-values (((resp port) - ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated - ;; in 2.0.8 (!). Assume it is available here. - (if (version>? "2.0.7" (version)) - (http-get* uri #:decode-body? #f) - (http-get uri #:streaming? #t))) - ((code) - (response-code resp)) - ((size) - (response-content-length resp))) - (case code - ((200) ; OK - (values port size)) - ((301 ; moved permanently - 302) ; found (redirection) - (let ((uri (response-location resp))) - (format #t "following redirection to `~a'...~%" - (uri->string uri)) - (fetch uri))) - (else - (error "download failed" (uri->string uri) - code (response-reason-phrase resp)))))))) + (http-fetch uri #:text? #f)))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) @@ -161,22 +187,166 @@ 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"))))) + (and (string=? (cache-store-directory cache) (%store-prefix)) + (and=> (download (string-append (cache-url cache) "/" + (store-path-hash-part path) + ".narinfo")) + (cute read-narinfo <> (cache-url cache))))) + +(define (obsolete? date now ttl) + "Return #t if DATE is obsolete compared to NOW + TTL seconds." + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (make-time time-monotonic 0 date))) + +(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 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 now %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 0) ('date date) + ('value value)) + ;; A cached positive lookup + (if (obsolete? date now %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value)))))))) + (lambda _ + (values #f #f))))) + (if valid? + cached ; including negative caches + (let ((narinfo (and=> (force cache) + (cut fetch-narinfo <> path)))) + (with-atomic-file-output cache-file + (lambda (out) + (write (cache-entry narinfo) out))) + narinfo)))) + +(define (remove-expired-cached-narinfos) + "Remove expired narinfo entries from the cache. The sole purpose of this +function is to make sure `%narinfo-cache-directory' doesn't grow +indefinitely." + (define now + (current-time time-monotonic)) + + (define (expired? file) + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (port) + (match (read port) + (('narinfo ('version 0) ('date date) + ('value #f)) + (obsolete? date now %narinfo-negative-ttl)) + (('narinfo ('version 0) ('date date) + ('value _)) + (obsolete? date now %narinfo-ttl)) + (_ #t))))) + (lambda args + ;; FILE may have been deleted. + #t))) + + (for-each (lambda (file) + (let ((file (string-append %narinfo-cache-directory + "/" file))) + (when (expired? file) + ;; Wrap in `false-if-exception' because FILE might have been + ;; deleted in the meantime (TOCTTOU). + (false-if-exception (delete-file file))))) + (scandir %narinfo-cache-directory + (lambda (file) + (= (string-length file) 32))))) + +(define (maybe-remove-expired-cached-narinfo) + "Remove expired narinfo entries from the cache if deemed necessary." + (define now + (current-time time-monotonic)) + + (define expiry-file + (string-append %narinfo-cache-directory "/last-expiry-cleanup")) + + (define last-expiry-date + (or (false-if-exception + (call-with-input-file expiry-file read)) + 0)) + + (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay) + (remove-expired-cached-narinfos) + (call-with-output-file expiry-file + (cute write (time-second now) <>)))) (define (filtered-port command input) "Return an input port (and PID) where data drained from INPUT is filtered @@ -214,9 +384,11 @@ 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) + (maybe-remove-expired-cached-narinfo) (match args (("--query") - (let ((cache (open-cache %cache-url))) + (let ((cache (delay (open-cache %cache-url)))) (let loop ((command (read-line))) (or (eof-object? command) (begin @@ -225,7 +397,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 +409,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) @@ -262,8 +434,8 @@ through COMMAND. INPUT must be a file input port." (loop (read-line))))))) (("--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)) + (let* ((cache (delay (open-cache %cache-url))) + (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)) |