diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/environment.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 35 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 43 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 8 |
6 files changed, 109 insertions, 37 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0abc509a35..95ba199d97 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -313,9 +313,7 @@ in OPTS." #:dry-run? dry-run?) (if dry-run? (return #f) - (mbegin %store-monad - (set-build-options-from-command-line* opts) - (built-derivations derivations)))))) + (built-derivations derivations))))) (define (inputs->profile-derivation inputs system bootstrap?) "Return the derivation for a profile consisting of INPUTS for SYSTEM. @@ -580,6 +578,8 @@ message if any test fails." (when container? (assert-container-features)) (with-store store + (set-build-options-from-command-line store opts) + ;; Use the bootstrap Guile when requested. (parameterize ((%graft? (assoc-ref opts 'graft?)) (%guile-for-build @@ -588,7 +588,6 @@ message if any test fails." (if bootstrap? %bootstrap-guile (canonical-package guile-2.0))))) - (set-build-options-from-command-line store opts) (run-with-store store ;; Containers need a Bourne shell at /bin/sh. (mlet* %store-monad ((bash (environment-bash container? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 58da3113a0..8da7a3fd3a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -84,12 +84,16 @@ "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if '-p' was omitted." ; see <http://bugs.gnu.org/17939> - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile)) + + ;; Trim trailing slashes so that the basename comparison below works as + ;; intended. + (let ((profile (string-trim-right profile #\/))) + (if (and %user-profile-directory + (string=? (canonicalize-path (dirname profile)) + (dirname %user-profile-directory)) + (string=? (basename profile) (basename %user-profile-directory))) + %current-profile + profile))) (define (user-friendly-profile profile) "Return either ~/.guix-profile if that's what PROFILE refers to, directly or @@ -709,9 +713,12 @@ processed, #f otherwise." (raise (condition (&profile-not-found-error (profile profile))))) ((string-null? pattern) - (list-generation display-profile-content - (car (profile-generations profile))) - (diff-profiles profile (profile-generations profile))) + (match (profile-generations profile) + (() + #t) + ((first rest ...) + (list-generation display-profile-content first) + (diff-profiles profile (cons first rest))))) ((matching-generations pattern profile) => (lambda (numbers) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a7e3e6d629..ade3c49a54 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -385,6 +385,24 @@ at a time." (string-suffix? ".narinfo" file))) '())) +(define (nar-expiration-time ttl) + "Return the narinfo expiration time (in seconds since the Epoch). The +expiration time is +inf.0 when passed an item that is still in the store; in +other cases, it is the last-access time of the item plus TTL. + +This policy allows us to keep cached nars that correspond to valid store +items. Failing that, we could eventually have to recompute them and return +404 in the meantime." + (let ((expiration-time (file-expiration-time ttl))) + (lambda (file) + (let ((item (string-append (%store-prefix) "/" + (basename file ".narinfo")))) + ;; Note: We don't need to use 'valid-path?' here because FILE would + ;; not exist if ITEM were not valid in the first place. + (if (file-exists? item) + +inf.0 + (expiration-time file)))))) + (define* (render-narinfo/cached store request hash #:key ttl (compression %no-compression) (nar-path "nar") @@ -417,7 +435,8 @@ requested using POOL." (display (call-with-input-file cached read-string) port)))) - ((valid-path? store item) + ((and (file-exists? item) ;cheaper than the 'valid-path?' RPC + (valid-path? store item)) ;; Nothing in cache: bake the narinfo and nar in the background and ;; return 404. (eventually pool @@ -435,7 +454,7 @@ requested using POOL." (maybe-remove-expired-cache-entries cache narinfo-files #:entry-expiration - (file-expiration-time ttl) + (nar-expiration-time ttl) #:delete-entry delete-entry #:cleanup-period ttl)))) (not-found request @@ -565,13 +584,13 @@ has the given HASH of type ALGO." " speaking. Welcome!"))) port))))) -(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 +(define (extract-narinfo-hash 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))))) + (and (string-suffix? ".narinfo" str) + (let ((base (string-drop-right str 8))) + (and (string-every %nix-base32-charset base) + base)))) (define (get-request? request) "Return #t if REQUEST uses the GET method." diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 52f7cdd972..1e54d3f218 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -77,8 +77,22 @@ if ITEM is not in the store." (leave (G_ "no available substitute information for '~a'~%") item))))))) -(define* (display-profile profile #:optional (port (current-output-port))) - "Display PROFILE, a list of PROFILE objects, to PORT." +(define profile-closure<? + (match-lambda* + ((($ <profile> name1 self1 total1) + ($ <profile> name2 self2 total2)) + (< total1 total2)))) + +(define profile-self<? + (match-lambda* + ((($ <profile> name1 self1 total1) + ($ <profile> name2 self2 total2)) + (< self1 self2)))) + +(define* (display-profile profile #:optional (port (current-output-port)) + #:key (profile<? profile-closure<?)) + "Display PROFILE, a list of PROFILE objects, to PORT. Sort entries +according to PROFILE<?." (define MiB (expt 2 20)) (format port "~64a ~8a ~a\n" @@ -89,11 +103,7 @@ if ITEM is not in the store." (format port "~64a ~6,1f ~6,1f ~5,1f%\n" name (/ total MiB) (/ self MiB) (* 100. (/ self whole 1.))))) - (sort profile - (match-lambda* - ((($ <profile> name1 self1 total1) - ($ <profile> name2 self2 total2)) - (> total1 total2))))) + (sort profile (negate profile<?))) (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) (define display-profile* @@ -224,6 +234,9 @@ Report the size of PACKAGE and its dependencies.\n")) fetch substitute from URLS if they are authorized")) (display (G_ " -s, --system=SYSTEM consider packages for SYSTEM--e.g., \"i686-linux\"")) + ;; TRANSLATORS: "closure" and "self" must not be translated. + (display (G_ " + --sort=KEY sort according to KEY--\"closure\" or \"self\"")) (display (G_ " -m, --map-file=FILE write to FILE a graphical map of disk usage")) (newline) @@ -247,6 +260,15 @@ Report the size of PACKAGE and its dependencies.\n")) (string-tokenize arg) (alist-delete 'substitute-urls result)) rest))) + (option '("sort") #t #f + (lambda (opt name arg result . rest) + (match arg + ("closure" + (alist-cons 'profile<? profile-closure<? result)) + ("self" + (alist-cons 'profile<? profile-self<? result)) + (_ + (leave (G_ "~a: invalid sorting key~%") arg))))) (option '(#\m "map-file") #t #f (lambda (opt name arg result) (alist-cons 'map-file arg result))) @@ -259,7 +281,8 @@ Report the size of PACKAGE and its dependencies.\n")) (show-version-and-exit "guix size"))))) (define %default-options - `((system . ,(%current-system)))) + `((system . ,(%current-system)) + (profile<? . ,profile-closure<?))) ;;; @@ -273,6 +296,7 @@ Report the size of PACKAGE and its dependencies.\n")) (('argument . file) file) (_ #f)) opts)) + (profile<? (assoc-ref opts 'profile<?)) (map-file (assoc-ref opts 'map-file)) (system (assoc-ref opts 'system)) (urls (assoc-ref opts 'substitute-urls))) @@ -298,5 +322,6 @@ Report the size of PACKAGE and its dependencies.\n")) (begin (profile->page-map profile map-file) (return #t)) - (display-profile* profile))) + (display-profile* profile (current-output-port) + #:profile<? profile<?))) #:system system))))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 71f30030b6..35282f9027 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -47,6 +47,7 @@ #:use-module (ice-9 format) #:use-module (ice-9 ftw) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 vlist) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -96,6 +97,13 @@ ;;; ;;; Code: +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (define %narinfo-cache-directory ;; A local cache of narinfos, to avoid going to the network. Most of the ;; time, 'guix substitute' is called by guix-daemon as root and stores its @@ -593,15 +601,27 @@ if file doesn't exist, and the narinfo otherwise." (define (fetch-narinfos url paths) "Retrieve all the narinfos for PATHS from the cache at URL and return them." (define update-progress! - (let ((done 0)) + (let ((done 0) + (total (length paths))) (lambda () (display #\cr (current-error-port)) (force-output (current-error-port)) (format (current-error-port) (G_ "updating list of substitutes from '~a'... ~5,1f%") - url (* 100. (/ done (length paths)))) + url (* 100. (/ done total))) (set! done (+ 1 done))))) + (define hash-part->path + (let ((mapping (fold (lambda (path result) + (vhash-cons (store-path-hash-part path) path + result)) + vlist-null + paths))) + (lambda (hash) + (match (vhash-assoc hash mapping) + (#f #f) + ((_ . path) path))))) + (define (handle-narinfo-response request response port result) (let* ((code (response-code response)) (len (response-content-length response)) @@ -620,9 +640,7 @@ if file doesn't exist, and the narinfo otherwise." (if len (get-bytevector-n port len) (read-to-eof port)) - (cache-narinfo! url - (find (cut string-contains <> hash-part) paths) - #f + (cache-narinfo! url (hash-part->path hash-part) #f (if (= 404 code) ttl %narinfo-transient-error-ttl)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65dd92e8b7..0fcb6a9b0f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -579,8 +579,12 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) - (system-disk-image os #:disk-image-size image-size - #:file-system-type file-system-type)))) + (system-disk-image os + #:name (match file-system-type + ("iso9660" "image.iso") + (_ "disk-image")) + #:disk-image-size image-size + #:file-system-type file-system-type)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." |