aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-09-13 21:28:01 +0200
committerLudovic Courtès <ludo@gnu.org>2015-09-13 21:28:01 +0200
commit75710da66710cef1d32053cd8f350d13057d02a7 (patch)
treeabef6a326c741b1eb18db866b2f2bacee3e5fc51 /guix
parentab20c2cc33063ce783515d8ae7899ec7e2ca6f96 (diff)
parent610075f7c94c80b8321887b7ccf8bb1a7edd2b8e (diff)
downloadgnu-guix-75710da66710cef1d32053cd8f350d13057d02a7.tar
gnu-guix-75710da66710cef1d32053cd8f350d13057d02a7.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/r.scm134
-rw-r--r--guix/build/download.scm79
-rw-r--r--guix/build/emacs-build-system.scm2
-rw-r--r--guix/build/r-build-system.scm112
-rw-r--r--guix/build/ruby-build-system.scm16
-rw-r--r--guix/build/syscalls.scm24
-rw-r--r--guix/download.scm29
-rw-r--r--guix/git-download.scm4
-rw-r--r--guix/http-client.scm7
-rw-r--r--guix/import/cran.scm188
-rw-r--r--guix/import/gem.scm3
-rw-r--r--guix/licenses.scm20
-rw-r--r--guix/monads.scm8
-rw-r--r--guix/packages.scm15
-rw-r--r--guix/scripts/build.scm49
-rw-r--r--guix/scripts/graph.scm27
-rw-r--r--guix/scripts/import.scm2
-rw-r--r--guix/scripts/import/cran.scm92
-rw-r--r--guix/scripts/lint.scm28
-rw-r--r--guix/scripts/publish.scm23
-rw-r--r--guix/scripts/pull.scm2
-rw-r--r--guix/scripts/refresh.scm2
-rwxr-xr-xguix/scripts/substitute.scm2
-rw-r--r--guix/ui.scm111
24 files changed, 866 insertions, 113 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
new file mode 100644
index 0000000000..4daec5eb66
--- /dev/null
+++ b/guix/build-system/r.scm
@@ -0,0 +1,134 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 build-system r)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%r-build-system-modules
+ r-build
+ r-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for R packages.
+;;
+;; Code:
+
+(define %r-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build r-build-system)
+ ,@%gnu-build-system-modules))
+
+(define (default-r)
+ "Return the default R package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((r-mod (resolve-interface '(gnu packages statistics))))
+ (module-ref r-mod 'r)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (r (default-r))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:source #:target #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("r" ,r)
+ ,@native-inputs))
+ (outputs outputs)
+ (build r-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (r-build store name inputs
+ #:key
+ (tests? #t)
+ (test-target "tests")
+ (configure-flags ''())
+ (phases '(@ (guix build r-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %r-build-system-modules)
+ (modules '((guix build r-build-system)
+ (guix build utils))))
+ "Build SOURCE with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (r-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:configure-flags ,configure-flags
+ #:system ,system
+ #:tests? ,tests?
+ #:test-target ,test-target
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define r-build-system
+ (build-system
+ (name 'r)
+ (description "The standard R build system")
+ (lower lower)))
+
+;;; r.scm ends here
diff --git a/guix/build/download.scm b/guix/build/download.scm
index ae59b0109c..6e85174bc9 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -54,17 +55,46 @@ object, as an inexact number."
(+ (time-second duration)
(/ (time-nanosecond duration) 1e9)))
-(define (throughput->string throughput)
- "Given THROUGHPUT, measured in bytes per second, return a string
-representing it in a human-readable way."
- (if (> throughput 3e6)
- (format #f "~,2f MiB/s" (/ throughput (expt 2. 20)))
- (format #f "~,0f KiB/s" (/ throughput 1024.0))))
+(define (seconds->string duration)
+ "Given DURATION in seconds, return a string representing it in 'hh:mm:ss'
+format."
+ (if (not (number? duration))
+ "00:00:00"
+ (let* ((total-seconds (inexact->exact (round duration)))
+ (extra-seconds (modulo total-seconds 3600))
+ (hours (quotient total-seconds 3600))
+ (mins (quotient extra-seconds 60))
+ (secs (modulo extra-seconds 60)))
+ (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
+way."
+ (let ((KiB 1024.)
+ (MiB (expt 1024. 2))
+ (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 GiB) (format #f "~,1fMiB" (/ size MiB)))
+ ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
+ (else (format #f "~,3fTiB" (/ size TiB))))))
+
+(define* (progress-bar % #:optional (bar-width 20))
+ "Return % as a string representing an ASCII-art progress bar. The total
+width of the bar is BAR-WIDTH."
+ (let* ((fraction (/ % 100))
+ (filled (inexact->exact (floor (* fraction bar-width))))
+ (empty (- bar-width filled)))
+ (format #f "[~a~a]"
+ (make-string filled #\#)
+ (make-string empty #\space))))
(define* (progress-proc file size #:optional (log-port (current-output-port)))
- "Return a procedure to show the progress of FILE's download, which is
-SIZE byte long. The returned procedure is suitable for use as an
-argument to `dump-port'. The progress report is written to LOG-PORT."
+ "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."
;; 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.
@@ -83,14 +113,24 @@ argument to `dump-port'. The progress report is written to LOG-PORT."
(if (number? size)
(lambda (transferred cont)
(with-elapsed-time elapsed
- (let ((% (* 100.0 (/ transferred size)))
- (throughput (if elapsed
- (/ transferred elapsed)
- 0)))
+ (let* ((% (* 100.0 (/ transferred size)))
+ (throughput (if elapsed
+ (/ transferred elapsed)
+ 0))
+ (left (format #f " ~a ~a"
+ (basename 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)
(display #\cr log-port)
- (format log-port "~a\t~5,1f% of ~,1f KiB (~a)"
- file % (/ size 1024.0)
- (throughput->string throughput))
(flush-output-port log-port)
(cont))))
(lambda (transferred cont)
@@ -99,9 +139,10 @@ argument to `dump-port'. The progress report is written to LOG-PORT."
(/ transferred elapsed)
0)))
(display #\cr log-port)
- (format log-port "~a\t~6,1f KiB transferred (~a)"
- file (/ transferred 1024.0)
- (throughput->string throughput))
+ (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/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index aacb5a4186..cb5bde3191 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -84,7 +84,7 @@ store in '.el' files."
(elpa-name-ver (store-directory->elpa-name-version out))
(el-dir (string-append out %install-suffix "/" elpa-name-ver))
(name-ver (strip-store-file-name out))
- (info-dir (string-append out "/share/info/" name-ver))
+ (info-dir (string-append out "/share/info/"))
(info-files (find-files el-dir "\\.info$")))
(unless (null? info-files)
(mkdir-p info-dir)
diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm
new file mode 100644
index 0000000000..3fc13eb835
--- /dev/null
+++ b/guix/build/r-build-system.scm
@@ -0,0 +1,112 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 build r-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 popen)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%standard-phases
+ r-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard build procedure for R packages.
+;;
+;; Code:
+
+(define (invoke-r command params)
+ (zero? (apply system* "R" "CMD" command params)))
+
+(define (pipe-to-r command params)
+ (let ((port (apply open-pipe* OPEN_WRITE "R" params)))
+ (display command port)
+ (zero? (status:exit-val (close-pipe port)))))
+
+(define (generate-site-path inputs)
+ (string-join (map (match-lambda
+ ((_ . path)
+ (string-append path "/site-library")))
+ ;; Restrict to inputs beginning with "r-".
+ (filter (match-lambda
+ ((name . _)
+ (string-prefix? "r-" name)))
+ inputs))
+ ":"))
+
+(define* (check #:key test-target inputs outputs tests? #:allow-other-keys)
+ "Run the test suite of a given R package."
+ (let* ((libdir (string-append (assoc-ref outputs "out") "/site-library/"))
+
+ ;; R package names are case-sensitive and cannot be derived from the
+ ;; Guix package name. The exact package name is required as an
+ ;; argument to ‘tools::testInstalledPackage’, which runs the tests
+ ;; for a package given its name and the path to the “library” (a
+ ;; location for a collection of R packages) containing it.
+
+ ;; Since there can only be one R package in any collection (=
+ ;; “library”), the name of the only directory in the collection path
+ ;; is the original name of the R package.
+ (pkg-name (car (scandir libdir (negate (cut member <> '("." ".."))))))
+ (testdir (string-append libdir pkg-name "/" test-target))
+ (site-path (string-append libdir ":" (generate-site-path inputs))))
+ (if (and tests? (file-exists? testdir))
+ (begin
+ (setenv "R_LIBS_SITE" site-path)
+ (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", "
+ "lib.loc = \"" libdir "\")")
+ '("--no-save" "--slave")))
+ #t)))
+
+(define* (install #:key outputs inputs (configure-flags '())
+ #:allow-other-keys)
+ "Install a given R package."
+ (let* ((out (assoc-ref outputs "out"))
+ (site-library (string-append out "/site-library/"))
+ (params (append configure-flags
+ (list "--install-tests"
+ (string-append "--library=" site-library)
+ ".")))
+ (site-path (string-append site-library ":"
+ (generate-site-path inputs))))
+ ;; If dependencies cannot be found at install time, R will refuse to
+ ;; install the package.
+ (setenv "R_LIBS_SITE" site-path)
+ ;; Some R packages contain a configure script for which the CONFIG_SHELL
+ ;; variable should be set.
+ (setenv "CONFIG_SHELL" (which "bash"))
+ (mkdir-p site-library)
+ (invoke-r "INSTALL" params)))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'configure)
+ (delete 'build)
+ (delete 'check) ; tests must be run after installation
+ (replace 'install install)
+ (add-after 'install 'check check)))
+
+(define* (r-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given R package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; r-build-system.scm ends here
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 90fab92f6a..4184ccc9ac 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -44,12 +44,16 @@ directory."
(define* (unpack #:key source #:allow-other-keys)
"Unpack the gem SOURCE and enter the resulting directory."
(and (zero? (system* "gem" "unpack" source))
- (begin
- ;; The unpacked gem directory is named the same as the archive, sans
- ;; the ".gem" extension.
- (chdir (match:substring (string-match "^(.*)\\.gem$"
- (basename source))
- 1))
+ ;; 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)))
(define* (build #:key source #:allow-other-keys)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index fc801a5e9d..2c2fbde0a3 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -50,6 +50,8 @@
mkdtemp!
pivot-root
+ CLONE_CHILD_CLEARTID
+ CLONE_CHILD_SETTID
CLONE_NEWNS
CLONE_NEWUTS
CLONE_NEWIPC
@@ -303,12 +305,14 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(pointer->string result)))))
;; Linux clone flags, from linux/sched.h
-(define CLONE_NEWNS #x00020000)
-(define CLONE_NEWUTS #x04000000)
-(define CLONE_NEWIPC #x08000000)
-(define CLONE_NEWUSER #x10000000)
-(define CLONE_NEWPID #x20000000)
-(define CLONE_NEWNET #x40000000)
+(define CLONE_CHILD_CLEARTID #x00200000)
+(define CLONE_CHILD_SETTID #x01000000)
+(define CLONE_NEWNS #x00020000)
+(define CLONE_NEWUTS #x04000000)
+(define CLONE_NEWIPC #x08000000)
+(define CLONE_NEWUSER #x10000000)
+(define CLONE_NEWPID #x20000000)
+(define CLONE_NEWNET #x40000000)
;; The libc interface to sys_clone is not useful for Scheme programs, so the
;; low-level system call is wrapped instead.
@@ -325,7 +329,13 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
"Create a new child process by duplicating the current parent process.
Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes."
- (proc syscall-id flags %null-pointer))))
+ (let ((ret (proc syscall-id flags %null-pointer))
+ (err (errno)))
+ (if (= ret -1)
+ (throw 'system-error "clone" "~d: ~A"
+ (list flags (strerror err))
+ (list err))
+ ret)))))
(define setns
;; Some systems may be using an old (pre-2.14) version of glibc where there
diff --git a/guix/download.scm b/guix/download.scm
index 6e91607196..42956772f5 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -202,6 +202,12 @@
"http://ftp.fr.debian.org/debian/"
"http://ftp.debian.org/debian/"))))
+(define %mirror-file
+ ;; Copy of the list of mirrors to a file. This allows us to keep a single
+ ;; copy in the store, and computing it here avoids repeated calls to
+ ;; 'object->string'.
+ (plain-file "mirrors" (object->string %mirrors)))
+
(define (gnutls-package)
"Return the default GnuTLS package."
(let ((module (resolve-interface '(gnu packages tls))))
@@ -210,16 +216,14 @@
(define* (url-fetch url hash-algo hash
#:optional name
#:key (system (%current-system))
- (guile (default-guile))
- (mirrors %mirrors))
+ (guile (default-guile)))
"Return a fixed-output derivation that fetches URL (a string, or a list of
strings denoting alternate URLs), which is expected to have hash HASH of type
HASH-ALGO (a symbol). By default, the file name is the base name of URL;
optionally, NAME can specify a different file name.
When one of the URL starts with mirror://, then its host part is
-interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
-must be a list of symbol/URL-list pairs.
+interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
Alternately, when URL starts with file://, return the corresponding file name
in the store."
@@ -239,10 +243,6 @@ in the store."
((url ...)
(any https? url)))))
- (define mirror-file
- ;; Copy the list of mirrors to a file to keep a single copy in the store.
- (plain-file "mirrors" (object->string mirrors)))
-
(define builder
#~(begin
#+(if need-gnutls?
@@ -261,7 +261,7 @@ in the store."
(url-fetch (call-with-input-string (getenv "guix download url")
read)
#$output
- #:mirrors (call-with-input-file #$mirror-file read))))
+ #:mirrors (call-with-input-file #$%mirror-file read))))
(let ((uri (and (string? url) (string->uri url))))
(if (or (and (string? url) (not uri))
@@ -288,12 +288,11 @@ in the store."
;; Honor the user's proxy settings.
#:leaked-env-vars '("http_proxy" "https_proxy")
- ;; In general, offloading downloads is not a good idea.
- ;;#:local-build? #t
- ;; FIXME: The above would also disable use of
- ;; substitutes on old daemons, so comment it out;
- ;; see <https://bugs.gnu.org/18747>.
- )))))
+ ;; In general, offloading downloads is not a good
+ ;; idea. Daemons before 0.8.3 would also
+ ;; interpret this as "do not substitute" (see
+ ;; <https://bugs.gnu.org/18747>.)
+ #:local-build? #t)))))
(define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port)) recursive?)
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 0f2218c13e..1e5c845e34 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -89,9 +89,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "git-checkout") build
#:system system
- ;; FIXME: See <https://bugs.gnu.org/18747>.
- ;; Uncomment when fixed daemons are widely deployed.
- ;;#:local-build? #t
+ #:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
diff --git a/guix/http-client.scm b/guix/http-client.scm
index dc8d3298fc..5cfe05f2e0 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -19,7 +19,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix http-client)
- #:use-module (guix utils)
#:use-module (web uri)
#:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
@@ -167,13 +166,15 @@ closes PORT, unless KEEP-ALIVE? is true."
(define close
(and (not keep-alive?)
(lambda ()
- (close port))))
+ (close-port port))))
(make-custom-binary-input-port "delimited input port" read! #f #f close))
- (unless (guile-version>? "2.0.9")
+ (unless (guile-version>? "2.0.11")
;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more
;; than what 'content-length' says. See Guile commit 802a25b.
+ ;; Guile <= 2.0.12 had a bug whereby the 'close' method of the response
+ ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41.
(module-set! (resolve-module '(web response))
'make-delimited-input-port make-delimited-input-port)))
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
new file mode 100644
index 0000000000..8ed5e5407f
--- /dev/null
+++ b/guix/import/cran.scm
@@ -0,0 +1,188 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 import cran)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (sxml simple)
+ #:use-module (sxml match)
+ #:use-module (sxml xpath)
+ #:use-module (guix http-client)
+ #:use-module (guix hash)
+ #:use-module (guix store)
+ #:use-module (guix base32)
+ #:use-module ((guix download) #:select (download-to-store))
+ #:use-module (guix import utils)
+ #:export (cran->guix-package))
+
+;;; Commentary:
+;;;
+;;; Generate a package declaration template for the latest version of an R
+;;; package on CRAN, using the HTML description downloaded from
+;;; cran.r-project.org.
+;;;
+;;; Code:
+
+(define string->license
+ (match-lambda
+ ("AGPL-3" 'agpl3+)
+ ("Artistic-2.0" 'artistic2.0)
+ ("Apache License 2.0" 'asl2.0)
+ ("BSD_2_clause" 'bsd-2)
+ ("BSD_3_clause" 'bsd-3)
+ ("GPL-2" 'gpl2+)
+ ("GPL-3" 'gpl3+)
+ ("LGPL-2" 'lgpl2.0+)
+ ("LGPL-2.1" 'lgpl2.1+)
+ ("LGPL-3" 'lgpl3+)
+ ("MIT" 'x11)
+ ((x) (string->license x))
+ ((lst ...) `(list ,@(map string->license lst)))
+ (_ #f)))
+
+(define (format-inputs names)
+ "Generate a sorted list of package inputs from a list of package NAMES."
+ (map (lambda (name)
+ (list name (list 'unquote (string->symbol name))))
+ (sort names string-ci<?)))
+
+(define* (maybe-inputs package-inputs #:optional (type 'inputs))
+ "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
+package definition."
+ (match package-inputs
+ (()
+ '())
+ ((package-inputs ...)
+ `((,type (,'quasiquote ,(format-inputs package-inputs)))))))
+
+(define (table-datum tree label)
+ "Extract the datum node following a LABEL in the sxml table TREE. Only the
+first cell of a table row is considered a label cell."
+ ((node-pos 1)
+ ((sxpath `(xhtml:tr
+ (xhtml:td 1) ; only first cell can contain label
+ (equal? ,label)
+ ,(node-parent tree) ; go up to label cell
+ ,(node-parent tree) ; go up to matching row
+ (xhtml:td 2))) ; select second cell
+ tree)))
+
+(define %cran-url "http://cran.r-project.org/web/packages/")
+
+(define (cran-fetch name)
+ "Return an sxml representation of the CRAN page for the R package NAME,
+or #f on failure. NAME is case-sensitive."
+ ;; This API always returns the latest release of the module.
+ (let ((cran-url (string-append %cran-url name)))
+ (false-if-exception
+ (xml->sxml (http-fetch cran-url)
+ #:trim-whitespace? #t
+ #:namespaces '((xhtml . "http://www.w3.org/1999/xhtml"))
+ #:default-entity-handler
+ (lambda (port name)
+ (case name
+ ((nbsp) " ")
+ ((ge) ">=")
+ ((gt) ">")
+ ((lt) "<")
+ (else
+ (format (current-warning-port)
+ "~a:~a:~a: undefined entitity: ~a\n"
+ cran-url (port-line port) (port-column port)
+ name)
+ (symbol->string name))))))))
+
+(define (cran-sxml->sexp sxml)
+ "Return the `package' s-expression for a CRAN package from the SXML
+representation of the package page."
+ (define (nodes->text nodeset)
+ (string-join ((sxpath '(// *text*)) nodeset) " "))
+
+ (define (guix-name name)
+ (if (string-prefix? "r-" name)
+ (string-downcase name)
+ (string-append "r-" (string-downcase name))))
+
+ (sxml-match-let*
+ (((*TOP* (xhtml:html
+ ,head
+ (xhtml:body
+ (xhtml:h2 ,name-and-synopsis)
+ (xhtml:p ,description)
+ ,summary
+ (xhtml:h4 "Downloads:") ,downloads
+ . ,rest)))
+ sxml))
+ (let* ((name (match:prefix (string-match ": " name-and-synopsis)))
+ (synopsis (match:suffix (string-match ": " name-and-synopsis)))
+ (version (nodes->text (table-datum summary "Version:")))
+ (license ((compose string->license nodes->text)
+ (table-datum summary "License:")))
+ (home-page (nodes->text ((sxpath '((xhtml:a 1)))
+ (table-datum summary "URL:"))))
+ (source-url (string-append "mirror://cran/"
+ ;; Remove double dots, because we want an
+ ;; absolute path.
+ (regexp-substitute/global
+ #f "\\.\\./"
+ (string-join
+ ((sxpath '((xhtml:a 1) @ href *text*))
+ (table-datum downloads
+ " Package source: ")))
+ 'pre 'post)))
+ (tarball (with-store store (download-to-store store source-url)))
+ (sysdepends (map match:substring
+ (list-matches
+ "[^ ]+"
+ ;; Strip off comma and parenthetical
+ ;; expressions.
+ (regexp-substitute/global
+ #f "(,|\\([^\\)]+\\))"
+ (nodes->text (table-datum summary
+ "SystemRequirements:"))
+ 'pre 'post))))
+ (imports (map guix-name
+ ((sxpath '(// xhtml:a *text*))
+ (table-datum summary "Imports:")))))
+ `(package
+ (name ,(guix-name name))
+ (version ,version)
+ (source (origin
+ (method url-fetch)
+ (uri (string-append ,@(factorize-uri source-url version)))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string (file-sha256 tarball))))))
+ (build-system r-build-system)
+ ,@(maybe-inputs sysdepends)
+ ,@(maybe-inputs imports 'propagated-inputs)
+ (home-page ,(if (string-null? home-page)
+ (string-append %cran-url name)
+ home-page))
+ (synopsis ,synopsis)
+ ;; Use double spacing
+ (description ,(regexp-substitute/global #f "\\. \\b" description
+ 'pre ". " 'post))
+ (license ,license)))))
+
+(define (cran->guix-package package-name)
+ "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the
+`package' s-expression corresponding to that package, or #f on failure."
+ (let ((module-meta (cran-fetch package-name)))
+ (and=> module-meta cran-sxml->sexp)))
diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index 3c28d1d9fd..c64c4e9374 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -105,8 +105,9 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
(description ,description)
(home-page ,home-page)
(license ,(match licenses
+ (() #f)
((license) (license->symbol license))
- (_ (map license->symbol licenses))))))
+ (_ `(list ,@(map license->symbol licenses)))))))
(define* (gem->guix-package package-name #:optional version)
"Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the
diff --git a/guix/licenses.scm b/guix/licenses.scm
index dae0e3d386..c3b76af9b9 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +30,7 @@
non-copyleft
bsd-style ;deprecated!
cc0
+ cc-by-sa4.0 cc-by3.0
cddl1.0
cecill-c
artistic2.0 clarified-artistic
@@ -38,6 +40,7 @@
expat
freetype
gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+
+ gfl1.0
fdl1.3+
opl1.0+
isc
@@ -135,6 +138,16 @@ at URI, which may be a file:// URI pointing the package's tree."
"http://directory.fsf.org/wiki/License:CC0"
"http://www.gnu.org/licenses/license-list.html#CC0"))
+(define cc-by-sa4.0
+ (license "CC-BY-SA 4.0"
+ "http://creativecommons.org/licenses/by-sa/4.0/"
+ "Creative Commons Attribution-ShareAlike 4.0 International"))
+
+(define cc-by3.0
+ (license "CC-BY 3.0"
+ "http://creativecommons.org/licenses/by/3.0/"
+ "Creative Commons Attribution 3.0 Unported"))
+
(define cddl1.0
(license "CDDL 1.0"
"http://directory.fsf.org/wiki/License:CDDLv1.0"
@@ -211,6 +224,13 @@ at URI, which may be a file:// URI pointing the package's tree."
"https://www.gnu.org/licenses/gpl.html"
"https://www.gnu.org/licenses/license-list#GNUGPLv3"))
+;; The “GUST font license” is legally equivalent to LPPL v1.3c as it only
+;; extends the LPPL with an optional request.
+(define gfl1.0
+ (license "GUST font license 1.0"
+ "http://www.gust.org.pl/projects/e-foundry/licenses/GUST-FONT-LICENSE.txt"
+ "https://www.gnu.org/licenses/license-list#LPPL-1.3a"))
+
(define fdl1.3+
(license "FDL 1.3+"
"https://www.gnu.org/licenses/fdl.html"
diff --git a/guix/monads.scm b/guix/monads.scm
index 61cd533bf4..0b0ad239de 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -239,10 +239,10 @@ CONDITION is true, return *unspecified* in the current monad."
(identifier? #'id)
;; Slow path: Return a closure-returning procedure (we don't
;; guarantee (eq? LIFTN LIFTN), but that's fine.)
- (lambda (liftn proc monad)
- (lambda (args ...)
- (with-monad monad
- (return (proc args ...))))))))))))
+ #'(lambda (proc monad)
+ (lambda (args ...)
+ (with-monad monad
+ (return (proc args ...))))))))))))
(define-lift lift0 ())
(define-lift lift1 (a))
diff --git a/guix/packages.scm b/guix/packages.scm
index da4940981d..49c6b44884 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -93,6 +94,8 @@
package-output
package-grafts
+ transitive-input-references
+
%supported-systems
%hurd-systems
%hydra-supported-systems
@@ -604,6 +607,18 @@ for the host system (\"native inputs\"), and not target inputs."
recursively."
(transitive-inputs (package-propagated-inputs package)))
+(define (transitive-input-references alist inputs)
+ "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
+in INPUTS and their transitive propagated inputs."
+ (define label
+ (match-lambda
+ ((label . _)
+ label)))
+
+ (map (lambda (input)
+ `(assoc-ref ,alist ,(label input)))
+ (transitive-inputs inputs)))
+
(define-syntax define-memoized/v
(lambda (form)
"Define a memoized single-valued unary procedure with docstring.
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index d593b5a8a7..ab2a39b1f8 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -25,6 +25,7 @@
#:use-module (guix utils)
#:use-module (guix monads)
#:use-module (guix gexp)
+ #:autoload (guix http-client) (http-fetch http-get-error?)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
@@ -42,6 +43,45 @@
guix-build))
+(define %default-log-urls
+ ;; Default base URLs for build logs.
+ '("http://hydra.gnu.org/log"))
+
+;; XXX: The following procedure cannot be in (guix store) because of the
+;; dependency on (guix derivations).
+(define* (log-url store file #:key (base-urls %default-log-urls))
+ "Return a URL under one of the BASE-URLS where a build log for FILE can be
+found. Return #f if no build log was found."
+ (define (valid-url? url)
+ ;; Probe URL and return #t if it is accessible.
+ (guard (c ((http-get-error? c) #f))
+ (close-port (http-fetch url #:buffered? #f))
+ #t))
+
+ (define (find-url file)
+ (let ((base (basename file)))
+ (any (lambda (base-url)
+ (let ((url (string-append base-url "/" base)))
+ (and (valid-url? url) url)))
+ base-urls)))
+
+ (cond ((derivation-path? file)
+ (catch 'system-error
+ (lambda ()
+ ;; Usually we'll have more luck with the output file name since
+ ;; the deriver that was used by the server could be different, so
+ ;; try one of the output file names.
+ (let ((drv (call-with-input-file file read-derivation)))
+ (or (find-url (derivation->output-path drv))
+ (find-url file))))
+ (lambda args
+ ;; As a last resort, try the .drv.
+ (if (= ENOENT (system-error-errno args))
+ (find-url file)
+ (apply throw args)))))
+ (else
+ (find-url file))))
+
(define (register-root store paths root)
"Register ROOT as an indirect GC root for all of PATHS."
(let* ((root (string-append (canonicalize-path (dirname root))
@@ -457,6 +497,11 @@ arguments with packages that use the specified source."
(list %default-options)))
(store (open-connection))
(drv (options->derivations store opts))
+ (urls (map (cut string-append <> "/log")
+ (if (assoc-ref opts 'substitutes?)
+ (or (assoc-ref opts 'substitute-urls)
+ %default-substitute-urls)
+ '())))
(roots (filter-map (match-lambda
(('gc-root . root) root)
(_ #f))
@@ -470,7 +515,9 @@ arguments with packages that use the specified source."
(cond ((assoc-ref opts 'log-file?)
(for-each (lambda (file)
- (let ((log (log-file store file)))
+ (let ((log (or (log-file store file)
+ (log-url store file
+ #:base-urls urls))))
(if log
(format #t "~a~%" log)
(leave (_ "no build log for '~a'~%")
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 475f054571..2b671be131 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -39,6 +39,16 @@
%bag-emerged-node-type
%derivation-node-type
%reference-node-type
+ %node-types
+
+ node-type
+ node-type?
+ node-type-identifier
+ node-type-label
+ node-type-edges
+ node-type-convert
+ node-type-name
+ node-type-description
%graphviz-backend
graph-backend?
@@ -370,6 +380,9 @@ given BACKEND. Use NODE-TYPE to traverse the DAG."
(lambda (opt name arg result)
(list-node-types)
(exit 0)))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression arg result)))
(option '(#\h "help") #f #f
(lambda args
(show-help)
@@ -387,6 +400,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
-t, --type=TYPE represent nodes of the given TYPE"))
(display (_ "
--list-types list the available graph types"))
+ (display (_ "
+ -e, --expression=EXPR consider the package EXPR evaluates to"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -407,12 +422,14 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
(with-error-handling
(let* ((opts (parse-command-line args %options
(list %default-options)))
- (specs (filter-map (match-lambda
- (('argument . spec) spec)
- (_ #f))
- opts))
(type (assoc-ref opts 'node-type))
- (packages (map specification->package specs)))
+ (packages (filter-map (match-lambda
+ (('argument . spec)
+ (specification->package spec))
+ (('expression . exp)
+ (read/eval-package-expression exp))
+ (_ #f))
+ opts)))
(with-store store
(run-with-store store
(mlet %store-monad ((nodes (mapm %store-monad
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 6cd762a537..7b29794e8f 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -73,7 +73,7 @@ rather than \\n."
;;; Entry point.
;;;
-(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem"))
+(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
new file mode 100644
index 0000000000..f11fa1004f
--- /dev/null
+++ b/guix/scripts/import/cran.scm
@@ -0,0 +1,92 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 import cran)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix import cran)
+ #:use-module (guix scripts import)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:export (guix-import-cran))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (_ "Usage: guix import cran PACKAGE-NAME
+Import and convert the CRAN package for PACKAGE-NAME.\n"))
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix import cran")))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-cran . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((package-name)
+ (let ((sexp (cran->guix-package package-name)))
+ (unless sexp
+ (leave (_ "failed to download description for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 14ac8cba81..2a618c9451 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -24,6 +24,7 @@
#:use-module (guix download)
#:use-module (guix ftp-client)
#:use-module (guix packages)
+ #:use-module (guix licenses)
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (guix utils)
@@ -56,7 +57,15 @@
check-derivation
check-home-page
check-source
- check-formatting))
+ check-license
+ check-formatting
+
+ %checkers
+ lint-checker
+ lint-checker?
+ lint-checker-name
+ lint-checker-description
+ lint-checker-check))
;;;
@@ -511,6 +520,16 @@ descriptions maintained upstream."
(format #f (_ "failed to create derivation: ~s~%")
args)))))
+(define (check-license package)
+ "Warn about type errors of the 'license' field of PACKAGE."
+ (match (package-license package)
+ ((or (? license?)
+ ((? license?) ...))
+ #t)
+ (x
+ (emit-warning package (_ "invalid license field")
+ 'license))))
+
;;;
;;; Source code formatting.
@@ -613,6 +632,13 @@ them for PACKAGE."
(description "Validate home-page URLs")
(check check-home-page))
(lint-checker
+ (name 'license)
+ ;; TRANSLATORS: <license> is the name of a data type and must not be
+ ;; translated.
+ (description "Make sure the 'license' field is a <license> \
+or a list thereof")
+ (check check-license))
+ (lint-checker
(name 'source)
(description "Validate source URLs")
(check check-source))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index e3bcac8047..cc96355947 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -151,7 +151,7 @@ PATH-INFO. The narinfo is signed with KEY."
(references (string-join
(map basename (path-info-references path-info))
" "))
- (deriver (path-info-deriver path-info))
+ (deriver (path-info-deriver path-info))
(base-info (format #f
"StorePath: ~a
URL: ~a
@@ -162,12 +162,21 @@ References: ~a~%"
store-path url hash size references))
;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation.
- (info (if (string-null? deriver)
- base-info
- (let ((drv (load-derivation deriver)))
- (format #f "~aSystem: ~a~%Deriver: ~a~%"
- base-info (derivation-system drv)
- (basename deriver)))))
+ (info (if (string-null? deriver)
+ base-info
+ (catch 'system-error
+ (lambda ()
+ (let ((drv (load-derivation deriver)))
+ (format #f "~aSystem: ~a~%Deriver: ~a~%"
+ base-info (derivation-system drv)
+ (basename deriver))))
+ (lambda args
+ ;; DERIVER might be missing, but that's fine:
+ ;; it's only used for <substitutable> where it's
+ ;; optional. 'System' is currently unused.
+ (if (= ENOENT (system-error-errno args))
+ base-info
+ (apply throw args))))))
(signature (base64-encode-string
(canonical-sexp->string (signed-string info)))))
(format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index e6ed8d23eb..e8459e5ffb 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -43,7 +43,7 @@
(define %snapshot-url
;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
- "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
+ "http://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
)
(define-syntax-rule (with-environment-variable variable value body ...)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 28519d78e2..e7980a97b0 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -149,7 +149,7 @@ values: 'interactive' (default), 'always', and 'never'."
port-sha256)))
(update-package-source package version hash)))
(warning (_ "~a: version ~a could not be \
-downloaded and authenticated; not updating")
+downloaded and authenticated; not updating~%")
(package-name package) version)))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 95aae2a372..e908bc997e 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -703,7 +703,7 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
;;;
(define (display-narinfo-data narinfo)
- "Write to the current output port the contents of NARINFO is the format
+ "Write to the current output port the contents of NARINFO in the format
expected by the daemon."
(format #t "~a\n~a\n~a\n"
(narinfo-path narinfo)
diff --git a/guix/ui.scm b/guix/ui.scm
index a6d4fd10cf..ca5b844a43 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -2,7 +2,8 @@
;;; 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 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -45,6 +46,9 @@
#:use-module (ice-9 regex)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
+ #:use-module (texinfo)
+ #:use-module (texinfo plain-text)
+ #:use-module (texinfo string-utils)
#:export (_
N_
P_
@@ -69,6 +73,7 @@
switch-symlinks
config-directory
fill-paragraph
+ package-description-string
string->recutils
package->recutils
package-specification->name+version+output
@@ -77,6 +82,7 @@
args-fold*
parse-command-line
run-guix-command
+ run-guix
program-name
guix-warning-port
warning
@@ -98,7 +104,15 @@
(define _ (cut gettext <> %gettext-domain))
(define N_ (cut ngettext <> <> <> %gettext-domain))
-(define P_ (cut gettext <> %package-text-domain))
+
+(define (P_ msgid)
+ "Return the translation of the package description or synopsis MSGID."
+ ;; Descriptions/synopses might occasionally be empty strings, even if that
+ ;; is something we try to avoid. Since (gettext "") can return a non-empty
+ ;; string, explicitly check for that case.
+ (if (string-null? msgid)
+ msgid
+ (gettext msgid %package-text-domain)))
(define-syntax-rule (define-diagnostic name prefix)
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
@@ -766,6 +780,28 @@ converted to a space; sequences of more than one line break are preserved."
;;; Packages.
;;;
+(define %text-width
+ (make-parameter (or (and=> (getenv "WIDTH") string->number)
+ 80)))
+
+(set! (@@ (texinfo plain-text) wrap*)
+ ;; XXX: Monkey patch this private procedure to let 'package->recutils'
+ ;; parameterize the fill of description field correctly.
+ (lambda strings
+ (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
+ (fill-string (string-concatenate strings)
+ #:line-width (%text-width) #:initial-indent indent
+ #:subsequent-indent indent))))
+
+(define (texi->plain-text str)
+ "Return a plain-text representation of texinfo fragment STR."
+ (stexi->plain-text (texi-fragment->stexi str)))
+
+(define (package-description-string package)
+ "Return a plain-text representation of PACKAGE description field."
+ (and=> (package-description package)
+ (compose texi->plain-text P_)))
+
(define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
@@ -778,18 +814,9 @@ followed by \"+ \", which makes for a valid multi-line field value in the
'()
str)))
-(define* (package->recutils p port
- #:optional (width (or (and=> (getenv "WIDTH")
- string->number)
- 80)))
+(define* (package->recutils p port #:optional (width (%text-width)))
"Write to PORT a `recutils' record of package P, arranging to fit within
WIDTH columns."
- (define (description->recutils str)
- (let ((str (P_ str)))
- (string->recutils
- (fill-paragraph str width
- (string-length "description: ")))))
-
(define (dependencies->recutils packages)
(let ((list (string-join (map package-full-name
(sort packages package<?)) " ")))
@@ -833,9 +860,15 @@ WIDTH columns."
(chr chr))
(or (and=> (package-synopsis p) P_)
"")))
- (format port "description: ~a~%"
- (and=> (package-description p) description->recutils))
- (newline port))
+ (format port "~a~2%"
+ (string->recutils
+ (string-trim-right
+ (parameterize ((%text-width width))
+ (texi->plain-text
+ (string-append "description: "
+ (or (and=> (package-description p) P_)
+ ""))))
+ #\newline))))
(define (string->generations str)
"Return the list of generations matching a pattern in STR. This function
@@ -1032,31 +1065,37 @@ found."
(parameterize ((program-name command))
(apply command-main args))))
+(define (run-guix . args)
+ "Run the 'guix' command defined by command line ARGS.
+Unlike 'guix-main', this procedure assumes that locale, i18n support,
+and signal handling has already been set up."
+ (define option? (cut string-prefix? "-" <>))
+
+ (match args
+ (()
+ (format (current-error-port)
+ (_ "guix: missing command name~%"))
+ (show-guix-usage))
+ ((or ("-h") ("--help"))
+ (show-guix-help))
+ (("--version")
+ (show-version-and-exit "guix"))
+ (((? option? o) args ...)
+ (format (current-error-port)
+ (_ "guix: unrecognized option '~a'~%") o)
+ (show-guix-usage))
+ (("help" args ...)
+ (show-guix-help))
+ ((command args ...)
+ (apply run-guix-command
+ (string->symbol command)
+ args))))
+
(define guix-warning-port
(make-parameter (current-warning-port)))
(define (guix-main arg0 . args)
(initialize-guix)
- (let ()
- (define (option? str) (string-prefix? "-" str))
- (match args
- (()
- (format (current-error-port)
- (_ "guix: missing command name~%"))
- (show-guix-usage))
- ((or ("-h") ("--help"))
- (show-guix-help))
- (("--version")
- (show-version-and-exit "guix"))
- (((? option? o) args ...)
- (format (current-error-port)
- (_ "guix: unrecognized option '~a'~%") o)
- (show-guix-usage))
- (("help" args ...)
- (show-guix-help))
- ((command args ...)
- (apply run-guix-command
- (string->symbol command)
- args)))))
+ (apply run-guix args))
;;; ui.scm ends here