summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2017-06-03 17:51:21 +0200
committerMarius Bakke <mbakke@fastmail.com>2017-06-03 17:51:21 +0200
commitd0c45d2d822fdf31b8a8edc73fe7be12a0676705 (patch)
tree04ae8108a67013fce99273db4582c29e7845f0a7 /guix
parent0b70f7d557181febd80b16c8e3a03887df3871af (diff)
parentac1560f18c25e4312c1f32c001405c176daa1764 (diff)
Merge branch 'master' into core-updates
Conflicts: gnu/packages/image.scm (incorporated libtiff graft)
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/font.scm130
-rw-r--r--guix/build/download.scm9
-rw-r--r--guix/build/font-build-system.scm72
-rw-r--r--guix/build/syscalls.scm56
-rw-r--r--guix/derivations.scm47
-rw-r--r--guix/git-download.scm3
-rw-r--r--guix/licenses.scm9
-rw-r--r--guix/scripts/gc.scm8
-rw-r--r--guix/scripts/offload.scm4
-rw-r--r--guix/scripts/publish.scm11
-rwxr-xr-xguix/scripts/substitute.scm14
-rw-r--r--guix/ui.scm87
-rw-r--r--guix/workers.scm18
13 files changed, 408 insertions, 60 deletions
diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm
new file mode 100644
index 0000000000..f448c302c2
--- /dev/null
+++ b/guix/build-system/font.scm
@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.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 font)
+ #: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)
+ #:export (%font-build-system-modules
+ font-build
+ font-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for fonts. This is implemented as an extension of
+;; 'gnu-build-system'.
+;;
+;; Code:
+
+(define %font-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build font-build-system)
+ ,@%gnu-build-system-modules))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs))
+
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+ ,(list "tar" (module-ref (resolve-interface '(gnu packages base)) 'tar))
+ ,(list "unzip" (module-ref (resolve-interface '(gnu packages zip)) 'unzip))
+ ,@(let ((compression (resolve-interface '(gnu packages compression))))
+ (map (match-lambda
+ ((name package)
+ (list name (module-ref compression package))))
+ `(("gzip" gzip)
+ ("bzip2" bzip2)
+ ("xz" xz))))))
+ (build-inputs native-inputs)
+ (outputs outputs)
+ (build font-build)
+ (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define* (font-build store name inputs
+ #:key source
+ (tests? #t)
+ (test-target "test")
+ (configure-flags ''())
+ (phases '(@ (guix build font-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %font-build-system-modules)
+ (modules '((guix build font-build-system)
+ (guix build utils))))
+ "Build SOURCE with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (font-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
+ #:test-target ,test-target
+ #:tests? ,tests?
+ #: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 font-build-system
+ (build-system
+ (name 'font)
+ (description "The build system for font packages")
+ (lower lower)))
+
+;;; font.scm ends here
diff --git a/guix/build/download.scm b/guix/build/download.scm
index ce4708a873..6ef6233346 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -296,6 +296,13 @@ session record port using PORT as its underlying communication port."
(make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
(getenv "SSL_CERT_DIR")))) ;like OpenSSL
+(define (set-certificate-credentials-x509-trust-file!* cred file format)
+ "Like 'set-certificate-credentials-x509-trust-file!', but without the file
+name decoding bug described at
+<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
+ (let ((data (call-with-input-file file get-bytevector-all)))
+ (set-certificate-credentials-x509-trust-data! cred data format)))
+
(define (make-credendials-with-ca-trust-files directory)
"Return certificate credentials with X.509 authority certificates read from
DIRECTORY. Those authority certificates are checked when
@@ -309,7 +316,7 @@ DIRECTORY. Those authority certificates are checked when
(let ((file (string-append directory "/" file)))
;; Protect against dangling symlinks.
(when (file-exists? file)
- (set-certificate-credentials-x509-trust-file!
+ (set-certificate-credentials-x509-trust-file!*
cred file
x509-certificate-format/pem))))
(or files '()))
diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm
new file mode 100644
index 0000000000..f2a646f6f4
--- /dev/null
+++ b/guix/build/font-build-system.scm
@@ -0,0 +1,72 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2017 Alex Griffin <a@ajgrf.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 build font-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%standard-phases
+ font-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the build procedure for font packages.
+;;
+;; Code:
+
+(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack))
+
+(define* (unpack #:key source #:allow-other-keys)
+ "Unpack SOURCE into the build directory. SOURCE may be a compressed
+archive, or a font file."
+ (if (any (cut string-suffix? <> source)
+ (list ".ttf" ".otf"))
+ (begin
+ (mkdir "source")
+ (chdir "source")
+ (copy-file source (strip-store-file-name source))
+ #t)
+ (gnu:unpack #:source source)))
+
+(define* (install #:key outputs #:allow-other-keys)
+ "Install the package contents."
+ (let* ((out (assoc-ref outputs "out"))
+ (source (getcwd))
+ (fonts (string-append out "/share/fonts")))
+ (for-each (cut install-file <> (string-append fonts "/truetype"))
+ (find-files source "\\.(ttf|ttc)$"))
+ (for-each (cut install-file <> (string-append fonts "/opentype"))
+ (find-files source "\\.(otf|otc)$"))
+ #t))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (replace 'unpack unpack)
+ (delete 'configure)
+ (delete 'check)
+ (delete 'build)
+ (replace 'install install)))
+
+(define* (font-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given font package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; font-build-system.scm ends here
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0529c228a5..2def2a108f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -62,6 +62,7 @@
file-system-fragment-size
file-system-mount-flags
statfs
+ free-disk-space
processes
mkdtemp!
@@ -69,6 +70,9 @@
pivot-root
fcntl-flock
+ set-thread-name
+ thread-name
+
CLONE_CHILD_CLEARTID
CLONE_CHILD_SETTID
CLONE_NEWNS
@@ -694,6 +698,12 @@ mounted at FILE."
(list file (strerror err))
(list err)))))))
+(define (free-disk-space file)
+ "Return the free disk space, in bytes, on the file system that hosts FILE."
+ (let ((fs (statfs file)))
+ (* (file-system-block-size fs)
+ (file-system-blocks-available fs))))
+
;;;
;;; Containers.
@@ -884,6 +894,52 @@ exception if it's already taken."
;;;
+;;; Miscellaneous, aka. 'prctl'.
+;;;
+
+(define %prctl
+ ;; Should it win the API contest against 'ioctl'? You tell us!
+ (syscall->procedure int "prctl"
+ (list int unsigned-long unsigned-long
+ unsigned-long unsigned-long)))
+
+(define PR_SET_NAME 15) ;<linux/prctl.h>
+(define PR_GET_NAME 16)
+
+(define %max-thread-name-length
+ ;; Maximum length in bytes of the process name, including the terminating
+ ;; zero.
+ 16)
+
+(define (set-thread-name name)
+ "Set the name of the calling thread to NAME. NAME is truncated to 15
+bytes."
+ (let ((ptr (string->pointer name)))
+ (let-values (((ret err)
+ (%prctl PR_SET_NAME
+ (pointer-address ptr) 0 0 0)))
+ (unless (zero? ret)
+ (throw 'set-process-name "set-process-name"
+ "set-process-name: ~A"
+ (list (strerror err))
+ (list err))))))
+
+(define (thread-name)
+ "Return the name of the calling thread as a string."
+ (let ((buf (make-bytevector %max-thread-name-length)))
+ (let-values (((ret err)
+ (%prctl PR_GET_NAME
+ (pointer-address (bytevector->pointer buf))
+ 0 0 0)))
+ (if (zero? ret)
+ (bytes->string (bytevector->u8-list buf))
+ (throw 'process-name "process-name"
+ "process-name: ~A"
+ (list (strerror err))
+ (list err))))))
+
+
+;;;
;;; Network interfaces.
;;;
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 9aaab05ecb..b9ad9c9e8c 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -271,13 +271,14 @@ result is the set of prerequisites of DRV not already in valid."
(define* (substitution-oracle store drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
-returns #t if it's substitutable and #f otherwise. The returned procedure
+returns a 'substitutable?' if it's substitutable and #f otherwise.
+The returned procedure
knows about all substitutes for all the derivations listed in DRV, *except*
those that are already valid (that is, it won't bother checking whether an
item is substitutable if it's already on disk); it also knows about their
prerequisites, unless they are themselves substitutable.
-Creating a single oracle (thus making a single 'substitutable-paths' call) and
+Creating a single oracle (thus making a single 'substitutable-path-info' call) and
reusing it is much more efficient than calling 'has-substitutes?' or similar
repeatedly, because it avoids the costs associated with launching the
substituter many times."
@@ -318,21 +319,28 @@ substituter many times."
(cons* self (dependencies drv) result)))))
'()
drv))))
- (subst (list->set (substitutable-paths store paths))))
- (cut set-contains? subst <>)))
+ (subst (fold (lambda (subst vhash)
+ (vhash-cons (substitutable-path subst) subst
+ vhash))
+ vlist-null
+ (substitutable-path-info store paths))))
+ (lambda (item)
+ (match (vhash-assoc item subst)
+ (#f #f)
+ ((key . value) value)))))
(define* (derivation-prerequisites-to-build store drv
#:key
(mode (build-mode normal))
(outputs
(derivation-output-names drv))
- (substitutable?
+ (substitutable-info
(substitution-oracle store
(list drv)
#:mode mode)))
"Return two values: the list of derivation-inputs required to build the
OUTPUTS of DRV and not already available in STORE, recursively, and the list
-of required store paths that can be substituted. SUBSTITUTABLE? must be a
+of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a
one-argument procedure similar to that returned by 'substitution-oracle'."
(define built?
(cut valid-path? store <>))
@@ -343,7 +351,7 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
(define input-substitutable?
;; Return true if and only if all of SUB-DRVS are subsitutable. If at
;; least one is missing, then everything must be rebuilt.
- (compose (cut every substitutable? <>) derivation-input-output-paths))
+ (compose (cut every substitutable-info <>) derivation-input-output-paths))
(define (derivation-built? drv* sub-drvs)
;; In 'check' mode, assume that DRV is not built.
@@ -351,20 +359,24 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
(eq? drv* drv)))
(every built? (derivation-output-paths drv* sub-drvs))))
- (define (derivation-substitutable? drv sub-drvs)
+ (define (derivation-substitutable-info drv sub-drvs)
(and (substitutable-derivation? drv)
- (every substitutable? (derivation-output-paths drv sub-drvs))))
+ (let ((info (filter-map substitutable-info
+ (derivation-output-paths drv sub-drvs))))
+ (and (= (length info) (length sub-drvs))
+ info))))
(let loop ((drv drv)
(sub-drvs outputs)
- (build '())
- (substitute '()))
+ (build '()) ;list of <derivation-input>
+ (substitute '())) ;list of <substitutable>
(cond ((derivation-built? drv sub-drvs)
(values build substitute))
- ((derivation-substitutable? drv sub-drvs)
- (values build
- (append (derivation-output-paths drv sub-drvs)
- substitute)))
+ ((derivation-substitutable-info drv sub-drvs)
+ =>
+ (lambda (substitutables)
+ (values build
+ (append substitutables substitute))))
(else
(let ((build (if (substitutable-derivation? drv)
build
@@ -381,8 +393,9 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
(append (append-map (lambda (input)
(if (and (not (input-built? input))
(input-substitutable? input))
- (derivation-input-output-paths
- input)
+ (map substitutable-info
+ (derivation-input-output-paths
+ input))
'()))
(derivation-inputs drv))
substitute)
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 9f6d20ee38..316835502c 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -146,7 +146,8 @@ absolute file name and STAT is the result of 'lstat'."
(line
(loop (cons line lines))))))
(inodes (map (lambda (file)
- (let ((stat (lstat file)))
+ (let ((stat (lstat
+ (string-append directory "/" file))))
(cons (stat:dev stat) (stat:ino stat))))
files))
(status (close-pipe pipe)))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 8396b1a3c6..6845b89d90 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -11,6 +11,7 @@
;;; Copyright © 2016, 2017 ng0 <ng0@libertad.pw>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Petter <petter@mykolab.ch>
+;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -37,7 +38,8 @@
non-copyleft
bsd-style ;deprecated!
cc0
- cc-by2.0 cc-by3.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0
+ cc-by2.0 cc-by3.0 cc-by4.0
+ cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0
cddl1.0
cecill cecill-b cecill-c
artistic2.0 clarified-artistic
@@ -181,6 +183,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"http://creativecommons.org/licenses/by-sa/2.0/"
"Creative Commons Attribution-ShareAlike 2.0 Generic"))
+(define cc-by4.0
+ (license "CC-BY 4.0"
+ "http://creativecommons.org/licenses/by/4.0/"
+ "Creative Commons Attribution 4.0 Unported"))
+
(define cc-by3.0
(license "CC-BY 3.0"
"http://creativecommons.org/licenses/by/3.0/"
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 221467a108..0a9719d259 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,7 +20,7 @@
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix store)
- #:autoload (guix build syscalls) (statfs)
+ #:autoload (guix build syscalls) (free-disk-space)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@@ -184,9 +184,7 @@ Invoke the garbage collector.\n"))
(define (ensure-free-space store space)
;; Attempt to have at least SPACE bytes available in STORE.
- (let* ((fs (statfs (%store-prefix)))
- (free (* (file-system-block-size fs)
- (file-system-blocks-available fs))))
+ (let ((free (free-disk-space (%store-prefix))))
(if (> free space)
(info (G_ "already ~h bytes available on ~a, nothing to do~%")
free (%store-prefix))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 74c0c5484c..77b340cff6 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -34,7 +34,8 @@
#:select (nar-error? nar-error-file))
#:use-module (guix nar)
#:use-module (guix utils)
- #:use-module ((guix build syscalls) #:select (fcntl-flock))
+ #:use-module ((guix build syscalls)
+ #:select (fcntl-flock set-thread-name))
#:use-module ((guix build utils) #:select (which mkdir-p))
#:use-module (guix ui)
#:use-module (srfi srfi-1)
@@ -641,6 +642,7 @@ machine."
(let ((max-silent-time (string->number max-silent-time))
(build-timeout (string->number build-timeout))
(print-build-trace? (string=? print-build-trace? "1")))
+ (set-thread-name "guix offload")
(parameterize ((%current-system system))
(let loop ((line (read-line)))
(unless (eof-object? line)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c306b809a7..c49c0c3e20 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -58,6 +58,7 @@
#:select (with-atomic-file-output compressed-file?))
#:use-module ((guix build utils)
#:select (dump-port mkdir-p find-files))
+ #:use-module ((guix build syscalls) #:select (set-thread-name))
#:export (%public-key
%private-key
@@ -649,6 +650,7 @@ blocking."
;; thread so that the main thread can keep working in the meantime.
(call-with-new-thread
(lambda ()
+ (set-thread-name "publish nar")
(let* ((response (write-response (sans-content-length response)
client))
(port (begin
@@ -670,6 +672,7 @@ blocking."
;; Send a raw file in a separate thread.
(call-with-new-thread
(lambda ()
+ (set-thread-name "publish file")
(catch 'system-error
(lambda ()
(call-with-input-file (utf8->string body)
@@ -858,10 +861,16 @@ consider using the '--user' option!~%")))
(sockaddr:port address))
(when repl-port
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+
+ ;; Set the name of the main thread.
+ (set-thread-name "guix publish")
+
(with-store store
(run-publish-server socket store
#:cache cache
- #:pool (and cache (make-pool workers))
+ #:pool (and cache (make-pool workers
+ #:thread-name
+ "publish worker"))
#:nar-path nar-path
#:compression compression
#:narinfo-ttl ttl))))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 73d4f6e2eb..71f30030b6 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -39,6 +39,8 @@
. guix:open-connection-for-uri)
close-connection
store-path-abbreviation byte-count->string))
+ #:use-module ((guix build syscalls)
+ #:select (set-thread-name))
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -872,15 +874,7 @@ DESTINATION as a nar file. Verify the substitute against ACL."
(format #t "~a~%" (narinfo-hash narinfo))
(format (current-error-port)
- ;; TRANSLATORS: The second part of this message looks like
- ;; "(4.1MiB installed)"; it shows the size of the package once
- ;; installed.
- (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%")
- (uri->string uri)
- ;; Use the Nar size as an estimate of the installed size.
- (narinfo-size narinfo)
- (and=> (narinfo-size narinfo)
- (cute byte-count->string <>)))
+ (G_ "Downloading ~a...~%") (uri->string uri))
(let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so
@@ -1015,6 +1009,8 @@ default value."
(#f #f)
(locale (false-if-exception (setlocale LC_ALL locale))))
+ (set-thread-name "guix substitute")
+
(with-networking
(with-error-handling ; for signature errors
(match args
diff --git a/guix/ui.scm b/guix/ui.scm
index 9e0fa26d19..5060fd6dc7 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -38,7 +38,8 @@
#:use-module (guix serialization)
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix licenses) #:select (license? license-name))
- #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module ((guix build syscalls)
+ #:select (free-disk-space terminal-columns))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
@@ -581,6 +582,17 @@ error."
(derivation->output-path derivation out-name)))
(derivation-outputs derivation))))
+(define (check-available-space need)
+ "Make sure at least NEED bytes are available in the store. Otherwise emit a
+warning."
+ (let ((free (catch 'system-error
+ (lambda ()
+ (free-disk-space (%store-prefix)))
+ (const #f))))
+ (when (and free (>= need free))
+ (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%")
+ (/ need 1e6) (/ free 1e6) (%store-prefix)))))
+
(define* (show-what-to-build store drv
#:key dry-run? (use-substitutes? #t)
(mode (build-mode normal)))
@@ -588,7 +600,7 @@ error."
derivations listed in DRV using MODE, a 'build-mode' value. Return #t if
there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and
report what is prerequisites are available for download."
- (define substitutable?
+ (define substitutable-info
;; Call 'substitutation-oracle' upfront so we don't end up launching the
;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'.
@@ -600,7 +612,7 @@ report what is prerequisites are available for download."
(or (null? (derivation-outputs drv))
(let ((out (derivation->output-path drv))) ;XXX: assume "out" exists
(or (valid-path? store out)
- (substitutable? out)))))
+ (substitutable-info out)))))
(let*-values (((build download)
(fold2 (lambda (drv build download)
@@ -608,7 +620,8 @@ report what is prerequisites are available for download."
(derivation-prerequisites-to-build
store drv
#:mode mode
- #:substitutable? substitutable?)))
+ #:substitutable-info
+ substitutable-info)))
(values (append b build)
(append d download))))
'() '()
@@ -622,13 +635,26 @@ report what is prerequisites are available for download."
(if use-substitutes?
(delete-duplicates
(append download
- (remove (cut valid-path? store <>)
- (append-map
- substitutable-references
- (substitutable-path-info store
- download)))))
+ (filter-map (lambda (item)
+ (if (valid-path? store item)
+ #f
+ (substitutable-info item)))
+ (append-map
+ substitutable-references
+ download))))
download)))
- ;; TODO: Show the installed size of DOWNLOAD.
+ (define installed-size
+ (reduce + 0 (map substitutable-nar-size download)))
+
+ (define download-size
+ (/ (reduce + 0 (map substitutable-download-size download))
+ 1e6))
+
+ (define display-download-size?
+ ;; Sometimes narinfos lack information about the download size. Only
+ ;; display when we have information for all of DOWNLOAD.
+ (not (any (compose zero? substitutable-download-size) download)))
+
(if dry-run?
(begin
(format (current-error-port)
@@ -636,22 +662,43 @@ report what is prerequisites are available for download."
"~:[The following derivations would be built:~%~{ ~a~%~}~;~]"
(length build))
(null? build) build)
- (format (current-error-port)
- (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
- "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
- (length download))
- (null? download) download))
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]")
+ (null? download)
+ download-size
+ (map substitutable-path download))
+ (format (current-error-port)
+ (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
+ "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
+ (length download))
+ (null? download)
+ (map substitutable-path download))))
(begin
(format (current-error-port)
(N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
"~:[The following derivations will be built:~%~{ ~a~%~}~;~]"
(length build))
(null? build) build)
- (format (current-error-port)
- (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
- "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
- (length download))
- (null? download) download)))
+ (if display-download-size?
+ (format (current-error-port)
+ ;; TRANSLATORS: "MB" is for "megabyte"; it should be
+ ;; translated to the corresponding abbreviation.
+ (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]")
+ (null? download)
+ download-size
+ (map substitutable-path download))
+ (format (current-error-port)
+ (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
+ "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
+ (length download))
+ (null? download)
+ (map substitutable-path download)))))
+
+ (check-available-space installed-size)
+
(pair? build)))
(define show-what-to-build*
diff --git a/guix/workers.scm b/guix/workers.scm
index e3452d249a..846f5e50a9 100644
--- a/guix/workers.scm
+++ b/guix/workers.scm
@@ -23,6 +23,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module ((guix build syscalls) #:select (set-thread-name))
#:export (pool?
make-pool
pool-enqueue!
@@ -60,7 +61,8 @@
(lambda ()
(lock-mutex mutex))))
-(define (worker-thunk mutex condvar pop-queue)
+(define* (worker-thunk mutex condvar pop-queue
+ #:key (thread-name "guix worker"))
"Return the thunk executed by worker threads."
(define (loop)
(match (pop-queue)
@@ -80,11 +82,18 @@
(loop))
(lambda ()
+ (catch 'system-error
+ (lambda ()
+ (set-thread-name thread-name))
+ (const #f))
+
(with-mutex mutex
(loop))))
-(define* (make-pool #:optional (count (current-processor-count)))
- "Return a pool of COUNT workers."
+(define* (make-pool #:optional (count (current-processor-count))
+ #:key (thread-name "guix worker"))
+ "Return a pool of COUNT workers. Use THREAD-NAME as the name of these
+threads as reported by the operating system."
(let* ((mutex (make-mutex))
(condvar (make-condition-variable))
(queue (make-q))
@@ -93,7 +102,8 @@
(worker-thunk mutex condvar
(lambda ()
(and (not (q-empty? queue))
- (q-pop! queue)))))
+ (q-pop! queue)))
+ #:thread-name thread-name))
1+
0))
(threads (map (lambda (proc)