diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 85 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 106 |
7 files changed, 133 insertions, 105 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0d69218338..e1b7feecfa 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -586,7 +586,7 @@ message if any test fails." store (if bootstrap? %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (run-with-store store ;; Containers need a Bourne shell at /bin/sh. (mlet* %store-monad ((bash (environment-bash container? diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8840b1acb5..1b43b0a63c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -587,24 +587,49 @@ from ~a") (package-home-page package)) 'home-page))))) +(define %distro-directory + (dirname (search-path %load-path "gnu.scm"))) + (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))) + (define patches + (or (and=> (package-source package) origin-patches) + '())) + (unless (every (match-lambda ;patch starts with package name? ((? string? patch) (and=> (string-contains (basename patch) (package-name package)) zero?)) (_ #f)) ;must be an <origin> or something like that. - (or (and=> (package-source package) origin-patches) - '())) + patches) (emit-warning package (G_ "file names of patches should start with the package name") - 'patch-file-names)))) + 'patch-file-names)) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length %distro-directory)) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (for-each (match-lambda + ((? string? patch) + (when (> (+ margin (if (string-prefix? %distro-directory + patch) + (- (string-length patch) prefix) + (string-length patch))) + max) + (emit-warning + package + (format #f (G_ "~a: file name is too long") + (basename patch)) + 'patch-file-names))) + (_ #f)) + patches)))) (define (escape-quotes str) "Replace any quote character in STR by an escaped quote character." diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 6a2485a007..ebd0bf783d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -118,7 +118,7 @@ determined." (catch #t (lambda () ;; Avoid ABI incompatibility with the <build-machine> record. - (set! %fresh-auto-compile #t) + ;; (set! %fresh-auto-compile #t) (save-module-excursion (lambda () diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f972ca2ef7..0a4a07ae2a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -49,7 +49,7 @@ #:use-module (srfi srfi-37) #:use-module (gnu packages) #:autoload (gnu packages base) (canonical-package) - #:autoload (gnu packages guile) (guile-2.0) + #:autoload (gnu packages guile) (guile-2.2) #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:export (build-and-use-profile delete-generations @@ -918,5 +918,5 @@ processed, #f otherwise." (%store) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (process-actions (%store) opts))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2400198000..be0c168444 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -25,7 +25,6 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) - #:use-module (guix download) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) @@ -39,14 +38,9 @@ #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) - #:use-module (gnu packages compression) - #:use-module (gnu packages gnupg) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (guix-pull)) @@ -281,7 +275,7 @@ certificates~%")) store (if (assoc-ref opts 'bootstrap?) %bootstrap-guile - (canonical-package guile-2.0))))) + (canonical-package guile-2.2))))) (run-with-store store (build-and-install checkout (config-directory) #:commit commit diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e50f1d8ac7..e2ff42693f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -36,6 +36,8 @@ #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) + #:use-module (guix progress) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) @@ -107,47 +109,54 @@ BODY..., and restore them." (store-lift topologically-sorted)) -(define* (copy-item item target +(define* (copy-item item references target #:key (log-port (current-error-port))) - "Copy ITEM to the store under root directory TARGET and register it." - (mlet* %store-monad ((refs (references* item))) - (let ((dest (string-append target item)) - (state (string-append target "/var/guix"))) - (format log-port "copying '~a'...~%" item) - - ;; Remove DEST if it exists to make sure that (1) we do not fail badly - ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and - ;; (2) we end up with the right contents. - (when (file-exists? dest) - (delete-file-recursively dest)) - - (copy-recursively item dest - #:log (%make-void-port "w")) - - ;; Register ITEM; as a side-effect, it resets timestamps, etc. - ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid - ;; reproducing the user's current settings; see - ;; <http://bugs.gnu.org/18049>. - (unless (register-path item - #:prefix target - #:state-directory state - #:references refs) - (leave (G_ "failed to register '~a' under '~a'~%") - item target)) - - (return #t)))) + "Copy ITEM to the store under root directory TARGET and register it with +REFERENCES as its set of references." + (let ((dest (string-append target item)) + (state (string-append target "/var/guix"))) + (format log-port "copying '~a'...~%" item) + + ;; Remove DEST if it exists to make sure that (1) we do not fail badly + ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and + ;; (2) we end up with the right contents. + (when (file-exists? dest) + (delete-file-recursively dest)) + + (copy-recursively item dest + #:log (%make-void-port "w")) + + ;; Register ITEM; as a side-effect, it resets timestamps, etc. + ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid + ;; reproducing the user's current settings; see + ;; <http://bugs.gnu.org/18049>. + (unless (register-path item + #:prefix target + #:state-directory state + #:references references) + (leave (G_ "failed to register '~a' under '~a'~%") + item target)))) (define* (copy-closure item target #:key (log-port (current-error-port))) "Copy ITEM and all its dependencies to the store under root directory TARGET, and register them." - (mlet* %store-monad ((refs (references* item)) - (to-copy (topologically-sorted* - (delete-duplicates (cons item refs) - string=?)))) - (sequence %store-monad - (map (cut copy-item <> target #:log-port log-port) - to-copy)))) + (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) + (refs (mapm %store-monad references* to-copy))) + (define progress-bar + (progress-reporter/bar (length to-copy) + (format #f (G_ "copying to '~a'...") + target))) + + (call-with-progress-reporter progress-bar + (lambda (report) + (let ((void (%make-void-port "w"))) + (for-each (lambda (item refs) + (copy-item item refs target #:log-port void) + (report)) + to-copy refs)))) + + (return *unspecified*))) (define* (install-bootloader installer-drv #:key @@ -667,7 +676,8 @@ and TARGET arguments." (gexp->file "bootloader-installer" (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 binary-ports)) (#$installer #$bootloader #$device #$target)))))) (define* (perform-action action os @@ -1095,7 +1105,8 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (current-terminal-columns (terminal-columns))) (process-command command args opts))))) ;;; Local Variables: diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 0d4a7fa26b..2e782e36ce 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -23,10 +23,11 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix progress) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix grafts) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (guix scripts substitute) #:use-module (gnu packages) #:use-module (web uri) @@ -48,42 +49,38 @@ (cons package result)))) '())) +(define (call-with-progress-reporter reporter proc) + "This is a variant of 'call-with-progress-reporter' that works with monadic +scope." + ;; TODO: Move to a more appropriate place. + (with-monad %store-monad + (start-progress-reporter! reporter) + (mlet* %store-monad ((report -> (lambda () + (progress-reporter-report! reporter))) + (result (proc report))) + (stop-progress-reporter! reporter) + (return result)))) + (define* (package-outputs packages #:optional (system (%current-system))) "Return the list of outputs of all of PACKAGES for the given SYSTEM." (let ((packages (filter (cut supported-package? <> system) packages))) - - (define update-progress! - (let ((total (length packages)) - (done 0) - (width (max 10 (- (terminal-columns) 10)))) - (lambda () - (set! done (+ 1 done)) - (let* ((ratio (/ done total 1.)) - (done (inexact->exact (round (* width ratio)))) - (left (- width done))) - (format (current-error-port) "~5,1f% [~a~a]\r" - (* ratio 100.) - (make-string done #\#) - (make-string left #\space)) - (when (>= done total) - (newline (current-error-port))) - (force-output (current-error-port)))))) - (format (current-error-port) (G_ "computing ~h package derivations for ~a...~%") (length packages) system) - (foldm %store-monad - (lambda (package result) - (mlet %store-monad ((drv (package->derivation package system - #:graft? #f))) - (update-progress!) - (match (derivation->output-paths drv) - (((names . items) ...) - (return (append items result)))))) - '() - packages))) + (call-with-progress-reporter (progress-reporter/bar (length packages)) + (lambda (report) + (foldm %store-monad + (lambda (package result) + (mlet %store-monad ((drv (package->derivation package system + #:graft? #f))) + (report) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (append items result)))))) + '() + packages))))) (cond-expand (guile-2.2 @@ -204,31 +201,32 @@ Report the availability of substitutes.\n")) (define (guix-weather . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options) - #:build-options? #f)) - (urls (assoc-ref opts 'substitute-urls)) - (systems (match (filter-map (match-lambda - (('system . system) system) - (_ #f)) - opts) - (() (list (%current-system))) - (systems systems))) - (packages (let ((file (assoc-ref opts 'manifest))) - (if file - (load-manifest file) - (all-packages)))) - (items (with-store store - (parameterize ((%graft? #f)) - (concatenate - (run-with-store store - (mapm %store-monad - (lambda (system) - (package-outputs packages system)) - systems))))))) - (for-each (lambda (server) - (report-server-coverage server items)) - urls)))) + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((opts (parse-command-line args %options + (list %default-options) + #:build-options? #f)) + (urls (assoc-ref opts 'substitute-urls)) + (systems (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + (packages (let ((file (assoc-ref opts 'manifest))) + (if file + (load-manifest file) + (all-packages)))) + (items (with-store store + (parameterize ((%graft? #f)) + (concatenate + (run-with-store store + (mapm %store-monad + (lambda (system) + (package-outputs packages system)) + systems))))))) + (for-each (lambda (server) + (report-server-coverage server items)) + urls))))) ;;; Local Variables: ;;; eval: (put 'let/time 'scheme-indent-function 1) |