diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/authenticate.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 59 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 69 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 106 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 79 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 354 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 314 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 17 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm (renamed from guix/scripts/substitute-binary.scm) | 336 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 38 |
12 files changed, 991 insertions, 401 deletions
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index e9900689fa..eedebb4bac 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,12 +82,6 @@ to stdout upon success." (leave (_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) -(define %default-port-conversion-strategy - ;; This fluid is in Guile > 2.0.5. - (if (defined? '%default-port-conversion-strategy) - (@ (guile) %default-port-conversion-strategy) - (make-fluid #f))) - ;;; ;;; Entry point with 'openssl'-compatible interface. We support this diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 370c2a37ff..2307f76b42 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -37,6 +37,7 @@ #:autoload (guix download) (download-to-store) #:export (%standard-build-options set-build-options-from-command-line + set-build-options-from-command-line* show-build-options-help guix-build)) @@ -139,6 +140,9 @@ options handled by 'set-build-options-from-command-line', and listed in #:print-build-trace (assoc-ref opts 'print-build-trace?) #:verbosity (assoc-ref opts 'verbosity))) +(define set-build-options-from-command-line* + (store-lift set-build-options-from-command-line)) + (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\L "load-path") #t #f @@ -228,6 +232,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " + --sources[=TYPE] build source derivations; TYPE may optionally be one + of \"package\", \"all\" (default), or \"transitive\"")) + (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -262,10 +269,22 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix build"))) - (option '(#\S "source") #f #f (lambda (opt name arg result) - (alist-cons 'source? #t result))) + (alist-cons 'source #t result))) + (option '("sources") #f #t + (lambda (opt name arg result) + (match arg + ("package" + (alist-cons 'source #t result)) + ((or "all" #f) + (alist-cons 'source package-direct-sources result)) + ("transitive" + (alist-cons 'source package-transitive-sources result)) + (else + (leave (_ "invalid argument: '~a' option argument: ~a, ~ +must be one of 'package', 'all', or 'transitive'~%") + name arg))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -308,28 +327,34 @@ build." (triplet (cut package-cross-derivation <> <> triplet <>)))) - (define src? (assoc-ref opts 'source?)) + (define src (assoc-ref opts 'source)) (define sys (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? graft?)) (let ((opts (options/with-source store (options/resolve-packages store opts)))) - (filter-map (match-lambda - (('argument . (? package? p)) - (if src? + (concatenate + (filter-map (match-lambda + (('argument . (? package? p)) + (match src + (#f + (list (package->derivation store p sys))) + (#t (let ((s (package-source p))) - (package-source-derivation store s)) - (package->derivation store p sys))) - (('argument . (? derivation? drv)) - drv) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (_ #f)) - opts)))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p))))) + (('argument . (? derivation? drv)) + (list drv)) + (('argument . (? derivation-path? drv)) + (list (call-with-input-file drv read-derivation))) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (_ #f)) + opts))))) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by actual diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 80ae924410..d053daf02e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,9 +23,9 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix utils) #:use-module (guix monads) - #:use-module (guix build utils) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 format) @@ -35,32 +36,20 @@ #:use-module (srfi srfi-98) #:export (guix-environment)) -(define (for-each-search-path proc inputs derivations pure?) - "Apply PROC for each native search path in INPUTS in addition to 'PATH'. -Use the output paths of DERIVATIONS to build each search path. When PURE? is -#t, the existing search path value is ignored. Otherwise, the existing search -path value is appended." - (let ((paths (append-map (lambda (drv) - (map (match-lambda - ((_ . output) - (derivation-output-path output))) - (derivation-outputs drv))) - derivations))) - (for-each (match-lambda - (($ <search-path-specification> - variable directories separator) - (let* ((current (getenv variable)) - (path (search-path-as-list directories paths)) - (value (list->search-path-as-string path separator))) - (proc variable - (if (and current (not pure?)) - (string-append value separator current) - value))))) - (cons* (search-path-specification - (variable "PATH") - (files '("bin" "sbin"))) - (delete-duplicates - (append-map package-native-search-paths inputs)))))) +(define (evaluate-input-search-paths inputs derivations) + "Evaluate the native search paths of INPUTS, a list of packages, of the +outputs of DERIVATIONS, and return a list of search-path/value pairs." + (let ((directories (append-map (lambda (drv) + (map (match-lambda + ((_ . output) + (derivation-output-path output))) + (derivation-outputs drv))) + derivations)) + (paths (cons $PATH + (delete-duplicates + (append-map package-native-search-paths + inputs))))) + (evaluate-search-paths paths directories))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables @@ -80,15 +69,26 @@ as 'HOME' and 'USER' are left untouched." PURE? is #t, unset the variables in the current environment. Otherwise, augment existing enviroment variables with additional search paths." (when pure? (purify-environment)) - (for-each-search-path setenv inputs derivations pure?)) + (for-each (match-lambda + ((($ <search-path-specification> variable _ separator) . value) + (let ((current (getenv variable))) + (setenv variable + (if (and current (not pure?)) + (string-append value separator current) + value))))) + (evaluate-input-search-paths inputs derivations))) (define (show-search-paths inputs derivations pure?) "Display the needed search paths to build an environment that contains the packages within INPUTS. When PURE? is #t, do not augment existing environment variables with additional search paths." - (for-each-search-path (lambda (variable value) - (format #t "export ~a=\"~a\"~%" variable value)) - inputs derivations pure?)) + (for-each (match-lambda + ((search-path . value) + (display + (search-path-definition search-path value + #:kind (if pure? 'exact 'prefix))) + (newline))) + (evaluate-input-search-paths inputs derivations))) (define (show-help) (display (_ "Usage: guix environment [OPTION]... PACKAGE... @@ -191,13 +191,6 @@ packages." (delete-duplicates (append-map transitive-inputs packages))) -;; TODO: Deduplicate these. -(define show-what-to-build* - (store-lift show-what-to-build)) - -(define set-build-options-from-command-line* - (store-lift set-build-options-from-command-line)) - (define (build-inputs inputs opts) "Build the packages in INPUTS using the build options in OPTS." (let ((substitutes? (assoc-ref opts 'substitutes?)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index ed16cab8f9..4bae65a1ec 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,6 +44,8 @@ Invoke the garbage collector.\n")) (display (_ " -d, --delete attempt to delete PATHS")) (display (_ " + --optimize optimize the store by deduplicating identical files")) + (display (_ " --list-dead list dead paths")) (display (_ " --list-live list live paths")) @@ -88,6 +90,10 @@ Invoke the garbage collector.\n")) (lambda (opt name arg result) (alist-cons 'action 'delete (alist-delete 'action result)))) + (option '("optimize") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'optimize + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -169,6 +175,8 @@ Invoke the garbage collector.\n")) (list-relatives requisites)) ((list-referrers) (list-relatives referrers)) + ((optimize) + (optimize-store store)) ((list-dead) (for-each (cut simple-format #t "~a~%" <>) (dead-paths store))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 7e75c10b3e..06b4c17573 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm new file mode 100644 index 0000000000..f7c18cd3bf --- /dev/null +++ b/guix/scripts/import/hackage.scm @@ -0,0 +1,106 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; +;;; 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 import hackage) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import hackage) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-hackage)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '((include-test-dependencies? . #t))) + +(define (show-help) + (display (_ "Usage: guix import hackage PACKAGE-NAME +Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME +includes a suffix constituted by a dash followed by a numerical version (as +used with Guix packages), then a definition for the specified version of the +package will be generated. If no version suffix is pecified, then the +generated package definition will correspond to the latest available +version.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -t, --no-test-dependencies don't include test only dependencies")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import hackage"))) + (option '(#\t "no-test-dependencies") #f #f + (lambda (opt name arg result) + (alist-cons 'include-test-dependencies? #f + (alist-delete 'include-test-dependencies? + result)))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-hackage . 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)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (hackage->guix-package + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?)))) + (unless sexp + (leave (_ "failed to download cabal file for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index c40d76b558..cced1bda66 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) + #:use-module (guix store) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) @@ -32,6 +33,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web uri) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix build download) #:select (maybe-expand-mirrors open-connection-for-uri)) @@ -41,12 +44,15 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:export (guix-lint check-description-style check-inputs-should-be-native - check-patches + check-patch-file-names check-synopsis-style + check-derivation check-home-page check-source)) @@ -348,26 +354,30 @@ warning for PACKAGE mentionning the FIELD." (package-home-page package)) 'home-page))))) -(define (check-patches package) - ;; Emit a warning if the patches requires by PACKAGE are badly named. - (let ((patches (and=> (package-source package) origin-patches)) - (name (package-name package)) - (full-name (package-full-name package))) - (when (and patches - (any (match-lambda - ((? string? patch) - (let ((filename (basename patch))) - (not (or (eq? (string-contains filename name) 0) - (eq? (string-contains filename full-name) - 0))))) - (_ - ;; This must be an <origin> or something like that. - #f)) - patches)) - (emit-warning package - (_ "file names of patches should start with \ +(define (check-patch-file-names package) + "Emit a warning if the patches requires by PACKAGE are badly named or if the +patch could not be found." + (guard (c ((message-condition? c) ;raised by 'search-patch' + (emit-warning package (condition-message c) + 'patch-file-names))) + (let ((patches (and=> (package-source package) origin-patches)) + (name (package-name package)) + (full-name (package-full-name package))) + (when (and patches + (any (match-lambda + ((? string? patch) + (let ((file (basename patch))) + (not (or (eq? (string-contains file name) 0) + (eq? (string-contains file full-name) + 0))))) + (_ + ;; This must be an <origin> or something like that. + #f)) + patches)) + (emit-warning package + (_ "file names of patches should start with \ the package name") - 'patches)))) + 'patch-file-names))))) (define (escape-quotes str) "Replace any quote character in STR by an escaped quote character." @@ -434,6 +444,25 @@ descriptions maintained upstream." (append-map (cut maybe-expand-mirrors <> %mirrors) uris)))))) +(define (check-derivation package) + "Emit a warning if we fail to compile PACKAGE to a derivation." + (catch #t + (lambda () + (guard (c ((nix-protocol-error? c) + (emit-warning package + (format #f (_ "failed to create derivation: ~a") + (nix-protocol-error-message c)))) + ((message-condition? c) + (emit-warning package + (format #f (_ "failed to create derivation: ~a") + (condition-message c))))) + (with-store store + (package-derivation store package)))) + (lambda args + (emit-warning package + (format #f (_ "failed to create derivation: ~s~%") + args))))) + ;;; @@ -455,9 +484,9 @@ descriptions maintained upstream." (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) (lint-checker - (name 'patch-filenames) - (description "Validate file names of patches") - (check check-patches)) + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) (lint-checker (name 'home-page) (description "Validate home-page URLs") @@ -467,6 +496,10 @@ descriptions maintained upstream." (description "Validate source URLs") (check check-source)) (lint-checker + (name 'derivation) + (description "Report failure to compile a package to a derivation") + (check check-derivation)) + (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 3cc7ae760f..06ee441799 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -25,6 +25,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) @@ -89,6 +90,15 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if %current-profile profile)) +(define (user-friendly-profile profile) + "Return either ~/.guix-profile if that's what PROFILE refers to, directly or +indirectly, or PROFILE." + (if (and %user-profile-directory + (false-if-exception + (string=? (readlink %user-profile-directory) profile))) + %user-profile-directory + profile)) + (define (link-to-empty-profile store generation) "Link GENERATION, a string, to the empty profile." (let* ((drv (run-with-store store @@ -232,6 +242,41 @@ DURATION-RELATION with the current time." filter-by-duration) (else #f))) +(define (delete-matching-generations store profile pattern) + "Delete from PROFILE all the generations matching PATTERN. PATTERN must be +a string denoting a set of generations: the empty list means \"all generations +but the current one\", a number designates a generation, and other patterns +denote ranges as interpreted by 'matching-derivations'." + (let ((current (generation-number profile))) + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (delete-generations (%store) profile + (delv current (profile-generations profile)))) + ;; Do not delete the zeroth generation. + ((equal? 0 (string->number pattern)) + #t) + + ;; If PATTERN is a duration, match generations that are + ;; older than the specified duration. + ((matching-generations pattern profile + #:duration-relation >) + => + (lambda (numbers) + (when (memv current numbers) + (warning (_ "not removing generation ~a, which is current~%") + current)) + + ;; Make sure we don't inadvertently remove the current + ;; generation. + (let ((numbers (delv current numbers))) + (when (null-list? numbers) + (leave (_ "no matching generation~%"))) + (delete-generations (%store) profile numbers)))) + (else + (leave (_ "invalid syntax: ~a~%") pattern))))) + ;;; ;;; Package specifications. @@ -330,77 +375,35 @@ an output path different than CURRENT-PATH." ;;; Search paths. ;;; -(define-syntax-rule (with-null-error-port exp) - "Evaluate EXP with the error port pointing to the bit bucket." - (with-error-to-port (%make-void-port "w") - (lambda () exp))) - (define* (search-path-environment-variables entries profile - #:optional (getenv getenv)) + #:optional (getenv getenv) + #:key (kind 'exact)) "Return environment variable definitions that may be needed for the use of ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the -current settings and report only settings not already effective." - - ;; Prefer ~/.guix-profile to the real profile directory name. - (let ((profile (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) - profile))) - %user-profile-directory - profile))) - - ;; The search path info is not stored in the manifest. Thus, we infer the - ;; search paths from same-named packages found in the distro. - - (define manifest-entry->package - (match-lambda - (($ <manifest-entry> name version) - ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; - ;; the former traverses the module tree only once and then allows for - ;; efficient access via a vhash. - (match (find-best-packages-by-name name version) - ((p _ ...) p) - (_ - (match (find-best-packages-by-name name #f) - ((p _ ...) p) - (_ #f))))))) - - (define search-path-definition - (match-lambda - (($ <search-path-specification> variable files separator - type pattern) - (let* ((values (or (and=> (getenv variable) - (cut string-tokenize* <> separator)) - '())) - ;; Add a trailing slash to force symlinks to be treated as - ;; directories when 'find-files' traverses them. - (files (if pattern - (map (cut string-append <> "/") files) - files)) - - ;; XXX: Silence 'find-files' when it stumbles upon non-existent - ;; directories (see - ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) - (path (with-null-error-port - (search-path-as-list files (list profile) - #:type type - #:pattern pattern)))) - (if (every (cut member <> values) path) - #f - (format #f "export ~a=\"~a\"" - variable - (string-join path separator))))))) - - (let* ((packages (filter-map manifest-entry->package entries)) - (search-paths (delete-duplicates - (append-map package-native-search-paths - packages)))) - (filter-map search-path-definition search-paths)))) +current settings and report only settings not already effective. KIND +must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search +path definition to be returned." + (let ((search-paths (delete-duplicates + (cons $PATH + (append-map manifest-entry-search-paths + entries))))) + (filter-map (match-lambda + ((spec . value) + (let ((variable (search-path-specification-variable spec)) + (sep (search-path-specification-separator spec))) + (environment-variable-definition variable value + #:separator sep + #:kind kind)))) + (evaluate-search-paths search-paths (list profile) + getenv)))) -(define (display-search-paths entries profile) +(define* (display-search-paths entries profile + #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let ((settings (search-path-environment-variables entries profile))) + (let* ((profile (user-friendly-profile profile)) + (settings (search-path-environment-variables entries profile + #:kind kind))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -430,9 +433,15 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " + -m, --manifest=FILE create a new profile generation with the manifest + from FILE")) + (display (_ " + --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) + (display (_ " --roll-back roll back to the previous generation")) (display (_ " - --search-paths display needed environment variable definitions")) + --search-paths[=KIND] + display needed environment variable definitions")) (display (_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) @@ -508,10 +517,21 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) ;; would upgrade everything. (delete '(upgrade . #f) result)) arg-handler)))) + (option '("do-not-upgrade") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'do-not-upgrade arg result) + result) + arg-handler)))) (option '("roll-back") #f #f (lambda (opt name arg result arg-handler) (values (alist-cons 'roll-back? #t result) #f))) + (option '(#\m "manifest") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'manifest arg result) + arg-handler))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result arg-handler) (values (cons `(query list-generations ,(or arg "")) @@ -526,10 +546,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result arg-handler) (values (alist-cons 'switch-generation arg result) #f))) - (option '("search-paths") #f #f + (option '("search-paths") #f #t (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) + (let ((kind (match arg + ((or "exact" "prefix" "suffix") + (string->symbol arg)) + (#f + 'exact) + (x + (leave (_ "~a: unsupported \ +kind of search path~%") + x))))) + (values (cons `(query search-paths ,kind) + result) + #f)))) (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) @@ -586,6 +616,13 @@ return the new list of manifest entries." (_ #f)) opts)) + (define do-not-upgrade-regexps + (filter-map (match-lambda + (('do-not-upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (define packages-to-upgrade (match upgrade-regexps (() @@ -595,6 +632,8 @@ return the new list of manifest entries." (($ <manifest-entry> name version output path _) (and (any (cut regexp-exec <> name) upgrade-regexps) + (not (any (cut regexp-exec <> name) + do-not-upgrade-regexps)) (upgradeable? name version path) (let ((output (or output "out"))) (call-with-values @@ -677,13 +716,31 @@ doesn't need it." (define (readlink* file) "Call 'readlink' until the result is not a symlink." - (catch 'system-error - (lambda () - (readlink* (readlink file))) - (lambda args - (if (= EINVAL (system-error-errno args)) - file - (apply throw args))))) + (define %max-symlink-depth 50) + + (let loop ((file file) + (depth 0)) + (define (absolute target) + (if (absolute-file-name? target) + target + (string-append (dirname file) "/" target))) + + (if (>= depth %max-symlink-depth) + file + (call-with-values + (lambda () + (catch 'system-error + (lambda () + (values #t (readlink file))) + (lambda args + (let ((errno (system-error-errno args))) + (if (or (= errno EINVAL)) + (values #f file) + (apply throw args)))))) + (lambda (success? target) + (if success? + (loop (absolute target) (+ depth 1)) + file)))))) ;;; @@ -751,8 +808,49 @@ more information.~%")) (define dry-run? (assoc-ref opts 'dry-run?)) (define profile (assoc-ref opts 'profile)) - (define current-generation-number - (generation-number profile)) + (define (build-and-use-profile manifest) + (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (let* ((prof-drv (run-with-store (%store) + (profile-derivation + manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks)))) + (prof (derivation->output-path prof-drv))) + (show-what-to-build (%store) (list prof-drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + + (cond + (dry-run? #t) + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (generation-file-name profile + (+ 1 number)))) + (and (build-derivations (%store) (list prof-drv)) + (let* ((entries (manifest-entries manifest)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks profile name) + (unless (string=? profile %current-profile) + (register-gc-root (%store) name)) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) + (display-search-paths entries profile))))))))) ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) @@ -782,88 +880,34 @@ more information.~%")) (for-each (match-lambda (('delete-generations . pattern) - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (delete-generations - (%store) profile - (delete current-generation-number - (profile-generations profile)))) - ;; Do not delete the zeroth generation. - ((equal? 0 (string->number pattern)) - (exit 0)) - - ;; If PATTERN is a duration, match generations that are - ;; older than the specified duration. - ((matching-generations pattern profile - #:duration-relation >) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (delete-generations (%store) profile numbers)))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) + (delete-matching-generations (%store) profile pattern) (process-actions (alist-delete 'delete-generations opts))) (_ #f)) opts)) + ((and (assoc-ref opts 'manifest) + (not dry-run?)) + (let* ((file-name (assoc-ref opts 'manifest)) + (user-module (make-user-module '((guix profiles) + (gnu)))) + (manifest (load* file-name user-module))) + (format #t (_ "installing new manifest from ~a with ~d entries.~%") + file-name (length (manifest-entries manifest))) + (build-and-use-profile manifest))) (else (let* ((manifest (profile-manifest profile)) (install (options->installable opts manifest)) (remove (options->removable opts manifest)) - (bootstrap? (assoc-ref opts 'bootstrap?)) (transaction (manifest-transaction (install install) (remove remove))) (new (manifest-perform-transaction manifest transaction))) - (when (equal? profile %current-profile) - (ensure-default-profile)) - (unless (and (null? install) (null? remove)) - (let* ((prof-drv (run-with-store (%store) - (profile-derivation - new - #:info-dir? (not bootstrap?) - #:ca-certificate-bundle? (not bootstrap?)))) - (prof (derivation->output-path prof-drv))) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (show-what-to-build (%store) (list prof-drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (generation-file-name profile - (+ 1 number)))) - (and (build-derivations (%store) (list prof-drv)) - (let* ((entries (manifest-entries new)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks profile name) - (unless (string=? profile %current-profile) - (register-gc-root (%store) name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) - (display-search-paths entries - profile)))))))))))) + (show-manifest-transaction (%store) manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile new)))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -932,11 +976,13 @@ more information.~%")) (available (fold-packages (lambda (p r) (let ((n (package-name p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)))) + (if (supported-package? p) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + r) + (cons p r)) + r))) '()))) (leave-on-EPIPE (for-each (lambda (p) @@ -966,11 +1012,13 @@ more information.~%")) (find-packages-by-name name version))) #t)) - (('search-paths) + (('search-paths kind) (let* ((manifest (profile-manifest profile)) (entries (manifest-entries manifest)) + (profile (user-friendly-profile profile)) (settings (search-path-environment-variables entries profile - (const #f)))) + (const #f) + #:kind kind))) (format #t "~{~a~%~}" settings) #t)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm new file mode 100644 index 0000000000..7bad2619b9 --- /dev/null +++ b/guix/scripts/publish.scm @@ -0,0 +1,314 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@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 publish) + #:use-module ((system repl server) #:prefix repl:) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web uri) + #:use-module (guix base32) + #:use-module (guix base64) + #:use-module (guix config) + #:use-module (guix derivations) + #:use-module (guix hash) + #:use-module (guix pki) + #:use-module (guix pk-crypto) + #:use-module (guix store) + #:use-module (guix serialization) + #:use-module (guix ui) + #:export (guix-publish)) + +(define (show-help) + (format #t (_ "Usage: guix publish [OPTION]... +Publish ~a over HTTP.\n") %store-directory) + (display (_ " + -p, --port=PORT listen on PORT")) + (display (_ " + --listen=HOST listen on the network interface for HOST")) + (display (_ " + -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " + -r, --repl[=PORT] spawn REPL server on PORT")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (getaddrinfo* host) + "Like 'getaddrinfo', but properly report errors." + (catch 'getaddrinfo-error + (lambda () + (getaddrinfo host)) + (lambda (key error) + (leave (_ "lookup of host '~a' failed: ~a~%") + host (gai-strerror error))))) + +(define %options + (list (option '(#\h "help") #f #f + (lambda _ + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda _ + (show-version-and-exit "guix publish"))) + (option '(#\u "user") #t #f + (lambda (opt name arg result) + (alist-cons 'user arg result))) + (option '(#\p "port") #t #f + (lambda (opt name arg result) + (alist-cons 'port (string->number* arg) result))) + (option '("listen") #t #f + (lambda (opt name arg result) + (match (getaddrinfo* arg) + ((info _ ...) + (alist-cons 'address (addrinfo:addr info) + result)) + (() + (leave (_ "lookup of host '~a' returned nothing") + name))))) + (option '(#\r "repl") #f #t + (lambda (opt name arg result) + ;; If port unspecified, use default Guile REPL port. + (let ((port (and arg (string->number* arg)))) + (alist-cons 'repl (or port 37146) result)))))) + +(define %default-options + `((port . 8080) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) + (repl . #f))) + +(define (lazy-read-file-sexp file) + "Return a promise to read the canonical sexp from FILE." + (delay + (call-with-input-file file + (compose string->canonical-sexp + get-string-all)))) + +(define %private-key + (lazy-read-file-sexp %private-key-file)) + +(define %public-key + (lazy-read-file-sexp %public-key-file)) + +(define %nix-cache-info + `(("StoreDir" . ,%store-directory) + ("WantMassQuery" . 0) + ("Priority" . 100))) + +(define (load-derivation file) + "Read the derivation from FILE." + (call-with-input-file file read-derivation)) + +(define (signed-string s) + "Sign the hash of the string S with the daemon's key." + (let* ((public-key (force %public-key)) + (hash (bytevector->hash-data (sha256 (string->utf8 s)) + #:key-type (key-type public-key)))) + (signature-sexp hash (force %private-key) public-key))) + +(define base64-encode-string + (compose base64-encode string->utf8)) + +(define (narinfo-string store-path path-info key) + "Generate a narinfo key/value string for STORE-PATH using the details in +PATH-INFO. The narinfo is signed with KEY." + (let* ((url (string-append "nar/" (basename store-path))) + (hash (bytevector->base32-string + (path-info-hash path-info))) + (size (path-info-nar-size path-info)) + (references (string-join + (map basename (path-info-references path-info)) + " ")) + (deriver (path-info-deriver path-info)) + (base-info (format #f + "StorePath: ~a +URL: ~a +Compression: none +NarHash: sha256:~a +NarSize: ~d +References: ~a~%" + store-path url hash size references)) + ;; Do not render a "Deriver" or "System" line if we are rendering + ;; info for a derivation. + (info (if (string-null? deriver) + base-info + (let ((drv (load-derivation deriver))) + (format #f "~aSystem: ~a~%Deriver: ~a~%" + base-info (derivation-system drv) + (basename deriver))))) + (signature (base64-encode-string + (canonical-sexp->string (signed-string info))))) + (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) + +(define (not-found request) + "Render 404 response for REQUEST." + (values (build-response #:code 404) + (string-append "Resource not found: " + (uri-path (request-uri request))))) + +(define (render-nix-cache-info) + "Render server information." + (values '((content-type . (text/plain))) + (lambda (port) + (for-each (match-lambda + ((key . value) + (format port "~a: ~a~%" key value))) + %nix-cache-info)))) + +(define (render-narinfo store request hash) + "Render metadata for the store path corresponding to HASH." + (let* ((store-path (hash-part->path store hash)) + (path-info (and (not (string-null? store-path)) + (query-path-info store store-path)))) + (if path-info + (values '((content-type . (application/x-nix-narinfo))) + (cut display + (narinfo-string store-path path-info (force %private-key)) + <>)) + (not-found request)))) + +(define (render-nar request store-item) + "Render archive of the store path corresponding to STORE-ITEM." + (let ((store-path (string-append %store-directory "/" store-item))) + ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will + ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte + ;; sequences. + (if (file-exists? store-path) + (values '((content-type . (application/x-nix-archive + (charset . "ISO-8859-1")))) + (lambda (port) + (write-file store-path port))) + (not-found request)))) + +(define extract-narinfo-hash + (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$"))) + (lambda (str) + "Return the hash within the narinfo resource string STR, or false if STR +is invalid." + (and=> (regexp-exec regexp str) + (cut match:substring <> 1))))) + +(define (get-request? request) + "Return #t if REQUEST uses the GET method." + (eq? (request-method request) 'GET)) + +(define (request-path-components request) + "Split the URI path of REQUEST into a list of component strings. For +example: \"/foo/bar\" yields '(\"foo\" \"bar\")." + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (make-request-handler store) + (lambda (request body) + (format #t "~a ~a~%" + (request-method request) + (uri-path (request-uri request))) + (if (get-request? request) ; reject POST, PUT, etc. + (match (request-path-components request) + ;; /nix-cache-info + (("nix-cache-info") + (render-nix-cache-info)) + ;; /<hash>.narinfo + (((= extract-narinfo-hash (? string? hash))) + (render-narinfo store request hash)) + ;; /nar/<store-item> + (("nar" store-item) + (render-nar request store-item)) + (_ (not-found request))) + (not-found request)))) + +(define (run-publish-server socket store) + (run-server (make-request-handler store) + 'http + `(#:socket ,socket))) + +(define (open-server-socket address) + "Return a TCP socket bound to ADDRESS, a socket address." + (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock address) + sock)) + +(define (gather-user-privileges user) + "Switch to the identity of USER, a user name." + (catch 'misc-error + (lambda () + (let ((user (getpw user))) + (setgroups #()) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)))) + (lambda (key proc message args . rest) + (leave (_ "user '~a' not found: ~a~%") + user (apply format #f message args))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-publish . args) + (with-error-handling + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (user (assoc-ref opts 'user)) + (port (assoc-ref opts 'port)) + (address (let ((addr (assoc-ref opts 'address))) + (make-socket-address (sockaddr:fam addr) + (sockaddr:addr addr) + port))) + (socket (open-server-socket address)) + (repl-port (assoc-ref opts 'repl))) + ;; Read the key right away so that (1) we fail early on if we can't + ;; access them, and (2) we can then drop privileges. + (force %private-key) + (force %public-key) + + (when user + ;; Now that we've read the key material and opened the socket, we can + ;; drop privileges. + (gather-user-privileges user)) + + (when (zero? (getuid)) + (warning (_ "server running as root; \ +consider using the '--user' option!~%"))) + (format #t (_ "publishing ~a on ~a, port ~d~%") + %store-directory + (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) + (sockaddr:port address)) + (when repl-port + (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) + (with-store store + (run-publish-server socket store))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 04886499a2..28519d78e2 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; @@ -207,16 +207,13 @@ update would trigger a complete rebuild." (list-dependent? (assoc-ref opts 'list-dependent?)) (key-download (assoc-ref opts 'key-download)) (packages - (match (concatenate - (filter-map (match-lambda - (('argument . value) - (let ((p (find-packages-by-name value))) - (when (null? p) - (leave (_ "~a: no package by that name~%") - value)) - p)) + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) (_ #f)) - opts)) + opts) (() ; default to all packages (let ((select? (match (assoc-ref opts 'select) ('core core-package?) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute.scm index a4d153d4a0..8b4fa36d2a 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute.scm @@ -17,7 +17,7 @@ ;;; 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 substitute-binary) +(define-module (guix scripts substitute) #:use-module (guix ui) #:use-module (guix store) #:use-module (guix utils) @@ -28,13 +28,12 @@ #:use-module (guix base64) #:use-module (guix pk-crypto) #:use-module (guix pki) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation)) #: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 (ice-9 binary-ports) @@ -48,11 +47,13 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) #:use-module (guix http-client) #:export (narinfo-signature->canonical-sexp read-narinfo write-narinfo - guix-substitute-binary)) + guix-substitute)) ;;; Comment: ;;; @@ -68,8 +69,8 @@ (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"))) + (cut string-append <> "/guix/substitute")) + (string-append %state-directory "/substitute/cache"))) (define %allow-unauthenticated-substitutes? ;; Whether to allow unchecked substitutes. This is useful for testing @@ -83,8 +84,10 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. - (* 24 3600)) + ;; valid. This is a reasonable default value (corresponds to the TTL for + ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to + ;; state what their TTL is in /nix-cache-info. (XXX) + (* 36 3600)) (define %narinfo-negative-ttl ;; Likewise, but for negative lookups---i.e., cached lookup failures. @@ -94,15 +97,6 @@ disabled!~%")) ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) -;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it. -;; See <http://bugs.gnu.org/14404>. -(set! regexp-exec - (let ((real regexp-exec) - (lock (make-mutex))) - (lambda (rx str . rest) - (with-mutex lock - (apply real rx str rest))))) - (define fields->alist ;; The narinfo format is really just like recutils. recutils->alist) @@ -163,15 +157,12 @@ to the caller without emitting an error message." (leave (_ "download from '~a' failed: ~a, ~s~%") (uri->string (http-get-error-uri c)) code (http-get-error-reason c)))))) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + (with-timeout (if timeout? %fetch-timeout 0) (begin @@ -188,7 +179,9 @@ to the caller without emitting an error message." (close-port port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (set! port (open-socket-for-uri uri)) + (unless buffered? + (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port)))))))) (define-record-type <cache> @@ -218,7 +211,7 @@ failure." gonna have to wait." (delay (begin (format (current-error-port) - (_ "updating list of substitutes from '~a'...~%") + (_ "updating list of substitutes from '~a'...\r") url) (open-cache url)))) @@ -309,12 +302,16 @@ NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." (corrupt-signature (leave (_ "signature on '~a' is corrupt~%") uri))))) -(define* (read-narinfo port #:optional url) +(define* (read-narinfo port #:optional url + #:key size) "Read a narinfo from PORT. If URL is true, it must be a string used to -build full URIs from relative URIs found while reading PORT. +build full URIs from relative URIs found while reading PORT. When SIZE is +true, read at most SIZE bytes from PORT; otherwise, read as much as possible. No authentication and authorization checks are performed here!" - (let ((str (utf8->string (get-bytevector-all port)))) + (let ((str (utf8->string (if size + (get-bytevector-n port size) + (get-bytevector-all port))))) (alist->record (call-with-input-string str fields->alist) (narinfo-maker str url) '("StorePath" "URL" "Compression" @@ -376,40 +373,56 @@ or is signed by an unauthorized key." the cache STR originates form." (call-with-input-string str (cut read-narinfo <> cache-uri))) -(define (fetch-narinfo cache path) - "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH." - (define (download url) - ;; Download the .narinfo from URL, and return its contents as a list of - ;; key/value pairs. Don't emit an error message upon 404. - (false-if-exception (fetch (string->uri url) - #:quiet-404? #t))) - - (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-threads - ;; Number of threads spawned to perform lookup operations. This means we - ;; can have this many simultaneous HTTP GET requests to the server, which - ;; limits the impact of connection latency. - 20) -(define (lookup-narinfo cache path) - "Check locally if we have valid info about PATH, otherwise go to CACHE and -check what it has." +(define (narinfo-cache-file path) + "Return the name of the local file that contains an entry for PATH." + (string-append %narinfo-cache-directory "/" + (store-path-hash-part path))) + +(define (cached-narinfo path) + "Check locally if we have valid info about PATH. Return two values: a +Boolean indicating whether we have valid cached info, and that info, which may +be either #f (when PATH is unavailable) or the narinfo for PATH." (define now (current-time time-monotonic)) (define cache-file - (string-append %narinfo-cache-directory "/" - (store-path-hash-part path))) + (narinfo-cache-file path)) + + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date now %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value value)) + ;; A cached positive lookup + (if (obsolete? date now %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value cache-uri)))) + (('narinfo ('version v) _ ...) + (values #f #f)))))) + (lambda _ + (values #f #f)))) + +(define (cache-narinfo! cache path narinfo) + "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may +be #f, in which case it indicates that PATH is unavailable at CACHE." + (define now + (current-time time-monotonic)) (define (cache-entry cache-uri narinfo) `(narinfo (version 1) @@ -417,43 +430,154 @@ check what it has." (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 1) - ('cache-uri cache-uri) - ('date date) ('value #f)) - ;; A cached negative lookup. - (if (obsolete? date now %narinfo-negative-ttl) - (values #f #f) - (values #t #f))) - (('narinfo ('version 1) - ('cache-uri cache-uri) - ('date date) ('value value)) - ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) - (values #f #f) - (values #t (string->narinfo value - cache-uri)))) - (('narinfo ('version v) _ ...) - (values #f #f)))))) - (lambda _ - (values #f #f))))) - (if valid? - cached ; including negative caches + (with-atomic-file-output (narinfo-cache-file path) + (lambda (out) + (write (cache-entry (cache-url cache) narinfo) out))) + narinfo) + +(define (narinfo-request cache-url path) + "Return an HTTP request for the narinfo of PATH at CACHE-URL." + (let ((url (string-append cache-url "/" (store-path-hash-part path) + ".narinfo"))) + (build-request (string->uri url) #:method 'GET))) + +(define (http-multiple-get base-url requests proc) + "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +response, passing it the request object, the response, and a port from which +to read the response body. Return the list of results." + (let connect ((requests requests) + (result '())) + ;; (format (current-error-port) "connecting (~a requests left)..." + ;; (length requests)) + (let ((p (open-socket-for-uri base-url))) + ;; Send all of REQUESTS in a row. + (setvbuf p _IOFBF (expt 2 16)) + (for-each (cut write-request <> p) requests) + (force-output p) + + ;; Now start processing responses. + (let loop ((requests requests) + (result result)) + (match requests + (() + (reverse result)) + ((head tail ...) + (let* ((resp (read-response p)) + (body (response-body-port resp))) + ;; The server can choose to stop responding at any time, in which + ;; case we have to try again. Check whether that is the case. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (close-port p) + (connect requests result)) ;try again + (_ + (loop tail ;keep going + (cons (proc head resp body) result))))))))))) + +(define (read-to-eof port) + "Read from PORT until EOF is reached. The data are discarded." + (dump-port port (%make-void-port "w"))) + +(define (narinfo-from-file file url) + "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f +if file doesn't exist, and the narinfo otherwise." + (catch 'system-error + (lambda () + (call-with-input-file file + (cut read-narinfo <> url))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (fetch-narinfos cache paths) + "Retrieve all the narinfos for PATHS from CACHE and return them." + (define url + (cache-url cache)) + + (define update-progress! + (let ((done 0)) + (lambda () + (display #\cr (current-error-port)) + (force-output (current-error-port)) + (format (current-error-port) + (_ "updating list of substitutes from '~a'... ~5,1f%") + url (* 100. (/ done (length paths)))) + (set! done (+ 1 done))))) + + (define (handle-narinfo-response request response port) + (let ((len (response-content-length response))) + ;; Make sure to read no more than LEN bytes since subsequent bytes may + ;; belong to the next response. + (case (response-code response) + ((200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (cache-narinfo! cache (narinfo-path narinfo) narinfo) + (update-progress!) + narinfo)) + ((404) ; failure + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! cache + (find (cut string-contains <> hash-part) paths) + #f) + (update-progress!)) + #f) + (else ; transient failure + (if len + (get-bytevector-n port len) + (read-to-eof port)) + #f)))) + + (and (string=? (cache-store-directory cache) (%store-prefix)) + (let ((uri (string->uri url))) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url requests + handle-narinfo-response))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))))) + +(define (lookup-narinfos cache paths) + "Return the narinfos for PATHS, invoking the server at CACHE when no +information is available locally." + (let-values (((cached missing) + (fold2 (lambda (path cached missing) + (let-values (((valid? value) + (cached-narinfo path))) + (if valid? + (values (cons value cached) missing) + (values cached (cons path missing))))) + '() + '() + paths))) + (if (null? missing) + cached (let* ((cache (force cache)) - (narinfo (and cache (fetch-narinfo cache path)))) - ;; Cache NARINFO only when CACHE was actually accessible. This - ;; avoids caching negative hits when in fact we just lacked network - ;; access. - (when cache - (with-atomic-file-output cache-file - (lambda (out) - (write (cache-entry (cache-url cache) narinfo) out)))) - narinfo)))) + (missing (if cache + (fetch-narinfos cache missing) + '()))) + (append cached missing))))) + +(define (lookup-narinfo cache path) + "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was +found." + (match (lookup-narinfos cache (list path)) + ((answer) answer))) (define (remove-expired-cached-narinfos) "Remove expired narinfo entries from the cache. The sole purpose of this @@ -522,17 +646,9 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;; XXX: We're not in control, so we always return anyway. n)) - ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done, - ;; don't pretend to report any progress in that case. - (if (guile-version>? "2.0.5") - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-port port)) - (begin - (format (current-error-port) (_ "Downloading, please wait...~%")) - (format (current-error-port) - (_ "(Please consider upgrading Guile to get proper progress report.)~%")) - port))) + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) (define-syntax with-networking (syntax-rules () @@ -553,7 +669,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; (define (show-help) - (display (_ "Usage: guix substitute-binary [OPTION]... + (display (_ "Usage: guix substitute [OPTION]... Internal tool to substitute a pre-built binary to a local build.\n")) (display (_ " --query report on the availability of substitutes for the @@ -576,16 +692,6 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; Entry point. ;;; -(define n-par-map* - ;; We want the ability to run many threads in parallel, regardless of the - ;; number of cores. However, Guile 2.0.5 has a bug whereby 'n-par-map' ends - ;; up consuming a lot of memory, possibly leading to death. Thus, resort to - ;; 'par-map' on 2.0.5. - (if (guile-version>? "2.0.5") - n-par-map - (lambda (n proc lst) - (par-map proc lst)))) - (define (check-acl-initialized) "Warn if the ACL is uninitialized." (define (singleton? acl) @@ -649,7 +755,7 @@ found." ;; daemon. "http://hydra.gnu.org"))) -(define (guix-substitute-binary . args) +(define (guix-substitute . args) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) (maybe-remove-expired-cached-narinfo) @@ -694,9 +800,7 @@ substituter disabled~%") ;; Return the subset of PATHS available in CACHE. (let ((substitutable (if cache - (n-par-map* %lookup-threads - (cut lookup-narinfo cache <>) - paths) + (lookup-narinfos cache paths) '()))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) @@ -706,9 +810,7 @@ substituter disabled~%") ;; Reply info about PATHS if it's in CACHE. (let ((substitutable (if cache - (n-par-map* %lookup-threads - (cut lookup-narinfo cache <>) - paths) + (lookup-narinfos cache paths) '()))) (for-each (lambda (narinfo) (format #t "~a\n~a\n~a\n" @@ -774,7 +876,7 @@ substituter disabled~%") (every (compose zero? cdr waitpid) pids)))) (("--version") - (show-version-and-exit "guix substitute-binary")) + (show-version-and-exit "guix substitute")) (("--help") (show-help)) (opts @@ -785,4 +887,4 @@ substituter disabled~%") ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: -;;; substitute-binary.scm ends here +;;; substitute.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1b64e6fb92..8d5fbe5a78 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -48,42 +48,14 @@ (define %user-module ;; Module in which the machine description file is loaded. - (let ((module (make-fresh-user-module))) - (for-each (lambda (iface) - (module-use! module (resolve-interface iface))) - '((gnu system) - (gnu services) - (gnu system shadow))) - module)) + (make-user-module '((gnu system) + (gnu services) + (gnu system shadow)))) (define (read-operating-system file) "Read the operating-system declaration from FILE and return it." - ;; TODO: Factorize. - (catch #t - (lambda () - ;; Avoid ABI incompatibility with the <operating-system> record. - (set! %fresh-auto-compile #t) + (load* file %user-module)) - (save-module-excursion - (lambda () - (set-current-module %user-module) - (primitive-load file)))) - (lambda args - (match args - (('system-error . _) - (let ((err (system-error-errno args))) - (leave (_ "failed to open operating system file '~a': ~a~%") - file (strerror err)))) - (('syntax-error proc message properties form . rest) - (let ((loc (source-properties->location properties))) - (format (current-error-port) (_ "~a: error: ~a~%") - (location->string loc) message) - (exit 1))) - ((error args ...) - (report-error (_ "failed to load operating system file '~a':~%") - file) - (apply display-error #f (current-error-port) args) - (exit 1)))))) ;;; @@ -95,8 +67,6 @@ (store-lift references)) (define topologically-sorted* (store-lift topologically-sorted)) -(define show-what-to-build* - (store-lift show-what-to-build)) (define* (copy-item item target |