summaryrefslogtreecommitdiff
path: root/guix/build
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/build
parentab20c2cc33063ce783515d8ae7899ec7e2ca6f96 (diff)
parent610075f7c94c80b8321887b7ccf8bb1a7edd2b8e (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-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
5 files changed, 200 insertions, 33 deletions
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