From 3d90fa982b489cea2ccd2c0b14d63d45923e294a Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 15 May 2017 20:08:57 +0530 Subject: build-system: Add 'font-build-system'. * Makefile.am (MODULES): Add 'guix/build-system/font.scm' and 'guix/build/font-build-system.scm'. * guix/build-system/font.scm: New file. * guix/build/font-build-system.scm: New file. * doc/guix.texi (Build Systems): Add 'font-build-system'. --- guix/build-system/font.scm | 130 +++++++++++++++++++++++++++++++++++++++ guix/build/font-build-system.scm | 71 +++++++++++++++++++++ 2 files changed, 201 insertions(+) create mode 100644 guix/build-system/font.scm create mode 100644 guix/build/font-build-system.scm (limited to 'guix') 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 +;;; +;;; 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 . + +(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/font-build-system.scm b/guix/build/font-build-system.scm new file mode 100644 index 0000000000..cca1e93f0f --- /dev/null +++ b/guix/build/font-build-system.scm @@ -0,0 +1,71 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Arun Isaac +;;; +;;; 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 . + +(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$")) + (for-each (cut install-file <> (string-append fonts "/opentype")) + (find-files source "\\.otf$")) + #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 -- cgit v1.2.3 From aa401f9ba6410095370ce0c4e5a01c02203a2b9f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 May 2017 15:49:11 +0200 Subject: syscalls: Add 'thread-name' and 'set-thread-name'. * guix/build/syscalls.scm (PR_SET_NAME, PR_GET_NAME) (%max-thread-name-length): New variables. (%prctl, set-thread-name, thread-name): New procedures. * tests/syscalls.scm ("set-thread-name"): New test. --- guix/build/syscalls.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 8 ++++++++ 2 files changed, 57 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0529c228a5..52439afd44 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -69,6 +69,9 @@ pivot-root fcntl-flock + set-thread-name + thread-name + CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID CLONE_NEWNS @@ -882,6 +885,52 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) + +;;; +;;; 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) ; +(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/tests/syscalls.scm b/tests/syscalls.scm index 8db45b41b6..e20f0600bc 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -266,6 +266,14 @@ (close-port file) result))))))))) +(test-equal "set-thread-name" + "Syscall Test" + (let ((name (thread-name))) + (set-thread-name "Syscall Test") + (let ((new-name (thread-name))) + (set-thread-name name) + new-name))) + (test-assert "all-network-interface-names" (match (all-network-interface-names) (((? string? names) ..1) -- cgit v1.2.3 From 8902d0f2676a500c785044fff54b8675f96cef6d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 May 2017 16:09:32 +0200 Subject: scripts: Set thread names. This allows 'guix publish' threads as well as 'guix substitute' and 'guix offload' processes to be properly labeled in 'top', 'pstree', etc. * guix/workers.scm (worker-thunk): Add #:thread-name parameter and honor it. (make-pool): Likewise. * guix/scripts/publish.scm (http-write): Add calls to 'set-thread-name' in bodies of 'call-with-new-thread'. (guix-publish): Call 'set-thread-name'. Pass #:thread-name to 'make-pool'. * guix/scripts/offload.scm (guix-offload): Call 'set-thread-name'. * guix/scripts/substitute.scm (guix-substitute): Likewise. --- guix/scripts/offload.scm | 4 +++- guix/scripts/publish.scm | 11 ++++++++++- guix/scripts/substitute.scm | 4 ++++ guix/workers.scm | 18 ++++++++++++++---- 4 files changed, 31 insertions(+), 6 deletions(-) (limited to 'guix') 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..4ee15ba67d 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) @@ -1015,6 +1017,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/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) -- cgit v1.2.3 From 27fd13c3c2701204f48fe0012438edbb91957dfc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 30 May 2017 10:11:13 +0200 Subject: download: Work around GnuTLS bug with UTF-8 certificate file names. Reported by Mark H Weaver at . * guix/build/download.scm (set-certificate-credentials-x509-trust-file!*): New procedure. (make-credendials-with-ca-trust-files): Use it instead of 'set-certificate-credentials-x509-trust-file!'. --- guix/build/download.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') 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 +." + (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 '())) -- cgit v1.2.3 From 151cb9738a1903670acfee8cc28b5a2e441172ce Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 25 May 2017 16:58:23 +0100 Subject: git-download: Fix 'git-predicate' to use absolute paths. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit git ls-files will return paths relative to the repository directory. This commit prepends the repository directory to those paths when calling lstat, such that 'git-predicate' works if the current working directory is not the repository directory. * guix/git-download.scm (git-predicate): Prepend repository directory to the file path when calling lstat. Signed-off-by: Ludovic Courtès --- guix/git-download.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') 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))) -- cgit v1.2.3 From 046175cd4eae314f6e5d3d614efdeb573e8199df Mon Sep 17 00:00:00 2001 From: Alex Griffin Date: Wed, 31 May 2017 13:01:42 -0500 Subject: build: font: Support font collection files. * guix/build/font-build-system.scm (install): Support TrueType Collection (TTC) and OpenType Collection (OTC) files. Signed-off-by: Danny Milosavljevic --- guix/build/font-build-system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm index cca1e93f0f..f2a646f6f4 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac +;;; Copyright © 2017 Alex Griffin ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,9 +51,9 @@ archive, or a font file." (source (getcwd)) (fonts (string-append out "/share/fonts"))) (for-each (cut install-file <> (string-append fonts "/truetype")) - (find-files source "\\.ttf$")) + (find-files source "\\.(ttf|ttc)$")) (for-each (cut install-file <> (string-append fonts "/opentype")) - (find-files source "\\.otf$")) + (find-files source "\\.(otf|otc)$")) #t)) (define %standard-phases -- cgit v1.2.3 From ef51ac21eec28de3b0fb693f88be5f3c494d464a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 09:55:56 +0200 Subject: derivations: 'substitution-oracle' returns a . * guix/derivations.scm (substitution-oracle): Use 'substitution-path-info' instead of 'substitution-paths'. Turn SUBST into a vhash from path to . Change the returned procedure to provide a instead of a Boolean. * tests/derivations.scm ("substitution-oracle and #:substitute? #f"): Mock 'substitutable-path-info' instead of 'substitutable-paths'. --- guix/derivations.scm | 16 ++++++++++++---- tests/derivations.scm | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 9aaab05ecb..5e457f1893 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,8 +319,15 @@ 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 diff --git a/tests/derivations.scm b/tests/derivations.scm index cabbf7b951..d4e1a32bb6 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -919,7 +919,7 @@ (set! query paths) '()) - (mock ((guix store) substitutable-paths + (mock ((guix store) substitutable-path-info record-substitutable-path-query) (let ((pred (substitution-oracle store (list drv)))) -- cgit v1.2.3 From 2dc98729afb62e48b5866f599df9a9274d440686 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 11:06:42 +0200 Subject: derivations: 'derivation-prerequisites-to-build' returns . * guix/derivations.scm (derivation-prerequisites-to-build): Rename #:substitutable? to #:substitutable-info. [derivation-substitutable?]: Rename to... [derivation-substitutable-info]: ... this. Return a list of . Second return value is now a list of instead of a list of strings. * guix/ui.scm (show-what-to-build)[substitutable?]: Rename to... [substitutable-info]: ... this. Adjust to new 'derivation-prerequisites-to-build' return value type. * tests/derivations.scm ("derivation-prerequisites-to-build and substitutes"): Adjust. ("derivation-prerequisites-to-build and substitutes, local build"): Likewise. --- guix/derivations.scm | 31 ++++++++++++++++++------------- guix/ui.scm | 25 +++++++++++++++---------- tests/derivations.scm | 6 +++--- 3 files changed, 36 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 5e457f1893..b9ad9c9e8c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -334,13 +334,13 @@ substituter many times." (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 <>)) @@ -351,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. @@ -359,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 + (substitute '())) ;list of (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 @@ -389,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/ui.scm b/guix/ui.scm index 9e0fa26d19..9b64648964 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -588,7 +588,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 +600,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 +608,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,11 +623,13 @@ 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. (if dry-run? @@ -640,7 +643,8 @@ report what is prerequisites are available for download." (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) - (null? download) download)) + (null? download) + (map substitutable-path download))) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" @@ -651,7 +655,8 @@ report what is prerequisites are available for download." (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) - (null? download) download))) + (null? download) + (map substitutable-path download)))) (pair? build))) (define show-what-to-build* diff --git a/tests/derivations.scm b/tests/derivations.scm index d4e1a32bb6..f3aad1b906 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -831,10 +831,10 @@ (derivation-prerequisites-to-build store drv)) ((build* download*) (derivation-prerequisites-to-build store drv - #:substitutable? + #:substitutable-info (const #f)))) (and (null? build) - (equal? download (list output)) + (equal? (map substitutable-path download) (list output)) (null? download*) (null? build*)))))) @@ -879,7 +879,7 @@ ;; See . (and (null? build) (match download - (((? string? item)) + (((= substitutable-path item)) (string=? item (derivation->output-path drv)))))))))) (test-assert "derivation-prerequisites-to-build in 'check' mode" -- cgit v1.2.3 From d9bad2f08296fa73b967973aa6648d24c100980f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 15:06:28 +0200 Subject: ui: 'show-what-to-build' displays how much will be downloaded. * guix/ui.scm (show-what-to-build)[download-size] [display-download-size?]: New variables. Add cases for when DISPLAY-DOWNLOAD-SIZE? is true. --- guix/ui.scm | 49 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9b64648964..04700a6d20 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -632,6 +632,15 @@ report what is prerequisites are available for download." download)))) download))) ;; TODO: Show the installed size of 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) @@ -639,24 +648,40 @@ 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) - (map substitutable-path 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) - (map substitutable-path 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))))) (pair? build))) (define show-what-to-build* -- cgit v1.2.3 From 65f224dc8d9568232baa07f28474ba5c90f07428 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 15:23:51 +0200 Subject: syscalls: Provide 'free-disk-space'. * guix/build/syscalls.scm (free-disk-space): New procedure. * guix/scripts/gc.scm (guix-gc)[ensure-free-space]: Use it instead of 'statfs'. --- guix/build/syscalls.scm | 7 +++++++ guix/scripts/gc.scm | 8 +++----- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 52439afd44..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! @@ -697,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. 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 +;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; 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)) -- cgit v1.2.3 From dcfc6f213b287778b5dc6ea4a8d34f5e1368752b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 15:26:21 +0200 Subject: ui: 'show-what-to-build' warns when we don't have enough disk space. * guix/ui.scm (check-available-space): New procedure. (show-what-to-build): Compute 'installed-size' and call 'check-available-space'. --- guix/ui.scm | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 04700a6d20..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))) @@ -631,7 +643,9 @@ report what is prerequisites are available for download." 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)) @@ -682,6 +696,9 @@ report what is prerequisites are available for download." (length download)) (null? download) (map substitutable-path download))))) + + (check-available-space installed-size) + (pair? build))) (define show-what-to-build* -- cgit v1.2.3 From 36a9d3f10da3811c66c3e379e20381728c368a3b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 May 2017 15:28:07 +0200 Subject: substitute: Do not display the installed size. * guix/scripts/substitute.scm (process-substitution): Do not show the installed size in the "Downloading" message. --- guix/scripts/substitute.scm | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 4ee15ba67d..71f30030b6 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -874,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 -- cgit v1.2.3 From 8b8bf88f2155b3542436e350e1db279f31d69465 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sat, 3 Jun 2017 04:38:14 +0200 Subject: licenses: Add CC-BY 4.0. * guix/licenses.scm (cc-by4.0): New variable. --- guix/licenses.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') 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 ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2017 Petter +;;; Copyright © 2017 Marius Bakke ;;; ;;; 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/" -- cgit v1.2.3