summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/r.scm12
-rw-r--r--guix/build/download.scm83
-rw-r--r--guix/build/ruby-build-system.scm86
-rw-r--r--guix/download.scm2
-rw-r--r--guix/import/cran.scm2
-rw-r--r--guix/licenses.scm6
-rw-r--r--guix/packages.scm22
-rw-r--r--guix/scripts.scm118
-rw-r--r--guix/scripts/archive.scm1
-rw-r--r--guix/scripts/build.scm10
-rw-r--r--guix/scripts/download.scm1
-rw-r--r--guix/scripts/edit.scm1
-rw-r--r--guix/scripts/environment.scm1
-rw-r--r--guix/scripts/gc.scm1
-rw-r--r--guix/scripts/graph.scm16
-rw-r--r--guix/scripts/hash.scm1
-rw-r--r--guix/scripts/import/cpan.scm1
-rw-r--r--guix/scripts/import/cran.scm1
-rw-r--r--guix/scripts/import/elpa.scm1
-rw-r--r--guix/scripts/import/gem.scm1
-rw-r--r--guix/scripts/import/gnu.scm1
-rw-r--r--guix/scripts/import/hackage.scm3
-rw-r--r--guix/scripts/import/nix.scm1
-rw-r--r--guix/scripts/import/pypi.scm1
-rw-r--r--guix/scripts/lint.scm52
-rw-r--r--guix/scripts/package.scm1
-rw-r--r--guix/scripts/publish.scm1
-rw-r--r--guix/scripts/pull.scm1
-rw-r--r--guix/scripts/refresh.scm1
-rw-r--r--guix/scripts/size.scm1
-rwxr-xr-xguix/scripts/substitute.scm17
-rw-r--r--guix/scripts/system.scm21
-rw-r--r--guix/store.scm4
-rw-r--r--guix/ui.scm62
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.~%"))