diff options
Diffstat (limited to 'guix')
34 files changed, 372 insertions, 162 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 4daec5eb66..da06cb1358 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -28,7 +28,8 @@ #:use-module (srfi srfi-26) #:export (%r-build-system-modules r-build - r-build-system)) + r-build-system + cran-uri)) ;; Commentary: ;; @@ -36,6 +37,15 @@ ;; ;; Code: +(define (cran-uri name version) + "Return a list of URI strings for the R package archive on CRAN for the +release corresponding to NAME and VERSION. As only the most recent version is +available via the first URI, the second URI points to the archived version." + (list (string-append "mirror://cran/src/contrib/" + name "_" version ".tar.gz") + (string-append "mirror://cran/src/contrib/Archive/" + name "/" name "_" version ".tar.gz"))) + (define %r-build-system-modules ;; Build-side modules imported by default. `((guix build r-build-system) diff --git a/guix/build/download.scm b/guix/build/download.scm index 6e85174bc9..d362fc1f26 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -36,8 +36,10 @@ resolve-uri-reference maybe-expand-mirrors url-fetch + byte-count->string progress-proc - uri-abbreviation)) + uri-abbreviation + store-path-abbreviation)) ;;; Commentary: ;;; @@ -49,6 +51,11 @@ ;; Size of the HTTP receive buffer. 65536) +(define (nearest-exact-integer x) + "Given a real number X, return the nearest exact integer, with ties going to +the nearest exact even integer." + (inexact->exact (round x))) + (define (duration->seconds duration) "Return the number of seconds represented by DURATION, a 'time-duration' object, as an inexact number." @@ -56,16 +63,17 @@ object, as an inexact number." (/ (time-nanosecond duration) 1e9))) (define (seconds->string duration) - "Given DURATION in seconds, return a string representing it in 'hh:mm:ss' -format." + "Given DURATION in seconds, return a string representing it in 'mm:ss' or +'hh:mm:ss' format, as needed." (if (not (number? duration)) - "00:00:00" - (let* ((total-seconds (inexact->exact (round duration))) + "00:00" + (let* ((total-seconds (nearest-exact-integer duration)) (extra-seconds (modulo total-seconds 3600)) - (hours (quotient total-seconds 3600)) + (num-hours (quotient total-seconds 3600)) + (hours (and (positive? num-hours) num-hours)) (mins (quotient extra-seconds 60)) (secs (modulo extra-seconds 60))) - (format #f "~2,'0d:~2,'0d:~2,'0d" hours mins secs)))) + (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) (define (byte-count->string size) "Given SIZE in bytes, return a string representing it in a human-readable @@ -75,8 +83,8 @@ way." (GiB (expt 1024. 3)) (TiB (expt 1024. 4))) (cond - ((< size KiB) (format #f "~dB" (inexact->exact size))) - ((< size MiB) (format #f "~dKiB" (inexact->exact (round (/ size KiB))))) + ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) + ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) (else (format #f "~,3fTiB" (/ size TiB)))))) @@ -91,10 +99,33 @@ width of the bar is BAR-WIDTH." (make-string filled #\#) (make-string empty #\space)))) -(define* (progress-proc file size #:optional (log-port (current-output-port))) +(define (string-pad-middle left right len) + "Combine LEFT and RIGHT with enough padding in the middle so that the +resulting string has length at least LEN. This right justifies RIGHT." + (string-append left + (string-pad right (max 0 (- len (string-length left)))))) + +(define (store-url-abbreviation url) + "Return a friendlier version of URL for display." + (let ((store-path (string-append (%store-directory) "/" (basename url)))) + ;; Take advantage of the implementation for store paths. + (store-path-abbreviation store-path))) + +(define* (store-path-abbreviation store-path #:optional (prefix-length 6)) + "Return an abbreviation of STORE-PATH for display, showing PREFIX-LENGTH +characters of the hash." + (let ((base (basename store-path))) + (string-append (string-take base prefix-length) + "…" + (string-drop base 32)))) + +(define* (progress-proc file size + #:optional (log-port (current-output-port)) + #:key (abbreviation identity)) "Return a procedure to show the progress of FILE's download, which is SIZE bytes long. The returned procedure is suitable for use as an argument to -`dump-port'. The progress report is written to LOG-PORT." +`dump-port'. The progress report is written to LOG-PORT, with ABBREVIATION +used to shorten FILE for display." ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not ;; called as frequently as we'd like too; this is especially bad with Nginx ;; on hydra.gnu.org, which returns whole nars as a single chunk. @@ -118,31 +149,31 @@ bytes long. The returned procedure is suitable for use as an argument to (/ transferred elapsed) 0)) (left (format #f " ~a ~a" - (basename file) + (abbreviation file) (byte-count->string size))) (right (format #f "~a/s ~a ~a~6,1f%" (byte-count->string throughput) (seconds->string elapsed) - (progress-bar %) %)) - ;; TODO: Make this adapt to the actual terminal width. - (cols 80) - (num-spaces (max 1 (- cols (+ (string-length left) - (string-length right))))) - (gap (make-string num-spaces #\space))) - (format log-port "~a~a~a" left gap right) + (progress-bar %) %))) + ;; TODO: Make this adapt to the actual terminal width. + (display (string-pad-middle left right 80) log-port) (display #\cr log-port) (flush-output-port log-port) (cont)))) (lambda (transferred cont) (with-elapsed-time elapsed - (let ((throughput (if elapsed - (/ transferred elapsed) - 0))) + (let* ((throughput (if elapsed + (/ transferred elapsed) + 0)) + (left (format #f " ~a" + (abbreviation file))) + (right (format #f "~a/s ~a | ~a transferred" + (byte-count->string throughput) + (seconds->string elapsed) + (byte-count->string transferred)))) + ;; TODO: Make this adapt to the actual terminal width. + (display (string-pad-middle left right 80) log-port) (display #\cr log-port) - (format log-port "~a\t~a transferred (~a/s)" - file - (byte-count->string transferred) - (byte-count->string throughput)) (flush-output-port log-port) (cont)))))))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 4184ccc9ac..2685da1a72 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -41,53 +41,63 @@ directory." ((file-name . _) file-name) (() (error "No files matching pattern: " pattern)))) +(define gnu:unpack (assq-ref gnu:%standard-phases 'unpack)) + +(define (gem-archive? file-name) + (string-match "^.*\\.gem$" file-name)) + (define* (unpack #:key source #:allow-other-keys) "Unpack the gem SOURCE and enter the resulting directory." - (and (zero? (system* "gem" "unpack" source)) - ;; The unpacked gem directory is named the same as the archive, sans - ;; the ".gem" extension. It is renamed to simply "gem" in an effort to - ;; keep file names shorter to avoid UNIX-domain socket file names and - ;; shebangs that exceed the system's fixed maximum length when running - ;; test suites. - (let ((dir (match:substring (string-match "^(.*)\\.gem$" - (basename source)) - 1))) - (rename-file dir "gem") - (chdir "gem") - #t))) + (if (gem-archive? source) + (and (zero? (system* "gem" "unpack" source)) + ;; The unpacked gem directory is named the same as the archive, + ;; sans the ".gem" extension. It is renamed to simply "gem" in an + ;; effort to keep file names shorter to avoid UNIX-domain socket + ;; file names and shebangs that exceed the system's fixed maximum + ;; length when running test suites. + (let ((dir (match:substring (string-match "^(.*)\\.gem$" + (basename source)) + 1))) + (rename-file dir "gem") + (chdir "gem") + #t)) + ;; Use GNU unpack strategy for things that aren't gem archives. + (gnu:unpack #:source source))) (define* (build #:key source #:allow-other-keys) "Build a new gem using the gemspec from the SOURCE gem." + (define (first-gemspec) + (first-matching-file "\\.gemspec$")) ;; Remove the original gemspec, if present, and replace it with a new one. ;; This avoids issues with upstream gemspecs requiring tools such as git to ;; generate the files list. - (let ((gemspec (or (false-if-exception - (first-matching-file "\\.gemspec$")) - ;; Make new gemspec if one wasn't shipped. - ".gemspec"))) - - (when (file-exists? gemspec) (delete-file gemspec)) - - ;; Extract gemspec from source gem. - (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source))) - (dynamic-wind - (const #t) - (lambda () - (call-with-output-file gemspec - (lambda (out) - ;; 'gem spec' writes to stdout, but 'gem build' only reads - ;; gemspecs from a file, so we redirect the output to a file. - (while (not (eof-object? (peek-char pipe))) - (write-char (read-char pipe) out)))) - #t) - (lambda () - (close-pipe pipe)))) - - ;; Build a new gem from the current working directory. This also allows any - ;; dynamic patching done in previous phases to be present in the installed - ;; gem. - (zero? (system* "gem" "build" gemspec)))) + (when (gem-archive? source) + (let ((gemspec (or (false-if-exception (first-gemspec)) + ;; Make new gemspec if one wasn't shipped. + ".gemspec"))) + + (when (file-exists? gemspec) (delete-file gemspec)) + + ;; Extract gemspec from source gem. + (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source))) + (dynamic-wind + (const #t) + (lambda () + (call-with-output-file gemspec + (lambda (out) + ;; 'gem spec' writes to stdout, but 'gem build' only reads + ;; gemspecs from a file, so we redirect the output to a file. + (while (not (eof-object? (peek-char pipe))) + (write-char (read-char pipe) out)))) + #t) + (lambda () + (close-pipe pipe)))))) + + ;; Build a new gem from the current working directory. This also allows any + ;; dynamic patching done in previous phases to be present in the installed + ;; gem. + (zero? (system* "gem" "build" (first-gemspec)))) (define* (check #:key tests? test-target #:allow-other-keys) "Run the gem's test suite rake task TEST-TARGET. Skip the tests if TESTS? diff --git a/guix/download.scm b/guix/download.scm index 42956772f5..204cfc0826 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -167,9 +167,9 @@ (cran ;; Arbitrary mirrors from http://cran.r-project.org/mirrors.html ;; This one automatically redirects to servers worldwide + "http://cran.r-project.org/" "http://cran.rstudio.com/" "http://cran.univ-lyon1.fr/" - "http://cran.r-mirror.de/" "http://cran.ism.ac.jp/" "http://cran.stat.auckland.ac.nz/" "http://cran.mirror.ac.za/" diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 8ed5e5407f..585cb9fec2 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -165,7 +165,7 @@ representation of the package page." (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (cran-uri ,name version)) (sha256 (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) diff --git a/guix/licenses.scm b/guix/licenses.scm index c3b76af9b9..7e05b32993 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -61,6 +61,7 @@ sleepycat vim x11 x11-style + zpl2.1 zlib fsf-free)) @@ -382,6 +383,11 @@ which may be a file:// URI pointing the package's tree." "Check the URI for details. " comment))) +(define zpl2.1 + (license "Zope Public License 2.1" + "http://directory.fsf.org/wiki?title=License:ZopePLv2.1" + "https://www.gnu.org/licenses/license-list.html#Zope2.0")) + (define zlib (license "Zlib" "http://www.gzip.org/zlib/zlib_license.html" diff --git a/guix/packages.scm b/guix/packages.scm index 49c6b44884..72822b8c97 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (web uri) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience @@ -46,6 +47,7 @@ origin-method origin-sha256 origin-file-name + origin-actual-file-name origin-patches origin-patch-flags origin-patch-inputs @@ -189,6 +191,26 @@ representation." ((_ str) #'(nix-base32-string->bytevector str))))) +(define (origin-actual-file-name origin) + "Return the file name of ORIGIN, either its 'file-name' field or the file +name of its URI." + (define (uri->file-name uri) + ;; Return the 'base name' of URI or URI itself, where URI is a string. + (let ((path (and=> (string->uri uri) uri-path))) + (if path + (basename path) + uri))) + + (or (origin-file-name origin) + (match (origin-uri origin) + ((head . tail) + (uri->file-name head)) + ((? string? uri) + (uri->file-name uri)) + (else + ;; git, svn, cvs, etc. reference + #f)))) + (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. diff --git a/guix/scripts.scm b/guix/scripts.scm new file mode 100644 index 0000000000..e34d38904c --- /dev/null +++ b/guix/scripts.scm @@ -0,0 +1,118 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; +;;; 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) + #:use-module (guix utils) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (args-fold* + parse-command-line + maybe-build + build-package)) + +;;; Commentary: +;;; +;;; General code for Guix scripts. +;;; +;;; Code: + +(define (args-fold* options unrecognized-option-proc operand-proc . seeds) + "A wrapper on top of `args-fold' that does proper user-facing error +reporting." + (catch 'misc-error + (lambda () + (apply args-fold options unrecognized-option-proc + operand-proc seeds)) + (lambda (key proc msg args . rest) + ;; XXX: MSG is not i18n'd. + (leave (_ "invalid argument: ~a~%") + (apply format #f msg args))))) + +(define (environment-build-options) + "Return additional build options passed as environment variables." + (arguments-from-environment-variable "GUIX_BUILD_OPTIONS")) + +(define %default-argument-handler + ;; The default handler for non-option command-line arguments. + (lambda (arg result) + (alist-cons 'argument arg result))) + +(define* (parse-command-line args options seeds + #:key + (argument-handler %default-argument-handler)) + "Parse the command-line arguments ARGS as well as arguments passed via the +'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of +SRFI-37 options) and return the result, seeded by SEEDS. +Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'. + +ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc' +parameter of 'args-fold'." + (define (parse-options-from args seeds) + ;; Actual parsing takes place here. + (apply args-fold* args options + (lambda (opt name arg . rest) + (leave (_ "~A: unrecognized option~%") name)) + argument-handler + seeds)) + + (call-with-values + (lambda () + (parse-options-from (environment-build-options) seeds)) + (lambda seeds + ;; ARGS take precedence over what the environment variable specifies. + (parse-options-from args seeds)))) + +(define* (maybe-build drvs + #:key dry-run? use-substitutes?) + "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is +true." + (with-monad %store-monad + (>>= (show-what-to-build* drvs + #:dry-run? dry-run? + #:use-substitutes? use-substitutes?) + (lambda (_) + (if dry-run? + (return #f) + (built-derivations drvs)))))) + +(define* (build-package package + #:key dry-run? (use-substitutes? #t) + #:allow-other-keys + #:rest build-options) + "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'. +Show what and how will/would be built." + (mbegin %store-monad + (apply set-build-options* + #:use-substitutes? use-substitutes? + (strip-keyword-arguments '(#:dry-run?) build-options)) + (mlet %store-monad ((derivation (package->derivation package))) + (mbegin %store-monad + (maybe-build (list derivation) + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + (return (show-derivation-outputs derivation)))))) + +;;; scripts.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index ab2fc46c31..b120c555e3 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -27,6 +27,7 @@ #:use-module (guix ui) #:use-module (guix pki) #:use-module (guix pk-crypto) + #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 match) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ab2a39b1f8..a357cf8aa4 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -19,6 +19,7 @@ (define-module (guix scripts build) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) @@ -537,14 +538,7 @@ arguments with packages that use the specified source." roots)) ((not (assoc-ref opts 'dry-run?)) (and (build-derivations store drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) + (for-each show-derivation-outputs drv) (for-each (cut register-root store <> <>) (map (lambda (drv) (map cdr diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 87b420405c..533970ffbb 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -18,6 +18,7 @@ (define-module (guix scripts download) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix utils) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index fc453ac38d..30146af10b 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -18,6 +18,7 @@ (define-module (guix scripts edit) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) #:use-module (gnu packages) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index ecdbc7aa37..7aa52e8a8a 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -27,6 +27,7 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module ((guix gexp) #:select (lower-inputs)) + #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 format) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6403893687..7e06c72ccb 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -18,6 +18,7 @@ (define-module (guix scripts gc) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (ice-9 match) #:use-module (ice-9 regex) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2b671be131..725ae42030 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -18,6 +18,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix monads) @@ -33,7 +34,6 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:use-module (web uri) #:export (%package-node-type %bag-node-type %bag-emerged-node-type @@ -78,25 +78,13 @@ ;;; Package DAG. ;;; -(define (uri->file-name uri) - "Return the 'base name' of URI or URI itself, where URI is a string." - (let ((path (and=> (string->uri uri) uri-path))) - (if path - (basename path) - uri))) - (define (node-full-name thing) "Return a human-readable name to denote THING, a package, origin, or file name." (cond ((package? thing) (package-full-name thing)) ((origin? thing) - (or (origin-file-name thing) - (match (origin-uri thing) - ((head . tail) - (uri->file-name head)) - ((? string? uri) - (uri->file-name uri))))) + (origin-actual-file-name thing)) ((string? thing) ;file name (or (basename thing) (error "basename" thing))) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index e2305d73ee..d44095377b 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -22,6 +22,7 @@ #:use-module (guix hash) #:use-module (guix serialization) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix utils) #:use-module (rnrs io ports) #:use-module (rnrs files) diff --git a/guix/scripts/import/cpan.scm b/guix/scripts/import/cpan.scm index 1f4dedf23f..3d470f684d 100644 --- a/guix/scripts/import/cpan.scm +++ b/guix/scripts/import/cpan.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import cpan) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import cpan) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index f11fa1004f..8d001ac494 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -20,6 +20,7 @@ (define-module (guix scripts import cran) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import cran) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index c72aaf0760..b22a7c4c23 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import elpa) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import elpa) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index 9f8094feac..a5dd2a7822 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import gem) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import gem) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/gnu.scm b/guix/scripts/import/gnu.scm index 5fac6db516..92bd8305ea 100644 --- a/guix/scripts/import/gnu.scm +++ b/guix/scripts/import/gnu.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import gnu) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import gnu) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 1e33556481..8d31128c47 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import hackage) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import hackage) #:use-module (guix scripts import) #:use-module (srfi srfi-1) @@ -47,7 +48,7 @@ package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) (display (_ " - -e ALIST, --cabal-environment=ALIST + -e ALIST, --cabal-environment=ALIST specify environment for Cabal evaluation")) (display (_ " -h, --help display this help and exit")) diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm index 2dc2677c54..dba053b313 100644 --- a/guix/scripts/import/nix.scm +++ b/guix/scripts/import/nix.scm @@ -20,6 +20,7 @@ (define-module (guix scripts import nix) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import snix) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 1e03843840..7166b014eb 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import pypi) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix import pypi) #:use-module (guix scripts import) #:use-module (srfi srfi-1) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2a618c9451..8224f540bb 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix scripts) #:use-module (guix gnu-maintenance) #:use-module (guix monads) #:use-module (gnu packages) @@ -57,6 +59,7 @@ check-derivation check-home-page check-source + check-source-file-name check-license check-formatting @@ -140,6 +143,13 @@ monad." (_ "description should not be empty") 'description))) + (define (check-texinfo-markup package) + "Check that PACKAGE description can be parsed as a Texinfo fragment." + (catch 'parser-error + (lambda () (package-description-string package)) + (lambda (keys . args) + (emit-warning package (_ "Texinfo markup in description is invalid"))))) + (define (check-proper-start description) (unless (or (properly-starts-sentence? description) (string-prefix-ci? (package-name package) description)) @@ -169,6 +179,7 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (let ((description (package-description package))) (when (string? description) (check-not-empty description) + (check-texinfo-markup package) (check-proper-start description) (check-end-of-sentence-space description)))) @@ -501,6 +512,26 @@ descriptions maintained upstream." (display warning (guix-warning-port))) (reverse warnings))))))))) +(define (check-source-file-name package) + "Emit a warning if PACKAGE's origin has no meaningful file name." + (define (origin-file-name-valid? origin) + ;; Return #t if the source file name contains only a version or is #f; + ;; indicates that the origin needs a 'file-name' field. + (let ((file-name (origin-actual-file-name origin)) + (version (package-version package))) + (and file-name + (not (or (string-prefix? version file-name) + ;; Common in many projects is for the filename to start + ;; with a "v" followed by the version, + ;; e.g. "v3.2.0.tar.gz". + (string-prefix? (string-append "v" version) file-name)))))) + + (let ((origin (package-source package))) + (unless (or (not origin) (origin-file-name-valid? origin)) + (emit-warning package + (_ "the source file name should contain the package name") + 'source)))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (catch #t @@ -563,12 +594,25 @@ descriptions maintained upstream." (format #f (_ "line ~a is way too long (~a characters)") line-number (string-length line))))) +(define %hanging-paren-rx + (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) + +(define (report-lone-parentheses package line line-number) + "Emit a warning if LINE contains hanging parentheses." + (when (regexp-exec %hanging-paren-rx line) + (emit-warning package + (format #f + (_ "line ~a: parentheses feel lonely, \ +move to the previous or next line") + line-number)))) + (define %formatting-reporters ;; List of procedures that report formatting issues. These are not separate ;; checkers because they would need to re-read the file. (list report-tabulations report-trailing-white-space - report-long-line)) + report-long-line + report-lone-parentheses)) (define* (report-formatting-issues package file starting-line #:key (reporters %formatting-reporters)) @@ -643,6 +687,10 @@ or a list thereof") (description "Validate source URLs") (check check-source)) (lint-checker + (name 'source-file-name) + (description "Validate file names of sources") + (check check-source-file-name)) + (lint-checker (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 23f1597856..e0fe1ddb27 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -29,6 +29,7 @@ #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p search-path-as-list)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index cc96355947..e352090d2d 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -45,6 +45,7 @@ #:use-module (guix store) #:use-module (guix serialization) #:use-module (guix ui) + #:use-module (guix scripts) #:export (guix-publish)) (define (show-help) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e8459e5ffb..56ee9acb18 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -18,6 +18,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) #:use-module (guix packages) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index e7980a97b0..097059e372 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -21,6 +21,7 @@ (define-module (guix scripts refresh) #:use-module (guix ui) #:use-module (guix hash) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index ee070f14b1..44ff92655b 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -18,6 +18,7 @@ (define-module (guix scripts size) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix utils) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index e908bc997e..ec8e6244af 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -31,7 +31,8 @@ #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) - #:select (progress-proc uri-abbreviation)) + #:select (progress-proc uri-abbreviation + store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -337,8 +338,9 @@ or is signed by an unauthorized key." (unless %allow-unauthenticated-substitutes? (assert-valid-signature narinfo signature hash acl) (when verbose? + ;; Visually separate substitutions with a newline. (format (current-error-port) - "found valid signature for '~a', from '~a'~%" + "~%Found valid signature for ~a~%From ~a~%" (narinfo-path narinfo) (uri->string (narinfo-uri narinfo))))) narinfo)))) @@ -753,13 +755,12 @@ 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'~:[~*~; (~,1f MiB installed)~]...~%" - store-item - + (format (current-error-port) "Downloading ~a~:[~*~; (~a installed)~]...~%" + (store-path-abbreviation store-item) ;; Use the Nar size as an estimate of the installed size. (narinfo-size narinfo) (and=> (narinfo-size narinfo) - (cute / <> (expt 2. 20)))) + (cute byte-count->string <>))) (let*-values (((raw download-size) ;; Note that Hydra currently generates Nars on the fly ;; and doesn't specify a Content-Length, so @@ -772,7 +773,9 @@ DESTINATION as a nar file. Verify the substitute against ACL." (narinfo-size narinfo)))) (progress (progress-proc (uri-abbreviation uri) dl-size - (current-error-port)))) + (current-error-port) + #:abbreviation + store-path-abbreviation))) (progress-report-port progress raw))) ((input pids) (decompressed-port (and=> (narinfo-compression narinfo) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 45f598219d..5e2d226dfe 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -26,6 +26,7 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix profiles) + #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix build utils) #:use-module (gnu build install) @@ -298,19 +299,6 @@ it atomically, and then run OS's activation script." ((disk-image) (system-disk-image os #:disk-image-size image-size)))) -(define* (maybe-build drvs - #:key dry-run? use-substitutes?) - "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is -true." - (with-monad %store-monad - (>>= (show-what-to-build* drvs - #:dry-run? dry-run? - #:use-substitutes? use-substitutes?) - (lambda (_) - (if dry-run? - (return #f) - (built-derivations drvs)))))) - (define* (perform-action action os #:key grub? dry-run? use-substitutes? device target @@ -514,6 +502,13 @@ Build the operating system declared in FILE according to ACTION.\n")) (leave (_ "wrong number of arguments for action '~a'~%") action)) + (unless action + (format (current-error-port) + (_ "guix system: missing command name~%")) + (format (current-error-port) + (_ "Try 'guix system --help' for more information.~%")) + (exit 1)) + (case action ((build vm vm-image disk-image reconfigure) (unless (= count 1) diff --git a/guix/store.scm b/guix/store.scm index 132b8a3ac4..5f37e72589 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -58,6 +58,7 @@ close-connection with-store set-build-options + set-build-options* valid-path? query-path-hash hash-part->path @@ -986,6 +987,9 @@ permission bits are kept." ;; Monadic variant of 'build-things'. (store-lift build-things)) +(define set-build-options* + (store-lift set-build-options)) + (define %guile-for-build ;; The derivation of the Guile to be used within the build environment, ;; when using 'gexp->derivation' and co. diff --git a/guix/ui.scm b/guix/ui.scm index ca5b844a43..4a3630f242 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2,9 +2,11 @@ ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> +;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com> ;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> -;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,7 +41,6 @@ #:use-module (srfi srfi-31) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (srfi srfi-37) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -61,6 +62,7 @@ show-bug-report-information string->number* size->number + show-derivation-outputs show-what-to-build show-what-to-build* show-manifest-transaction @@ -79,8 +81,6 @@ package-specification->name+version+output string->generations string->duration - args-fold* - parse-command-line run-guix-command run-guix program-name @@ -503,6 +503,14 @@ error." (leave (_ "expression ~s does not evaluate to a package~%") str)))) +(define (show-derivation-outputs derivation) + "Show the output file names of DERIVATION." + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path derivation out-name))) + (derivation-outputs derivation)))) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t)) "Show what will or would (depending on DRY-RUN?) be built in realizing the @@ -959,52 +967,6 @@ optionally contain a version number and an output name, as in these examples: ;;; Command-line option processing. ;;; -(define (args-fold* options unrecognized-option-proc operand-proc . seeds) - "A wrapper on top of `args-fold' that does proper user-facing error -reporting." - (catch 'misc-error - (lambda () - (apply args-fold options unrecognized-option-proc - operand-proc seeds)) - (lambda (key proc msg args . rest) - ;; XXX: MSG is not i18n'd. - (leave (_ "invalid argument: ~a~%") - (apply format #f msg args))))) - -(define (environment-build-options) - "Return additional build options passed as environment variables." - (arguments-from-environment-variable "GUIX_BUILD_OPTIONS")) - -(define %default-argument-handler - ;; The default handler for non-option command-line arguments. - (lambda (arg result) - (alist-cons 'argument arg result))) - -(define* (parse-command-line args options seeds - #:key - (argument-handler %default-argument-handler)) - "Parse the command-line arguments ARGS as well as arguments passed via the -'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of -SRFI-37 options) and return the result, seeded by SEEDS. -Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'. - -ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc' -parameter of 'args-fold'." - (define (parse-options-from args seeds) - ;; Actual parsing takes place here. - (apply args-fold* args options - (lambda (opt name arg . rest) - (leave (_ "~A: unrecognized option~%") name)) - argument-handler - seeds)) - - (call-with-values - (lambda () - (parse-options-from (environment-build-options) seeds)) - (lambda seeds - ;; ARGS take precedence over what the environment variable specifies. - (parse-options-from args seeds)))) - (define (show-guix-usage) (format (current-error-port) (_ "Try `guix --help' for more information.~%")) |