diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 27 | ||||
| -rw-r--r-- | guix/scripts/import/gnu.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/import/nix.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 139 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 2 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 9 |
9 files changed, 131 insertions, 76 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 86b95b4075..b64138ec0e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -195,7 +195,7 @@ of \"guile\"." ((old new) (cons (specification->package old) (specification->package new))) - (_ + (x (leave (_ "invalid replacement specification: ~s~%") spec)))) replacement-specs)) @@ -595,8 +595,16 @@ build." (#f (list (package->derivation store p system))) (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) + (match (package-source p) + (#f + (format (current-error-port) + (_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) (proc (map (cut package-source-derivation store <>) (proc p)))))) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index d44095377b..a6eced92fb 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,6 +50,8 @@ 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 (_ " + -x, --exclude-vcs exclude version control directories")) + (format #t (_ " -f, --format=FMT write the hash in the given format")) (format #t (_ " -r, --recursive compute the hash on FILE recursively")) @@ -62,7 +65,10 @@ and 'hexadecimal' can be used as well).\n")) (define %options ;; Specification of the command-line options. - (list (option '(#\f "format") #t #f + (list (option '(#\x "exclude-vcs") #f #f + (lambda (opt name arg result) + (alist-cons 'exclude-vcs? #t result))) + (option '(#\f "format") #t #f (lambda (opt name arg result) (define fmt-proc (match arg @@ -81,7 +87,6 @@ and 'hexadecimal' can be used as well).\n")) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive? #t result))) - (option '(#\h "help") #f #f (lambda args (show-help) @@ -107,13 +112,23 @@ and 'hexadecimal' can be used as well).\n")) (alist-cons 'argument arg result)) %default-options)) + (define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + (else + #f))) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) value) (_ #f)) (reverse opts))) - (fmt (assq-ref opts 'format))) + (fmt (assq-ref opts 'format)) + (select? (if (assq-ref opts 'exclude-vcs?) + (negate vcs-file?) + (const #t)))) (define (file-hash file) ;; Compute the hash of FILE. @@ -121,7 +136,7 @@ and 'hexadecimal' can be used as well).\n")) (with-error-handling (if (assoc-ref opts 'recursive?) (let-values (((port get-hash) (open-sha256-port))) - (write-file file port) + (write-file file port #:select? select?) (flush-output-port port) (get-hash)) (call-with-input-file file port-sha256)))) @@ -134,5 +149,5 @@ and 'hexadecimal' can be used as well).\n")) (lambda args (leave (_ "~a~%") (strerror (system-error-errno args)))))) - (_ + (x (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import/gnu.scm b/guix/scripts/import/gnu.scm index 92bd8305ea..66861f5837 100644 --- a/guix/scripts/import/gnu.scm +++ b/guix/scripts/import/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,7 +68,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) ((or "interactive" "always" "never") (alist-cons 'key-download (string->symbol arg) result)) - (_ + (x (leave (_ "unsupported policy: ~a~%") arg))))) %standard-import-options)) @@ -99,7 +99,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (with-error-handling (gnu->guix-package name #:key-download (assoc-ref opts 'key-download)))) - (_ + (x (leave (_ "wrong number of arguments~%")))))) ;;; gnu.scm ends here diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm index dba053b313..05e6e4b85d 100644 --- a/guix/scripts/import/nix.scm +++ b/guix/scripts/import/nix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -86,5 +86,5 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (format #t ";; converted from ~a:~a~%~%" (location-file loc) (location-line loc)) expr)) - (_ + (x (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 7db0c9d610..b278f1e313 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -118,7 +118,7 @@ determined." (primitive-load file)))) (lambda args (match args - (('system-error . _) + (('system-error . rest) (let ((err (system-error-errno args))) ;; Silently ignore missing file since this is a common case. (if (= ENOENT err) @@ -129,7 +129,7 @@ determined." (let ((loc (source-properties->location properties))) (leave (_ "~a: ~a~%") (location->string loc) message))) - (_ + (x (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fd42cdb36e..b87aee0be9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -261,19 +261,46 @@ synopsis or description matches all of REGEXPS." ((<) #t) (else #f))))) -(define (upgradeable? name current-version current-path) - "Return #t if there's a version of package NAME newer than CURRENT-VERSION, -or if the newest available version is equal to CURRENT-VERSION but would have -an output path different than CURRENT-PATH." - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (case (version-compare candidate-version current-version) - ((>) #t) - ((<) #f) - ((=) (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - (not (string=? current-path candidate-path)))))) - (#f #f))) +(define (transaction-upgrade-entry entry transaction) + "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a +<manifest-entry>." + (define (supersede old new) + (info (_ "package '~a' has been superseded by '~a'~%") + (manifest-entry-name old) (package-name new)) + (manifest-transaction-install-entry + (package->manifest-entry new (manifest-entry-output old)) + (manifest-transaction-remove-pattern + (manifest-pattern + (name (manifest-entry-name old)) + (version (manifest-entry-version old)) + (output (manifest-entry-output old))) + transaction))) + + (match entry + (($ <manifest-entry> name version output (? string? path)) + (match (vhash-assoc name (find-newest-available-packages)) + ((_ candidate-version pkg . rest) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))))) + (#f + transaction))))) ;;; @@ -553,24 +580,20 @@ upgrading, #f otherwise." (output #f) (item item)))) -(define (options->installable opts manifest) +(define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." +return an variant of TRANSACTION that accounts for the specified installations +and upgrades." (define upgrade? (options->upgrade-predicate opts)) - (define to-upgrade - (filter-map (match-lambda - (($ <manifest-entry> name version output path _) - (and (upgrade? name) - (upgradeable? name version path) - (let ((output (or output "out"))) - (call-with-values - (lambda () - (specification->package+output name output)) - package->manifest-entry)))) - (_ #f)) - (manifest-entries manifest))) + (define upgraded + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -587,23 +610,29 @@ return the new list of manifest entries." (_ #f)) opts)) - (append to-upgrade to-install)) - -(define (options->removable options manifest) - "Given options, return the list of manifest patterns of packages to be -removed from MANIFEST." - (filter-map (match-lambda - (('remove . spec) - (call-with-values - (lambda () - (package-specification->name+version+output spec)) - (lambda (name version output) - (manifest-pattern - (name name) - (version version) - (output output))))) - (_ #f)) - options)) + (fold manifest-transaction-install-entry + upgraded + to-install)) + +(define (options->removable options manifest transaction) + "Given options, return a variant of TRANSACTION augmented with the list of +patterns of packages to remove." + (fold (lambda (opt transaction) + (match opt + (('remove . spec) + (call-with-values + (lambda () + (package-specification->name+version+output spec)) + (lambda (name version output) + (manifest-transaction-remove-pattern + (manifest-pattern + (name name) + (version version) + (output output)) + transaction)))) + (_ transaction))) + transaction + options)) (define (register-gc-root store profile) "Register PROFILE, a profile generation symlink, as a GC root, unless it @@ -814,16 +843,18 @@ processed, #f otherwise." opts) ;; Then, process normal package installation/removal/upgrade. - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction - (install (map transform-entry install)) - (remove remove))) - (new (manifest-perform-transaction manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction store manifest transaction + (let* ((manifest (profile-manifest profile)) + (step1 (options->installable opts manifest + (manifest-transaction))) + (step2 (options->removable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) (build-and-use-profile store profile new #:bootstrap? bootstrap? diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b00ac98c96..84e2a8f2a6 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -105,7 +105,7 @@ ((or "interactive" "always" "never") (alist-cons 'key-download (string->symbol arg) result)) - (_ + (x (leave (_ "unsupported policy: ~a~%") arg))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8827c45fb8..21e0613a8a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -300,7 +300,7 @@ Otherwise return #f." (define (narinfo-signature->canonical-sexp str) "Return the value of a narinfo's 'Signature' field as a canonical sexp." (match (string-split str #\;) - ((version _ sig) + ((version host-name sig) (let ((maybe-number (string->number version))) (cond ((not (number? maybe-number)) (leave (_ "signature version must be a number: ~s~%") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 953c6243ed..a2cd97ac1f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -383,7 +383,8 @@ it atomically, and then run OS's activation script." (uuid->string root) root)) (kernel (boot-parameters-kernel params)) - (kernel-arguments (boot-parameters-kernel-arguments params))) + (kernel-arguments (boot-parameters-kernel-arguments params)) + (initrd (boot-parameters-initrd params))) (menu-entry (label (string-append label " (#" (number->string number) ", " @@ -391,10 +392,10 @@ it atomically, and then run OS's activation script." (linux kernel) (linux-arguments (cons* (string-append "--root=" root-device) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system "/boot") + (string-append "--system=" system) + (string-append "--load=" system "/boot") kernel-arguments)) - (initrd #~(string-append #$system "/initrd")))))) + (initrd initrd))))) (let* ((numbers (generation-numbers profile)) (systems (map (cut generation-file-name profile <>) |