diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/environment.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 117 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 36 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 6 |
7 files changed, 97 insertions, 84 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 9ba487d1eb..ebe966f9cf 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -333,11 +333,11 @@ requisite store items i.e. the union closure of all the inputs." (requisites* (match input ((drv output) - (derivation->output-path drv output)) + (list (derivation->output-path drv output))) ((drv) - (derivation->output-path drv)) + (list (derivation->output-path drv))) ((? direct-store-path? path) - path)))) + (list path))))) (mlet %store-monad ((reqs (sequence %store-monad (map input->requisites inputs)))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 4ec9ff9dca..8db28138c8 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -229,7 +229,8 @@ Invoke the garbage collector.\n")) ((list-references) (list-relatives references)) ((list-requisites) - (list-relatives requisites)) + (list-relatives (lambda (store item) + (requisites store (list item))))) ((list-referrers) (list-relatives referrers)) ((optimize) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index d594be18e5..7db0c9d610 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (guix serialization) #:use-module (guix nar) #:use-module (guix utils) + #:use-module ((guix build syscalls) #:select (fcntl-flock)) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) #:use-module (srfi srfi-1) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 697afc17c3..e2e37098fc 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -794,9 +794,13 @@ processed, #f otherwise." (define transform (options->transformation opts)) (define (transform-entry entry) - (manifest-entry - (inherit entry) - (item (transform store (manifest-entry-item entry))))) + (let ((item (transform store (manifest-entry-item entry)))) + (manifest-entry + (inherit entry) + (item item) + (version (if (package? item) + (package-version item) + (manifest-entry-version entry)))))) ;; First, process roll-backs, generation removals, etc. (for-each (match-lambda diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 0efc190b22..209f0d8be9 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -258,38 +258,36 @@ downloaded and authenticated; not updating~%") (define (list-dependents packages) "List all the things that would need to be rebuilt if PACKAGES are changed." - (with-store store - (run-with-store store - ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE - ;; because it includes implicit dependencies. - (mlet %store-monad ((edges (node-back-edges %bag-node-type - (all-packages)))) - (let* ((dependents (node-transitive-edges packages edges)) - (covering (filter (lambda (node) - (null? (edges node))) - dependents))) - (match dependents - (() - (format (current-output-port) - (N_ "No dependents other than itself: ~{~a~}~%" - "No dependents other than themselves: ~{~a~^ ~}~%" - (length packages)) - (map package-full-name packages))) + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (mlet %store-monad ((edges (node-back-edges %bag-node-type + (all-packages)))) + (let* ((dependents (node-transitive-edges packages edges)) + (covering (filter (lambda (node) + (null? (edges node))) + dependents))) + (match dependents + (() + (format (current-output-port) + (N_ "No dependents other than itself: ~{~a~}~%" + "No dependents other than themselves: ~{~a~^ ~}~%" + (length packages)) + (map package-full-name packages))) - ((x) - (format (current-output-port) - (_ "A single dependent package: ~a~%") - (package-full-name x))) - (lst - (format (current-output-port) - (N_ "Building the following package would ensure ~d \ + ((x) + (format (current-output-port) + (_ "A single dependent package: ~a~%") + (package-full-name x))) + (lst + (format (current-output-port) + (N_ "Building the following package would ensure ~d \ dependent packages are rebuilt: ~*~{~a~^ ~}~%" - "Building the following ~d packages would ensure ~d \ + "Building the following ~d packages would ensure ~d \ dependent packages are rebuilt: ~{~a~^ ~}~%" - (length covering)) - (length covering) (length dependents) - (map package-full-name covering)))) - (return #t)))))) + (length covering)) + (length covering) (length dependents) + (map package-full-name covering)))) + (return #t)))) ;;; @@ -381,31 +379,36 @@ update would trigger a complete rebuild." (some ; user-specified packages some)))) (with-error-handling - (cond - (list-dependent? - (list-dependents packages)) - (update? - (let ((store (open-connection))) - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command)))) - (for-each - (cut update-package store <> updaters - #:key-download key-download) - packages)))) - (else - (for-each (lambda (package) - (match (package-update-path package updaters) - ((? upstream-source? source) - (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) - (upstream-source-version source)))) - (#f #f))) - packages)))))) + (with-store store + (run-with-store store + (cond + (list-dependent? + (list-dependents packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command)))) + (for-each + (cut update-package store <> updaters + #:key-download key-download) + packages) + (with-monad %store-monad + (return #t)))) + (else + (for-each (lambda (package) + (match (package-update-path package updaters) + ((? upstream-source? source) + (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) + (upstream-source-version source)))) + (#f #f))) + packages) + (with-monad %store-monad + (return #t))))))))) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index be1e8ca087..f28832ce90 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -91,15 +91,16 @@ if ITEM is not in the store." (sort profile (match-lambda* ((($ <profile> _ _ total1) ($ <profile> _ _ total2)) - (> total1 total2))))))) + (> total1 total2))))) + (format port (_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) (define display-profile* (lift display-profile %store-monad)) -(define (substitutable-requisites store item) - "Return the list of requisites of ITEM based on information available in +(define (substitutable-requisites store items) + "Return the list of requisites of ITEMS based on information available in substitutes." - (let loop ((items (list item)) + (let loop ((items items) (result '())) (match items (() @@ -113,23 +114,23 @@ substitutes." (append (append-map substitutable-references info) result))))))) -(define (requisites* item) +(define (requisites* items) "Return as a monadic value the requisites of ITEMS, based either on the information available in the local store or using information about substitutes." (lambda (store) (guard (c ((nix-protocol-error? c) - (values (substitutable-requisites store item) + (values (substitutable-requisites store items) store))) - (values (requisites store item) store)))) + (values (requisites store items) store)))) -(define (store-profile item) +(define (store-profile items) "Return as a monadic value a list of <profile> objects representing the -profile of ITEM and its requisites." - (mlet* %store-monad ((refs (>>= (requisites* item) +profile of ITEMS and their requisites." + (mlet* %store-monad ((refs (>>= (requisites* items) (lambda (refs) (return (delete-duplicates - (cons item refs)))))) + (append items refs)))))) (sizes (mapm %store-monad (lambda (item) (>>= (file-size item) @@ -137,7 +138,7 @@ profile of ITEM and its requisites." (return (cons item size))))) refs))) (define (dependency-size item) - (mlet %store-monad ((deps (requisites* item))) + (mlet %store-monad ((deps (requisites* (list item)))) (foldm %store-monad (lambda (item total) (return (+ (assoc-ref sizes item) total))) @@ -273,7 +274,7 @@ Report the size of PACKAGE and its dependencies.\n")) (match files (() (leave (_ "missing store item argument\n"))) - ((file) + ((files ..1) (leave-on-EPIPE ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted ;; packages, and (2) they do not make any difference on the @@ -285,13 +286,12 @@ Report the size of PACKAGE and its dependencies.\n")) #:substitute-urls urls) (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (profile (store-profile items))) (if map-file (begin (profile->page-map profile map-file) (return #t)) (display-profile* profile))) - #:system system))))) - ((files ...) - (leave (_ "too many arguments\n"))))))) + #:system system))))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5cdc55f2b2..81ce770dc5 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -889,7 +889,11 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) - (format (current-error-port) "Downloading ~a~:[~*~; (~a installed)~]...~%" + (format (current-error-port) + ;; TRANSLATORS: The second part of this message looks like + ;; "(4.1MiB installed)"; it shows the size of the package once + ;; installed. + (_ "Downloading ~a~:[~*~; (~a installed)~]...~%") (store-path-abbreviation store-item) ;; Use the Nar size as an estimate of the installed size. (narinfo-size narinfo) |