From 7920e187c121977716d3399f5780553ba138f9b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Dec 2017 22:49:08 +0100 Subject: scripts: All commands enable build hooks by default. * guix/scripts/archive.scm (%default-options): Add 'build-hook?'. * guix/scripts/copy.scm (%default-options): Likewise. * guix/scripts/environment.scm (%default-options): Likewise. * guix/scripts/pack.scm (%default-options): Likewise. * guix/scripts/package.scm (%default-options): Likewise. * guix/scripts/pull.scm (%default-options): Likewise. --- guix/scripts/archive.scm | 1 + guix/scripts/copy.scm | 1 + guix/scripts/environment.scm | 1 + guix/scripts/pack.scm | 1 + guix/scripts/package.scm | 3 ++- guix/scripts/pull.scm | 1 + guix/scripts/system.scm | 2 +- 7 files changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index a569848ae3..a359f405fe 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -53,6 +53,7 @@ (define %default-options ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (graft? . #t) (verbosity . 0))) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 9ffffe8ccd..4c85929858 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -150,6 +150,7 @@ (define %options (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (graft? . #t) (verbosity . 0))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e1b7feecfa..d2568e6a7d 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -178,6 +178,7 @@ (define (show-help) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (graft? . #t) (verbosity . 0))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 21fea446a6..a22258d5a6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -262,6 +262,7 @@ (define %default-options `((format . tarball) (system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (graft? . #t) (verbosity . 0) (symlinks . ()) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 0a4a07ae2a..617e102d93 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -360,7 +360,8 @@ (define %default-options ;; Alist of default option values. `((verbosity . 0) (graft? . #t) - (substitutes? . #t))) + (substitutes? . #t) + (build-hook? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index be0c168444..64c2196e03 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -89,6 +89,7 @@ (define %default-options (ref . (branch . "origin/master")) (system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (graft? . #t) (verbosity . 0))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e2ff42693f..d0eacc573c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -942,8 +942,8 @@ (define %default-options ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (graft? . #t) (build-hook? . #t) + (graft? . #t) (verbosity . 0) (file-system-type . "ext4") (image-size . guess) -- cgit v1.2.3 From 00cf98eb600610361298e22214fb09bc380e8f6f Mon Sep 17 00:00:00 2001 From: Rutger Helling Date: Fri, 8 Dec 2017 11:31:57 +0100 Subject: licenses: Add wxWindows 3.1 license. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/licenses.scm (wxwindows3.1+): New variable. Co-authored-by: Ludovic Courtès --- guix/licenses.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index b07d80076e..269d97c723 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2017 Petter ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2017 Arun Isaac +;;; Copyright © 2017 Rutger Helling ;;; ;;; This file is part of GNU Guix. ;;; @@ -91,6 +92,7 @@ (define-module (guix licenses) zlib fsf-free wtfpl2 + wxwindows3.1+ fsdg-compatible)) (define-record-type @@ -581,6 +583,11 @@ (define wtfpl2 "http://www.wtfpl.net" "http://www.wtfpl.net/about/")) +(define wxwindows3.1+ + (license "wxWindows 3.1+" + "https://wxwidgets.org/about/licence" + "https://www.gnu.org/licenses/license-list.html#Wxwind")) + (define x11 (license "X11" "http://directory.fsf.org/wiki/License:X11" -- cgit v1.2.3 From f4007b25476dfd97885f358d2dabbd463f6f6017 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 30 Nov 2017 23:41:29 +0200 Subject: lint: 'check-vulnerabilities' also checks package properties. * guix/scripts/lint.scm (check-vulnerabilities): Also check for CVEs listed as mitigated in the package properties. * tests/lint.scm ("cve: known safe from vulnerability"): New test. --- guix/scripts/lint.scm | 13 ++++++++++--- tests/lint.scm | 15 +++++++++++++++ 2 files changed, 25 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1b43b0a63c..4ec3267007 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2017 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -881,10 +882,16 @@ (define (check-vulnerabilities package) (or (and=> (package-source package) origin-patches) '()))) + (known-safe (or (assq-ref (package-properties package) + 'lint-hidden-cve) + '())) (unpatched (remove (lambda (vuln) - (find (cute string-contains - <> (vulnerability-id vuln)) - patches)) + (let ((id (vulnerability-id vuln))) + (or + (find (cute string-contains + <> id) + patches) + (member id known-safe)))) vulnerabilities))) (unless (null? unpatched) (emit-warning package diff --git a/tests/lint.scm b/tests/lint.scm index 064f3d177e..ab0e8b9a8c 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost +;;; Copyright © 2017 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -702,6 +703,20 @@ (define-syntax-rule (with-warnings body ...) (patches (list "/a/b/pi-CVE-2015-1234.patch")))))))))) +(test-assert "cve: known safe from vulnerability" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (properties `((lint-hidden-cve . ("CVE-2015-1234")))))))))) + (test-assert "cve: vulnerability fixed in replacement version" (mock ((guix scripts lint) package-vulnerabilities (lambda (package) -- cgit v1.2.3 From 8bc1935c7ce2a63b058b21db206d09e0e5872ab4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 10 Dec 2017 23:39:01 +0100 Subject: build-system/asdf: Use 'mlambda'. * guix/build-system/asdf.scm (package-with-build-system): Use 'mlambda' instead of 'memoize'. --- guix/build-system/asdf.scm | 124 ++++++++++++++++++++++----------------------- 1 file changed, 62 insertions(+), 62 deletions(-) (limited to 'guix') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index ec8b64497f..ab0ae57c6e 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -19,6 +19,7 @@ (define-module (guix build-system asdf) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -160,70 +161,69 @@ (define (has-from-build-system? pkg) (eq? from-build-system (package-build-system pkg))) (define transform - (memoize - (lambda (pkg) - (define rewrite - (match-lambda - ((name content . rest) - (let* ((is-package? (package? content)) - (new-content (if is-package? (transform content) content))) - `(,name ,new-content ,@rest))))) - - ;; Special considerations for source packages: CL inputs become - ;; propagated, and un-handled arguments are removed. - - (define new-propagated-inputs - (if target-is-source? - (map rewrite - (append - (filter (match-lambda - ((_ input . _) - (has-from-build-system? input))) - (append (package-inputs pkg) - ;; The native inputs might be needed just - ;; to load the system. - (package-native-inputs pkg))) - (package-propagated-inputs pkg))) - - (map rewrite (package-propagated-inputs pkg)))) - - (define (new-inputs inputs-getter) - (if target-is-source? - (map rewrite + (mlambda (pkg) + (define rewrite + (match-lambda + ((name content . rest) + (let* ((is-package? (package? content)) + (new-content (if is-package? (transform content) content))) + `(,name ,new-content ,@rest))))) + + ;; Special considerations for source packages: CL inputs become + ;; propagated, and un-handled arguments are removed. + + (define new-propagated-inputs + (if target-is-source? + (map rewrite + (append (filter (match-lambda ((_ input . _) - (not (has-from-build-system? input)))) - (inputs-getter pkg))) - (map rewrite (inputs-getter pkg)))) - - (define base-arguments - (if target-is-source? - (strip-keyword-arguments - '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) - (package-arguments pkg)) - (package-arguments pkg))) - - (cond - ((and variant-property - (assoc-ref (package-properties pkg) variant-property)) - => force) - - ((has-from-build-system? pkg) - (package - (inherit pkg) - (location (package-location pkg)) - (name (transform-package-name (package-name pkg))) - (build-system to-build-system) - (arguments - (substitute-keyword-arguments base-arguments - ((#:phases phases) (list phases-transformer phases)))) - (inputs (new-inputs package-inputs)) - (propagated-inputs new-propagated-inputs) - (native-inputs (new-inputs package-native-inputs)) - (outputs (if target-is-source? - '("out") - (package-outputs pkg))))) - (else pkg))))) + (has-from-build-system? input))) + (append (package-inputs pkg) + ;; The native inputs might be needed just + ;; to load the system. + (package-native-inputs pkg))) + (package-propagated-inputs pkg))) + + (map rewrite (package-propagated-inputs pkg)))) + + (define (new-inputs inputs-getter) + (if target-is-source? + (map rewrite + (filter (match-lambda + ((_ input . _) + (not (has-from-build-system? input)))) + (inputs-getter pkg))) + (map rewrite (inputs-getter pkg)))) + + (define base-arguments + (if target-is-source? + (strip-keyword-arguments + '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) + (package-arguments pkg)) + (package-arguments pkg))) + + (cond + ((and variant-property + (assoc-ref (package-properties pkg) variant-property)) + => force) + + ((has-from-build-system? pkg) + (package + (inherit pkg) + (location (package-location pkg)) + (name (transform-package-name (package-name pkg))) + (build-system to-build-system) + (arguments + (substitute-keyword-arguments base-arguments + ((#:phases phases) (list phases-transformer phases)))) + (inputs (new-inputs package-inputs)) + (propagated-inputs new-propagated-inputs) + (native-inputs (new-inputs package-native-inputs)) + (outputs (if target-is-source? + '("out") + (package-outputs pkg))))) + (else pkg)))) transform) -- cgit v1.2.3 From 3b80b81358b3861ca3794105c8eb4395df97846b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 10 Dec 2017 23:41:21 +0100 Subject: ui: Display hints to resolve profile collisions. Fixes . Reported by Ben Sturmfels . * guix/ui.scm (display-collision-resolution-hint): New procedure. (call-with-error-handling): Call it upon '&profile-collistion-error'. --- guix/ui.scm | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index e40fe576ba..fa747b7b08 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -502,6 +502,26 @@ (define unit (x (leave (G_ "unknown unit: ~a~%") unit))))))) +(define (display-collision-resolution-hint collision) + "Display hints on how to resolve COLLISION, a &profile-collistion-error." + (define (top-most-entry entry) + (let loop ((entry entry)) + (match (force (manifest-entry-parent entry)) + (#f entry) + (parent (loop parent))))) + + (let* ((first (profile-collision-error-entry collision)) + (second (profile-collision-error-conflict collision)) + (name1 (manifest-entry-name (top-most-entry first))) + (name2 (manifest-entry-name (top-most-entry second)))) + (if (string=? name1 name2) + (display-hint (format #f (G_ "You cannot have two different versions +or variants of @code{~a} in the same profile.") + name1)) + (display-hint (format #f (G_ "Try upgrading both @code{~a} and @code{~a}, +or remove one of them from the profile.") + name1 name2))))) + (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." (define (port-filename* port) @@ -570,6 +590,7 @@ (define (manifest-entry-output* entry) (manifest-entry-output* conflict) (manifest-entry-item conflict)) (report-parent-entries conflict) + (display-collision-resolution-hint c) (exit 1))) ((nar-error? c) (let ((file (nar-error-file c)) -- cgit v1.2.3 From 7f04197fef905790fd392f8d686d00ae95a0d04c Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 4 Dec 2017 10:33:31 -0600 Subject: utils: Fix cond-expand for Guile 2.0. * guix/build/download.scm (tls-wrap): Use 'guile-2.2' feature instead. --- guix/build/download.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 4490d225e6..609a100538 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -308,10 +308,10 @@ (define (log level str) (register-tls-record-port record port) ;; Write HTTP requests line by line rather than byte by byte: - ;; . This is not possible on Guile 2.0. + ;; . This is possible with Guile >= 2.2. (cond-expand - (guile-2.0 #f) - (else (setvbuf record 'line))) + (guile-2.2 (setvbuf record 'line)) + (else #f)) record))) -- cgit v1.2.3 From 47dc9a0dae35960ec6239152df748bb062c640b2 Mon Sep 17 00:00:00 2001 From: nee Date: Mon, 9 Oct 2017 23:02:05 +0200 Subject: guix: utils: Add version-major. * guix/utils.scm (version-major): New procedure. --- guix/utils.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index fed31f4ca4..92e45de616 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -82,6 +82,7 @@ (define-module (guix utils) version>=? version-prefix version-major+minor + version-major guile-version>? string-replace-substring arguments-from-environment-variable @@ -497,6 +498,10 @@ (define (version-major+minor version-string) minor version numbers from version-string." (version-prefix version-string 2)) +(define (version-major version-string) + "Return the major version number as string from the version-string." + (version-prefix version-string 1)) + (define (version>? a b) "Return #t when A denotes a version strictly newer than B." (eq? '> (version-compare a b))) -- cgit v1.2.3 From 03870da81922ccb6cc1a91976487f2d3f7da0d81 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Jun 2017 10:13:45 +0200 Subject: Add (guix profiling). * guix/profiling.scm: New file. * Makefile.am (MODULES): Add it. * guix/store.scm (record-operation): Use 'profiled?' and 'register-profiling-hook!'. --- Makefile.am | 1 + guix/profiling.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/store.scm | 19 +++++++++---------- 3 files changed, 62 insertions(+), 10 deletions(-) create mode 100644 guix/profiling.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index ddbf7a7984..85b9ab36d2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -102,6 +102,7 @@ MODULES = \ guix/http-client.scm \ guix/gnupg.scm \ guix/elf.scm \ + guix/profiling.scm \ guix/store.scm \ guix/cvs-download.scm \ guix/svn-download.scm \ diff --git a/guix/profiling.scm b/guix/profiling.scm new file mode 100644 index 0000000000..753fc6c22e --- /dev/null +++ b/guix/profiling.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 profiling) + #:use-module (ice-9 match) + #:export (profiled? + register-profiling-hook!)) + +;;; Commentary: +;;; +;;; Basic support for Guix-specific profiling. +;;; +;;; Code: + +(define profiled? + (let ((profiled + (or (and=> (getenv "GUIX_PROFILING") string-tokenize) + '()))) + (lambda (component) + "Return true if COMPONENT profiling is active." + (member component profiled)))) + +(define %profiling-hooks + ;; List of profiling hooks. + (map (match-lambda + ("after-gc" after-gc-hook) + ((or "exit" #f) exit-hook)) + (or (and=> (getenv "GUIX_PROFILING_EVENTS") string-tokenize) + '("exit")))) + +(define (register-profiling-hook! component thunk) + "Register THUNK as a profiling hook for COMPONENT, a string such as +\"rpc\"." + (when (profiled? component) + (for-each (lambda (hook) + (add-hook! hook thunk)) + %profiling-hooks))) diff --git a/guix/store.scm b/guix/store.scm index f336df85cc..e6e45ba89c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -25,6 +25,7 @@ (define-module (guix store) #:use-module (guix base16) #:use-module (guix base32) #:use-module (guix hash) + #:use-module (guix profiling) #:autoload (guix build syscalls) (terminal-columns) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) @@ -794,16 +795,14 @@ (define* (show-rpc-profile #:optional (port (current-error-port))) (define record-operation ;; Optionally, increment the number of calls of the given RPC. - (let ((profiled (or (and=> (getenv "GUIX_PROFILING") string-tokenize) - '()))) - (if (member "rpc" profiled) - (begin - (add-hook! exit-hook show-rpc-profile) - (lambda (name) - (let ((count (or (hashq-ref %rpc-calls name) 0))) - (hashq-set! %rpc-calls name (+ count 1))))) - (lambda (_) - #t)))) + (if (profiled? "rpc") + (begin + (register-profiling-hook! "rpc" show-rpc-profile) + (lambda (name) + (let ((count (or (hashq-ref %rpc-calls name) 0))) + (hashq-set! %rpc-calls name (+ count 1))))) + (lambda (_) + #t))) (define-syntax operation (syntax-rules () -- cgit v1.2.3 From 252c4083779a488c86e74362b4f3bb4bf927cc67 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 11 Dec 2017 21:43:54 +0100 Subject: memoization: Add profiling support. * guix/memoization.scm (%memoization-tables): New variable. (%make-hash-table*, show-memoization-tables): New procedures. (make-hash-table*): New macro. Add top-level call to 'register-profiling-hook!'. (memoize): Adjust to pass the resulting procedure to 'make-hash-table*'. (%mlambda): Likewise. --- guix/memoization.scm | 91 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 74 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/memoization.scm b/guix/memoization.scm index bf3b73d806..69343f592b 100644 --- a/guix/memoization.scm +++ b/guix/memoization.scm @@ -17,6 +17,9 @@ ;;; along with GNU Guix. If not, see . (define-module (guix memoization) + #:use-module (guix profiling) + #:use-module (ice-9 match) + #:autoload (srfi srfi-1) (count) #:export (memoize mlambda mlambdaq)) @@ -58,17 +61,69 @@ (define-cache-procedure cachedq/mv hashq-ref hashq-set!) (define-cache-procedure cached hash-ref hash-set! call/1 return/1) (define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1) +(define %memoization-tables + ;; Map procedures to the underlying hash table. + (make-weak-key-hash-table)) + +(define %make-hash-table* + (if (profiled? "memoization") + (lambda (proc location) + (let ((table (make-hash-table))) + (hashq-set! %memoization-tables proc + (cons table location)) + table)) + (lambda (proc location) + (make-hash-table)))) + +(define-syntax-rule (make-hash-table* proc) + (%make-hash-table* proc (current-source-location))) + +(define* (show-memoization-tables #:optional (port (current-error-port))) + "Display to PORT statistics about the memoization tables." + (define (tablelist (lambda (key value) + value) + %memoization-tables)) + + (match (sort tables (negate table (hash-count (const #t) table) 0)) + tables)) + (for-each (lambda (table location) + (let ((size (hash-count (const #t) table))) + (unless (zero? size) + (format port " ~a:~a:~a: \t~a entries~%" + (assq-ref location 'filename) + (and=> (assq-ref location 'line) 1+) + (assq-ref location 'column) + size)))) + tables locations)))) + +(register-profiling-hook! "memoization" show-memoization-tables) + (define (memoize proc) "Return a memoizing version of PROC. This is a generic version of 'mlambda' what works regardless of the arity of 'proc'. It is more expensive since the argument list is always allocated, and the result is returned via (apply values results)." - (let ((cache (make-hash-table))) - (lambda args - (cached/mv cache args - (lambda () - (apply proc args)))))) + (letrec* ((mproc (lambda args + (cached/mv cache args + (lambda () + (apply proc args))))) + (cache (make-hash-table* mproc))) + mproc)) (define-syntax %mlambda (syntax-rules () @@ -88,19 +143,21 @@ (define-syntax %mlambda ;; allocated. XXX: We can't really avoid the closure allocation since ;; Guile 2.0's compiler will always keep it. ((_ cached (arg) body ...) ;one argument - (let ((cache (make-hash-table)) - (proc (lambda (arg) body ...))) - (lambda (arg) - (cached cache arg (lambda () (proc arg)))))) + (letrec* ((proc (lambda (arg) body ...)) + (mproc (lambda (arg) + (cached cache arg (lambda () (proc arg))))) + (cache (make-hash-table* mproc))) + mproc)) ((_ _ (args ...) body ...) ;two or more arguments - (let ((cache (make-hash-table)) - (proc (lambda (args ...) body ...))) - (lambda (args ...) - ;; XXX: Always use 'cached', which uses 'equal?', to compare the - ;; argument lists. - (cached cache (list args ...) - (lambda () - (proc args ...)))))))) + (letrec* ((proc (lambda (args ...) body ...)) + (mproc (lambda (args ...) + ;; XXX: Always use 'cached', which uses 'equal?', to + ;; compare the argument lists. + (cached cache (list args ...) + (lambda () + (proc args ...))))) + (cache (make-hash-table* mproc))) + mproc)))) (define-syntax-rule (mlambda formals body ...) "Define a memoizing lambda. The lambda's arguments are compared with -- cgit v1.2.3 From 6c80641d54a95f2da95e480a4a746761d25161e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Dec 2017 14:52:17 +0100 Subject: memoization: Profiling support keeps track of lookups and hits. * guix/memoization.scm (): New record type. (define-lookup-procedure, define-update-procedure): New macros. (cache-ref, cacheq-ref, cache-set!, cacheq-set!): New procedures. (cached/mv, cachedq/mv, cached, cachedq): Use them instead of 'hash-ref' and 'hash-set!'. (%make-hash-table*): When 'profiled?' returns true, return a object. (define-cache-procedure): Adjust to show cache lookups and hits. --- guix/memoization.scm | 93 ++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 69 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/memoization.scm b/guix/memoization.scm index 69343f592b..0201fe4cb3 100644 --- a/guix/memoization.scm +++ b/guix/memoization.scm @@ -20,10 +20,48 @@ (define-module (guix memoization) #:use-module (guix profiling) #:use-module (ice-9 match) #:autoload (srfi srfi-1) (count) + #:use-module (srfi srfi-9) #:export (memoize mlambda mlambdaq)) +;; Data type representation a memoization cache when profiling is on. +(define-record-type + (make-cache table lookups hits) + cache? + (table cache-table) + (lookups cache-lookups set-cache-lookups!) + (hits cache-hits set-cache-hits!)) + +(define-syntax-rule (define-lookup-procedure proc get) + "Define a lookup procedure PROC. When profiling is turned off, PROC is set +to GET; when profiling is on, PROC is a wrapper around GET that keeps tracks +of lookups and cache hits." + (define proc + (if (profiled? "memoization") + (lambda (cache key default) + (let ((result (get (cache-table cache) key default))) + (set-cache-lookups! cache (+ 1 (cache-lookups cache))) + (unless (eq? result default) + (set-cache-hits! cache (+ 1 (cache-hits cache)))) + result)) + get))) + +(define-syntax-rule (define-update-procedure proc put!) + "Define an update procedure PROC. When profiling is turned off, PROC is +equal to PUT!; when profiling is on, PROC is a wrapper around PUT and unboxes +the underlying hash table." + (define proc + (if (profiled? "memoization") + (lambda (cache key value) + (put! (cache-table cache) key value)) + put!))) + +(define-lookup-procedure cache-ref hash-ref) +(define-lookup-procedure cacheq-ref hashq-ref) +(define-update-procedure cache-set! hash-set!) +(define-update-procedure cacheq-set! hashq-set!) + (define-syntax-rule (call/mv thunk) (call-with-values thunk list)) (define-syntax-rule (return/mv lst) @@ -56,22 +94,24 @@ (define name (define-cache-procedure name hash-ref hash-set! call/mv return/mv)))) -(define-cache-procedure cached/mv hash-ref hash-set!) -(define-cache-procedure cachedq/mv hashq-ref hashq-set!) -(define-cache-procedure cached hash-ref hash-set! call/1 return/1) -(define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1) +(define-cache-procedure cached/mv cache-ref cache-set!) +(define-cache-procedure cachedq/mv cacheq-ref cacheq-set!) +(define-cache-procedure cached cache-ref cache-set! call/1 return/1) +(define-cache-procedure cachedq cacheq-ref cacheq-set! call/1 return/1) (define %memoization-tables ;; Map procedures to the underlying hash table. (make-weak-key-hash-table)) (define %make-hash-table* + ;; When profiling is off, this is equivalent to 'make-hash-table'. When + ;; profiling is on, return a hash table wrapped in a object. (if (profiled? "memoization") (lambda (proc location) - (let ((table (make-hash-table))) + (let ((cache (make-cache (make-hash-table) 0 0))) (hashq-set! %memoization-tables proc - (cons table location)) - table)) + (cons cache location)) + cache)) (lambda (proc location) (make-hash-table)))) @@ -80,35 +120,40 @@ (define-syntax-rule (make-hash-table* proc) (define* (show-memoization-tables #:optional (port (current-error-port))) "Display to PORT statistics about the memoization tables." - (define (tablelist (lambda (key value) value) %memoization-tables)) - (match (sort tables (negate table (hash-count (const #t) table) 0)) - tables)) - (for-each (lambda (table location) - (let ((size (hash-count (const #t) table))) + (length caches) + (count (lambda (cache) + (> (hash-count (const #t) (cache-table cache)) 0)) + caches)) + (for-each (lambda (cache location) + (let ((size (hash-count (const #t) (cache-table cache)))) (unless (zero? size) - (format port " ~a:~a:~a: \t~a entries~%" + (format port " ~a:~a:~a: \t~a entries, ~a lookups, ~a% hits~%" (assq-ref location 'filename) (and=> (assq-ref location 'line) 1+) (assq-ref location 'column) - size)))) - tables locations)))) + size + (cache-lookups cache) + (inexact->exact + (round + (* 100. (/ (cache-hits cache) + (cache-lookups cache) 1.)))))))) + caches locations)))) (register-profiling-hook! "memoization" show-memoization-tables) -- cgit v1.2.3 From 3d19b7fbc2f9394ad7d957f1408fef9fc0589ce6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Dec 2017 15:20:47 +0100 Subject: derivations: Use 'define-immutable-record-type' as appropriate. This is a followup to dc673fa1131fb5d1e5ca29acb4a693cfb906986f. * guix/derivations.scm (, ): Use 'define-immutable-record-type'. --- guix/derivations.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 07803ca94f..b95849727b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -136,7 +136,7 @@ (define-immutable-record-type (env-vars derivation-builder-environment-vars) ; list of name/value pairs (file-name derivation-file-name)) ; the .drv file name -(define-record-type +(define-immutable-record-type (make-derivation-output path hash-algo hash recursive?) derivation-output? (path derivation-output-path) ; store path @@ -144,7 +144,7 @@ (define-record-type (hash derivation-output-hash) ; bytevector | #f (recursive? derivation-output-recursive?)) ; Boolean -(define-record-type +(define-immutable-record-type (make-derivation-input path sub-derivations) derivation-input? (path derivation-input-path) ; store path -- cgit v1.2.3 From 1d008d9f8c44dfdb808235d451b72f255e72f103 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Dec 2017 18:09:53 +0100 Subject: derivations: 'derivation-hash' assumes inputs are coalesced. * guix/derivations.scm (derivation-hash): Remove redundant 'coalesce-duplicate-inputs' call. --- guix/derivations.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index b95849727b..f842d26be8 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -658,8 +658,11 @@ (define derivation-hash ; `hashDerivationModulo' in derivations.cc (make-derivation-input hash sub-drvs)))) inputs)) (drv (make-derivation outputs - (sort (coalesce-duplicate-inputs inputs) - derivation-input Date: Wed, 13 Dec 2017 15:13:07 +0100 Subject: Revert "derivations: 'derivation-hash' assumes inputs are coalesced." This reverts commit 1d008d9f8c44dfdb808235d451b72f255e72f103. Reported by Rutger Helling . Fixes . --- guix/derivations.scm | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index f842d26be8..b95849727b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -658,11 +658,8 @@ (define derivation-hash ; `hashDerivationModulo' in derivations.cc (make-derivation-input hash sub-drvs)))) inputs)) (drv (make-derivation outputs - - ;; Note: INPUTS is already the result - ;; of 'coalesce-duplicate-inputs'. - (sort inputs derivation-input Date: Wed, 13 Dec 2017 14:00:20 +0100 Subject: derivations: Split 'derivation-hash' in two procedures. * guix/derivations.scm (derivation/masked-inputs): New procedure. (derivation-hash): Use it instead of the inline code. --- guix/derivations.scm | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index b95849727b..bb18ce6bb1 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -632,6 +632,24 @@ (define derivation-path->base16-hash (bytevector->base16-string (derivation-hash (read-derivation-from-file file))))) +(define (derivation/masked-inputs drv) + "Assuming DRV is a regular derivation (not fixed-output), replace the file +name of each input with that input's hash." + (match drv + (($ outputs inputs sources + system builder args env-vars) + (let ((inputs (map (match-lambda + (($ path sub-drvs) + (let ((hash (derivation-path->base16-hash path))) + (make-derivation-input hash sub-drvs)))) + inputs))) + (make-derivation outputs + (sort (coalesce-duplicate-inputs inputs) + derivation-inputstring hash-algo) ":" (bytevector->base16-string hash) ":" path)))) - (($ outputs inputs sources - system builder args env-vars) - ;; A regular derivation: replace the path of each input with that - ;; input's hash; return the hash of serialization of the resulting - ;; derivation. - (let* ((inputs (map (match-lambda - (($ path sub-drvs) - (let ((hash (derivation-path->base16-hash path))) - (make-derivation-input hash sub-drvs)))) - inputs)) - (drv (make-derivation outputs - (sort (coalesce-duplicate-inputs inputs) - derivation-inputbytevector drv))))))) + (_ + + ;; XXX: At this point this remains faster than `port-sha256', because + ;; the SHA256 port's `write' method gets called for every single + ;; character. + (sha256 (derivation->bytevector (derivation/masked-inputs drv))))))) (define* (derivation store name builder args #:key -- cgit v1.2.3 From 90354e34e386b21451e0b6dab87ff5d9e81a94ae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Dec 2017 14:35:44 +0100 Subject: derivations: Don't memoize 'derivation-hash'. This has little or no run-time impact and slightly reduces the memory footprint. * guix/derivations.scm (derivation-hash): Replace 'mlambda' with 'lambda'. --- guix/derivations.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index bb18ce6bb1..38cefb6100 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -651,7 +651,7 @@ (define (derivation/masked-inputs drv) #f))))) (define derivation-hash ; `hashDerivationModulo' in derivations.cc - (mlambda (drv) + (lambda (drv) "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." (match drv (($ ((_ . ($ path -- cgit v1.2.3 From d1f01e48457f8cac9e64fb9f890332d5d93f430e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Dec 2017 14:59:48 +0100 Subject: memoization: Add 'invalidate-memoization!. * guix/memoization.scm (%make-hash-table*): When not profiling, add the new table to %MEMOIZATION-TABLES. (invalidate-memoization!): New procedure. --- guix/memoization.scm | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/memoization.scm b/guix/memoization.scm index 0201fe4cb3..086c4cdc56 100644 --- a/guix/memoization.scm +++ b/guix/memoization.scm @@ -21,7 +21,8 @@ (define-module (guix memoization) #:use-module (ice-9 match) #:autoload (srfi srfi-1) (count) #:use-module (srfi srfi-9) - #:export (memoize + #:export (invalidate-memoization! + memoize mlambda mlambdaq)) @@ -113,11 +114,21 @@ (define %make-hash-table* (cons cache location)) cache)) (lambda (proc location) - (make-hash-table)))) + (let ((table (make-hash-table))) + (hashq-set! %memoization-tables proc table) + table)))) (define-syntax-rule (make-hash-table* proc) (%make-hash-table* proc (current-source-location))) +(define (invalidate-memoization! proc) + "Invalidate the memoization cache of PROC." + (match (hashq-ref %memoization-tables proc) + ((? hash-table? table) + (hash-clear! table)) + (((? cache? cache) . _) + (hash-clear! (cache-table cache))))) + (define* (show-memoization-tables #:optional (port (current-error-port))) "Display to PORT statistics about the memoization tables." (define (cache Date: Wed, 13 Dec 2017 15:01:07 +0100 Subject: hydra: Invalidate derivation caches after each architecture evaluation. This reduces max RSS from 1.3G to 1.0G. * guix/derivations.scm (invalidate-derivation-caches!): New procedure. * build-aux/hydra/gnu-system.scm (hydra-jobs): Use it. Add 'format' call. --- build-aux/hydra/gnu-system.scm | 7 +++++++ guix/derivations.scm | 10 ++++++++++ 2 files changed, 17 insertions(+) (limited to 'guix') diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index d9b9c55d9c..5aaac5220f 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -334,6 +334,13 @@ (define (either proc1 proc2 proc3) (parameterize ((%graft? #f)) ;; Return one job for each package, except bootstrap packages. (append-map (lambda (system) + (format (current-error-port) + "evaluating for '~a' (heap size: ~a MiB)...~%" + system + (round + (/ (assoc-ref (gc-stats) 'heap-size) + (expt 2. 20)))) + (invalidate-derivation-caches!) (case subset ((all) ;; Build everything, including replacements. diff --git a/guix/derivations.scm b/guix/derivations.scm index 38cefb6100..97f96d99c1 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -90,6 +90,7 @@ (define-module (guix derivations) derivation-path->output-paths derivation raw-derivation + invalidate-derivation-caches! map-derivation @@ -841,6 +842,15 @@ (define input->derivation-input (hash-set! %derivation-cache file drv*) drv*))) +(define (invalidate-derivation-caches!) + "Invalidate internal derivation caches. This is mostly useful for +long-running processes that know what they're doing. Use with care!" + ;; Typically this is meant to be used by Cuirass and Hydra, which can clear + ;; caches when they start evaluating packages for another architecture. + (invalidate-memoization! derivation->bytevector) + (invalidate-memoization! derivation-path->base16-hash) + (hash-clear! %derivation-cache)) + (define* (map-derivation store drv mapping #:key (system (%current-system))) "Given MAPPING, a list of pairs of derivations, return a derivation based on -- cgit v1.2.3 From 1bc147d609014cc86326ff0570dfb58426f1ec73 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 13 Dec 2017 23:35:13 +0100 Subject: guix: ant-build-system: Do not compress jars. Fixes . * guix/build/ant-build-system.scm (strip-jar-timestamps): Do not compress jar when repacking. --- guix/build/ant-build-system.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index a440daf054..6ce813a001 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -197,9 +197,12 @@ (define (repack-archive jar) ;; first. (with-directory-excursion dir (let* ((files (find-files "." ".*" #:directories? #t)) + ;; To ensure that the reference scanner can detect all + ;; store references in the jars we disable compression + ;; with the "-0" option. (command (if (file-exists? manifest) - `("zip" "-X" ,jar ,manifest ,@files) - `("zip" "-X" ,jar ,@files)))) + `("zip" "-0" "-X" ,jar ,manifest ,@files) + `("zip" "-0" "-X" ,jar ,@files)))) (unless (zero? (apply system* command)) (error "'zip' failed")))) (utime jar 0 0) -- cgit v1.2.3 From e22482038611a53a9d2b25df20363664cd91be2e Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 5 Dec 2017 12:59:15 +0100 Subject: bootloader: Factorize write-file-on-device. * gnu/bootloader/extlinux.scm (install-extlinux): Factorize bootloader writing in a new procedure write-file-on-device defined in (gnu build bootloader). * gnu/build/bootloader.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new file. * gnu/system/vm.scm (qemu-img): Adapt to import and use (gnu build bootloader) module during derivation building. * gnu/scripts/system.scm (bootloader-installer-derivation): Ditto. --- gnu/bootloader/extlinux.scm | 10 +++------- gnu/build/bootloader.scm | 37 +++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/system/vm.scm | 6 ++++-- guix/scripts/system.scm | 6 ++++-- 5 files changed, 49 insertions(+), 11 deletions(-) create mode 100644 gnu/build/bootloader.scm (limited to 'guix') diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm index 9b6e2c7f2a..f7820a37a4 100644 --- a/gnu/bootloader/extlinux.scm +++ b/gnu/bootloader/extlinux.scm @@ -20,6 +20,7 @@ (define-module (gnu bootloader extlinux) #:use-module (gnu bootloader) #:use-module (gnu system) + #:use-module (gnu build bootloader) #:use-module (gnu packages bootloaders) #:use-module (guix gexp) #:use-module (guix monads) @@ -95,13 +96,8 @@ (define (install-extlinux mbr) (find-files syslinux-dir "\\.c32$")) (unless (and (zero? (system* extlinux "--install" install-dir)) - (call-with-input-file (string-append syslinux-dir "/" #$mbr) - (lambda (input) - (let ((bv (get-bytevector-n input 440))) - (call-with-output-file device - (lambda (output) - (put-bytevector output bv)) - #:binary #t))))) + (write-file-on-device + (string-append syslinux-dir "/" #$mbr) 440 device 0)) (error "failed to install SYSLINUX"))))) (define install-extlinux-mbr diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm new file mode 100644 index 0000000000..d00674dd40 --- /dev/null +++ b/gnu/build/bootloader.scm @@ -0,0 +1,37 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; 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 (gnu build bootloader) + #:use-module (ice-9 binary-ports) + #:export (write-file-on-device)) + + +;;; +;;; Writing utils. +;;; + +(define (write-file-on-device file size device offset) + "Write SIZE bytes from FILE to DEVICE starting at OFFSET." + (call-with-input-file file + (lambda (input) + (let ((bv (get-bytevector-n input size))) + (call-with-output-file device + (lambda (output) + (seek output offset SEEK_SET) + (put-bytevector output bv)) + #:binary #t))))) diff --git a/gnu/local.mk b/gnu/local.mk index f6b29a7155..c87af5a17b 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -489,6 +489,7 @@ GNU_SYSTEM_MODULES = \ %D%/system/vm.scm \ \ %D%/build/activation.scm \ + %D%/build/bootloader.scm \ %D%/build/cross-toolchain.scm \ %D%/build/file-systems.scm \ %D%/build/install.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b376337c8d..6102d465b8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -277,10 +277,12 @@ (define* (qemu-image #:key the image." (expression->derivation-in-linux-vm name - (with-imported-modules (source-module-closure '((gnu build vm) + (with-imported-modules (source-module-closure '((gnu build bootloader) + (gnu build vm) (guix build utils))) #~(begin - (use-modules (gnu build vm) + (use-modules (gnu build bootloader) + (gnu build vm) (guix build utils) (srfi srfi-26) (ice-9 binary-ports)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d0eacc573c..cbf7e6cd03 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -674,9 +674,11 @@ (define (bootloader-installer-derivation installer and TARGET arguments." (with-monad %store-monad (gexp->file "bootloader-installer" - (with-imported-modules '((guix build utils)) + (with-imported-modules '((gnu build bootloader) + (guix build utils)) #~(begin - (use-modules (guix build utils) + (use-modules (gnu build bootloader) + (guix build utils) (ice-9 binary-ports)) (#$installer #$bootloader #$device #$target)))))) -- cgit v1.2.3 From 3e0a42973b90cfaa39b36f1a0c6c39d71f5e317c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Dec 2017 10:47:01 +0100 Subject: progress: Rename 'erase-in-line' to 'erase-current-line'. Suggested by Danny Milosavljevic . * guix/progress.scm (erase-in-line): Rename to... (erase-current-line): ... this. Adjust callers. --- guix/progress.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/progress.scm b/guix/progress.scm index 0ca5c08782..c9c3cd12a0 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -178,8 +178,8 @@ (define* (progress-bar % #:optional (bar-width 20)) (make-string filled #\#) (make-string empty #\space)))) -(define (erase-in-line port) - "Write an ANSI erase-in-line sequence to PORT to erase the whole line and +(define (erase-current-line port) + "Write an ANSI erase-current-line sequence to PORT to erase the whole line and move the cursor to the beginning of the line." (display "\r\x1b[K" port)) @@ -206,7 +206,7 @@ (define elapsed (byte-count->string throughput) (seconds->string elapsed) (progress-bar %) %))) - (erase-in-line log-port) + (erase-current-line log-port) (display (string-pad-middle left right (current-terminal-columns)) log-port) @@ -218,7 +218,7 @@ (define elapsed (byte-count->string throughput) (seconds->string elapsed) (byte-count->string transferred)))) - (erase-in-line log-port) + (erase-current-line log-port) (display (string-pad-middle left right (current-terminal-columns)) log-port) @@ -248,7 +248,7 @@ (define (report-progress) (set! done (+ 1 done)) (unless (> done total) (let* ((ratio (* 100. (/ done total)))) - (erase-in-line port) + (erase-current-line port) (if (string-null? prefix) (display (progress-bar ratio (current-terminal-columns)) port) (let ((width (- (current-terminal-columns) @@ -263,7 +263,7 @@ (define (report-progress) (set! done 0))) (report report-progress) (stop (lambda () - (erase-in-line port) + (erase-current-line port) (unless (string-null? prefix) (display prefix port) (newline port)) -- cgit v1.2.3 From 5a72ddf176d53a7f4df922985d9d7fd4cfa160f5 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 12 Dec 2017 16:06:47 +0100 Subject: scripts: system: Add --expression option. * guix/scripts/system.scm (show-help): Add expression option. (%options): Ditto. (guix-system): Allow commands taking a file as an argument to use an expression instead. (process-action): Read operating-system from expression or file. * doc/guix.texi (Invoking guix system): Introduce the expression option. --- doc/guix.texi | 8 ++++++++ guix/scripts/system.scm | 28 ++++++++++++++++++++++------ 2 files changed, 30 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 7625f30fbb..64f73b38a4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -18744,6 +18744,14 @@ Build Options}). In addition, @var{options} can contain one of the following: @table @option +@item --expression=@var{expr} +@itemx -e @var{expr} +Consider the operating-system @var{expr} evaluates to. +This is an alternative to specifying a file which evaluates to an +operating system. +This is used to generate the GuixSD installer @pxref{Building the +Installation Image}). + @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system} instead of the host system type. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index cbf7e6cd03..36aed3331f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -857,6 +857,9 @@ (define (show-help) (show-build-options-help) (display (G_ " -d, --derivation return the derivation of the given system")) + (display (G_ " + -e, --expression=EXPR consider the operating-system EXPR evaluates to + instead of reading FILE, when applicable")) (display (G_ " --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) @@ -895,6 +898,9 @@ (define %options (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\d "derivation") #f #f (lambda (opt name arg result) (alist-cons 'derivations-only? #t result))) @@ -964,11 +970,19 @@ (define (process-action action args opts) (let* ((file (match args (() #f) ((x . _) x))) + (expr (assoc-ref opts 'expression)) (system (assoc-ref opts 'system)) - (os (if file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error)) - (leave (G_ "no configuration file specified~%")))) + (os (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) @@ -1079,7 +1093,8 @@ (define (option-arguments opts) ;; Extract the plain arguments from OPTS. (let* ((args (reverse (filter-map (match-pair 'argument) opts))) (count (length args)) - (action (assoc-ref opts 'action))) + (action (assoc-ref opts 'action)) + (expr (assoc-ref opts 'expression))) (define (fail) (leave (G_ "wrong number of arguments for action '~a'~%") action)) @@ -1093,7 +1108,8 @@ (define (fail) (case action ((build container vm vm-image disk-image reconfigure) - (unless (= count 1) + (unless (or (= count 1) + (and expr (= count 0))) (fail))) ((init) (unless (= count 2) -- cgit v1.2.3 From dafc3dafeada11e4df043bf751a611b1ac8fc22a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 13 Dec 2017 23:42:40 +0100 Subject: guix: offload: Add "status" sub-command. * guix/scripts/offload.scm (check-machine-status): New procedure. (guix-offload): Call it when the argument is "status". * doc/guix.texi (Daemon Offload Setup): Document it. --- doc/guix.texi | 9 +++++++++ guix/scripts/offload.scm | 39 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 64f73b38a4..cb6e6b1c6b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1066,6 +1066,15 @@ regular expression like this: # guix offload test machines.scm '\.gnu\.org$' @end example +@cindex offload status +To display the current load of all build hosts, run this command on the +main node: + +@example +# guix offload status +@end example + + @node Invoking guix-daemon @section Invoking @command{guix-daemon} diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ebd0bf783d..7e114fa2c9 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -629,6 +630,32 @@ (define (build-machine=? m1 m2) (for-each assert-node-can-import nodes names sockets) (for-each assert-node-can-export nodes names sockets)))) +(define (check-machine-status machine-file pred) + "Print the load of each machine matching PRED in MACHINE-FILE." + (define (build-machine=? m1 m2) + (and (string=? (build-machine-name m1) (build-machine-name m2)) + (= (build-machine-port m1) (build-machine-port m2)))) + + ;; A given build machine may appear several times (e.g., once for + ;; "x86_64-linux" and a second time for "i686-linux"); test them only once. + (let ((machines (filter pred + (delete-duplicates (build-machines machine-file) + build-machine=?)))) + (info (G_ "getting status of ~a build machines defined in '~a'...~%") + (length machines) machine-file) + (for-each (lambda (machine) + (let* ((node (make-node (open-ssh-session machine))) + (uts (node-eval node '(uname)))) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + host name: ~a~% normalized load: ~a~%" + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (parameterize ((current-error-port (%make-void-port "rw+"))) + (machine-load machine))))) + machines))) + ;;; ;;; Entry point. @@ -691,6 +718,18 @@ (define not-coma (() (values %machine-file (const #t))) (x (leave (G_ "wrong number of arguments~%")))))) (check-machine-availability (or file %machine-file) pred)))) + (("status" rest ...) + (with-error-handling + (let-values (((file pred) + (match rest + ((file regexp) + (values file + (compose (cut string-match regexp <>) + build-machine-name))) + ((file) (values file (const #t))) + (() (values %machine-file (const #t))) + (x (leave (G_ "wrong number of arguments~%")))))) + (check-machine-status (or file %machine-file) pred)))) (("--version") (show-version-and-exit "guix offload")) (("--help") -- cgit v1.2.3 From b8396f96bfeadfa63e7ad2afc2ab5a37f37f5f81 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 Dec 2017 22:16:18 +0100 Subject: profiles: Use (guix man-db) to create the manual database. Fixes . Reported by Ruud van Asseldonk . This also speeds up database creation compared to "man-db --create" (less than half the time, on a warm cache, for 19k pages.) * guix/man-db.scm: New file. * Makefile.am (MODULES_NOT_COMPILED): Add it. * guix/profiles.scm (manual-database): Rewrite to use (guix man-db). --- Makefile.am | 3 +- guix/man-db.scm | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/profiles.scm | 110 ++++++++++++++---------------- 3 files changed, 252 insertions(+), 61 deletions(-) create mode 100644 guix/man-db.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 85b9ab36d2..fe1e685f34 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,7 +34,8 @@ nodist_noinst_SCRIPTS = \ # Modules that are not compiled but are installed nonetheless, such as # build-side modules with unusual dependencies. -MODULES_NOT_COMPILED = +MODULES_NOT_COMPILED = \ + guix/man-db.scm include gnu/local.mk diff --git a/guix/man-db.scm b/guix/man-db.scm new file mode 100644 index 0000000000..ae960e5a1e --- /dev/null +++ b/guix/man-db.scm @@ -0,0 +1,200 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 man-db) + #:use-module (guix zlib) + #:use-module ((guix build utils) #:select (find-files)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:export (mandb-entry? + mandb-entry-file-name + mandb-entry-name + mandb-entry-section + mandb-entry-synopsis + mandb-entry-kind + + mandb-entries + write-mandb-database)) + +;;; Comment: +;;; +;;; Scan gzipped man pages and create a man-db database. The database is +;;; meant to be used by 'man -k KEYWORD'. +;;; +;;; The implementation here aims to be simpler than that of 'man-db', and to +;;; produce deterministic output. See . +;;; +;;; Code: + +;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. +(module-use! (current-module) (resolve-interface '(gdbm))) + +(define-record-type + (mandb-entry file-name name section synopsis kind) + mandb-entry? + (file-name mandb-entry-file-name) ;e.g., "../abiword.1.gz" + (name mandb-entry-name) ;e.g., "ABIWORD" + (section mandb-entry-section) ;number + (synopsis mandb-entry-synopsis) ;string + (kind mandb-entry-kind)) ;'ultimate | 'link + +(define (mandb-entry file1 name1 section1) + (match entry2 + (($ file2 name2 section2) + (or (< section1 section2) + (stringstring entry) + "Return the wire format for ENTRY as a string." + (match entry + (($ file name section synopsis kind) + ;; See db_store.c:make_content in man-db for the format. + (string-append (abbreviate-file-name file) "\t" + (number->string section) "\t" + (number->string section) + + ;; Timestamp that we always set to the epoch. + "\t0\t0" + + ;; See "db_storage.h" in man-db for the different kinds. + "\t" + (case kind + ((ultimate) "A") ;ultimate man page + ((link) "B") ;".so" link to other man page + (else "A")) ;something that doesn't matter much + + "\t-\t-\t" + + (if (string-suffix? ".gz" file) "gz" "") + "\t" + + synopsis "\x00")))) + +;; The man-db schema version we're compatible with. +(define %version-key "$version$\x00") +(define %version-value "2.5.0\x00") + +(define (write-mandb-database file entries) + "Write ENTRIES to FILE as a man-db database. FILE is usually +\".../index.db\", and is a GDBM database." + (let ((db (gdbm-open file GDBM_WRCREAT))) + (gdbm-set! db %version-key %version-value) + + ;; Write ENTRIES in sorted order so we get deterministic output. + (for-each (lambda (entry) + (gdbm-set! db + (string-append (mandb-entry-file-name entry) + "\x00") + (entry->string entry))) + (sort entries mandb-entryentry file #:optional (resolve identity)) + "Parse FILE, a gzipped man page, and return a for it." + (define (string->number* str) + (if (and (string-prefix? "\"" str) + (> (string-length str) 1) + (string-suffix? "\"" str)) + (string->number (string-drop (string-drop-right str 1) 1)) + (string->number str))) + + ;; Note: This works for both gzipped and uncompressed files. + (call-with-gzip-input-port (open-file file "r0") + (lambda (port) + (let loop ((name #f) + (section #f) + (synopsis #f) + (kind 'ultimate)) + (if (and name section synopsis) + (mandb-entry file name section synopsis kind) + (let ((line (read-line port))) + (if (eof-object? line) + (mandb-entry file name (or section 0) (or synopsis "") + kind) + (match (string-tokenize line) + ((".TH" name (= string->number* section) _ ...) + (loop name section synopsis kind)) + ((".SH" (or "NAME" "\"NAME\"")) + (loop name section (read-synopsis port) kind)) + ((".so" link) + (match (and=> (resolve link) + (cut man-page->entry <> resolve)) + (#f + (loop name section synopsis 'link)) + (alias + (mandb-entry file + (mandb-entry-name alias) + (mandb-entry-section alias) + (mandb-entry-synopsis alias) + 'link)))) + (_ + (loop name section synopsis kind)))))))))) + +(define (man-files directory) + "Return the list of man pages found under DIRECTORY, recursively." + (find-files directory "\\.[0-9][a-z]?(\\.gz)?$")) + +(define (mandb-entries directory) + "Return mandb entries for the man pages found under DIRECTORY, recursively." + (map (lambda (file) + (man-page->entry file + (lambda (link) + (let ((file (string-append directory "/" link + ".gz"))) + (and (file-exists? file) file))))) + (man-files directory))) diff --git a/guix/profiles.scm b/guix/profiles.scm index cedf9faa82..3c05543bec 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -33,6 +33,7 @@ (define-module (guix profiles) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix sets) @@ -1113,84 +1114,73 @@ (define build (define (manual-database manifest) "Return a derivation that builds the manual page database (\"mandb\") for the entries in MANIFEST." - (define man-db ;lazy reference - (module-ref (resolve-interface '(gnu packages man)) 'man-db)) + (define gdbm-ffi + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-gdbm-ffi)) + + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure `((guix build utils) + (guix man-db)))))) (define build - (with-imported-modules '((guix build utils)) + (with-imported-modules modules #~(begin - (use-modules (guix build utils) + (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" + (effective-version))) + + (use-modules (guix man-db) + (guix build utils) (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26)) + (srfi srfi-19)) - (define entries - (filter-map (lambda (directory) + (define (compute-entries) + (append-map (lambda (directory) (let ((man (string-append directory "/share/man"))) - (and (directory-exists? man) - man))) + (if (directory-exists? man) + (mandb-entries man) + '()))) '#$(manifest-inputs manifest))) - (define manpages-collection-dir - (string-append (getenv "PWD") "/manpages-collection")) - (define man-directory (string-append #$output "/share/man")) - (define (get-manpage-tail-path manpage-path) - (let ((index (string-contains manpage-path "/share/man/"))) - (unless index - (error "Manual path doesn't contain \"/share/man/\":" - manpage-path)) - (string-drop manpage-path (+ index (string-length "/share/man/"))))) - - (define (populate-manpages-collection-dir entries) - (let ((manpages (append-map (cut find-files <> #:stat stat) entries))) - (for-each (lambda (manpage) - (let* ((dest-file (string-append - manpages-collection-dir "/" - (get-manpage-tail-path manpage)))) - (mkdir-p (dirname dest-file)) - (catch 'system-error - (lambda () - (symlink manpage dest-file)) - (lambda args - ;; Different packages may contain the same - ;; manpage. Simply ignore the symlink error. - #t)))) - manpages))) - - (mkdir-p manpages-collection-dir) - (populate-manpages-collection-dir entries) - - ;; Create a mandb config file which contains a custom made - ;; manpath. The associated catpath is the location where the database - ;; gets generated. - (copy-file #+(file-append man-db "/etc/man_db.conf") - "man_db.conf") - (substitute* "man_db.conf" - (("MANDB_MAP /usr/man /var/cache/man/fsstnd") - (string-append "MANDB_MAP " manpages-collection-dir " " - man-directory))) - (mkdir-p man-directory) - (setenv "MANPATH" (string-join entries ":")) - (format #t "Creating manual page database for ~a packages... " - (length entries)) + (format #t "Creating manual page database...~%") (force-output) - (let* ((start-time (current-time)) - (exit-status (system* #+(file-append man-db "/bin/mandb") - "--quiet" "--create" - "-C" "man_db.conf")) - (duration (time-difference (current-time) start-time))) - (format #t "done in ~,3f s~%" + (let* ((start (current-time)) + (entries (compute-entries)) + (_ (write-mandb-database (string-append man-directory + "/index.db") + entries)) + (duration (time-difference (current-time) start))) + (format #t "~a entries processed in ~,1f s~%" + (length entries) (+ (time-second duration) (* (time-nanosecond duration) (expt 10 -9)))) - (force-output) - (zero? exit-status))))) + (force-output))))) (gexp->derivation "manual-database" build + + ;; Work around GDBM 1.13 issue whereby uninitialized bytes + ;; get written to disk: + ;; . + #:env-vars `(("MALLOC_PERTURB_" . "1")) + #:local-build? #t)) (define %default-profile-hooks -- cgit v1.2.3 From 58d9e71bf13f5b1a598c9980a8e171afa71dd888 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Dec 2017 16:52:27 +0100 Subject: gnu-maintenance: 'latest-ftp-release' ignores "unstable" directories. * guix/gnu-maintenance.scm (latest-ftp-release): Filter out "unstable" directories. --- guix/gnu-maintenance.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 00e80bc79f..c2a7a33b6a 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -366,6 +366,9 @@ (define (file->source directory file) #f) (("w32" 'directory . _) #f) + (("unstable" 'directory . _) + ;; As seen at ftp.gnupg.org/gcrypt/pinentry. + #f) ((directory 'directory . _) directory) (_ #f)) -- cgit v1.2.3 From 16613d230b3d9a9cf307c5c5d3899eb0a0c93b0e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Dec 2017 21:31:59 +0100 Subject: man-db: Autoload (gdbm). Fixes 'guix pull'. Reported by ofosos on #guix. * guix/man-db.scm: Use 'module-autoload!' instead of 'module-use!'. so that (gdbm) is not loaded until we need it. --- guix/man-db.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/man-db.scm b/guix/man-db.scm index ae960e5a1e..5d62e0c82d 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -45,7 +45,7 @@ (define-module (guix man-db) ;;; Code: ;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. -(module-use! (current-module) (resolve-interface '(gdbm))) +(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT)) (define-record-type (mandb-entry file-name name section synopsis kind) -- cgit v1.2.3 From 399993f8040a18d0e38217d2949822954f45dc0e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Dec 2017 14:55:26 +0100 Subject: ui: Non-zero exit for compound '&message' and '&error-location' conditions. * guix/ui.scm (call-with-error-handling): When both 'message?' and 'error-location?' are true, add call to 'exit'. --- guix/ui.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index fa747b7b08..2b7cc3d41a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -621,7 +621,8 @@ (define (manifest-entry-output* entry) (format (current-error-port) (G_ "~a: error: ~a~%") (location->string (error-location c)) - (gettext (condition-message c) %gettext-domain))) + (gettext (condition-message c) %gettext-domain)) + (exit 1)) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. (leave (G_ "~a~%") -- cgit v1.2.3 From ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 10 Dec 2017 16:35:41 +0100 Subject: gexp: 'computed-file' has a new #:guile parameter. * guix/gexp.scm ()[guile]: New field. (computed-file): Add #:guile. (computed-file-compiler): Honor 'guile'. --- guix/gexp.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 1929947d95..f005c4d296 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -343,28 +343,34 @@ (define-gexp-compiler (plain-file-compiler (file ) system target) (text-file name content references)))) (define-record-type - (%computed-file name gexp options) + (%computed-file name gexp guile options) computed-file? (name computed-file-name) ;string (gexp computed-file-gexp) ;gexp + (guile computed-file-guile) ; (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (options '(#:local-build? #t))) + #:key guile (options '(#:local-build? #t))) "Return an object representing the store item NAME, a file or directory computed by GEXP. OPTIONS is a list of additional arguments to pass to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp options)) + (%computed-file name gexp guile options)) (define-gexp-compiler (computed-file-compiler (file ) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. (match file - (($ name gexp options) - (apply gexp->derivation name gexp options)))) + (($ name gexp guile options) + (if guile + (mlet %store-monad ((guile (lower-object guile system + #:target target))) + (apply gexp->derivation name gexp #:guile-for-build guile + options)) + (apply gexp->derivation name gexp options))))) (define-record-type (%program-file name gexp guile) -- cgit v1.2.3 From 3caab236c49012643ab46afd7e82a287ec413ee8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Dec 2017 22:33:51 +0100 Subject: guix gc: '--verify=foo' is reported as an error. Fixes . Reported by Martin Castillo . * guix/scripts/gc.scm (argument->verify-options): New procedure. (%options) ["verify"]: Adjust to use it. * tests/guix-gc.sh: Add test. --- guix/scripts/gc.scm | 31 +++++++++++++++++++++---------- tests/guix-gc.sh | 3 +++ 2 files changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 378a47d113..a31d2236b0 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -78,6 +78,21 @@ (define (show-help) (newline) (show-bug-report-information)) +(define argument->verify-options + (let ((not-comma (char-set-complement (char-set #\,))) + (validate (lambda (option) + (unless (memq option '(repair contents)) + (leave (G_ "~a: invalid '--verify' option~%") + option))))) + (lambda (arg) + "Turn ARG into a list of symbols denoting '--verify' options." + (if arg + (let ((lst (map string->symbol + (string-tokenize arg not-comma)))) + (for-each validate lst) + lst) + '())))) + (define %options ;; Specification of the command-line options. (list (option '(#\h "help") #f #f @@ -112,16 +127,12 @@ (define %options (alist-cons 'action 'optimize (alist-delete 'action result)))) (option '("verify") #f #t - (let ((not-comma (char-set-complement (char-set #\,)))) - (lambda (opt name arg result) - (let ((options (if arg - (map string->symbol - (string-tokenize arg not-comma)) - '()))) - (alist-cons 'action 'verify - (alist-cons 'verify-options options - (alist-delete 'action - result))))))) + (lambda (opt name arg result) + (let ((options (argument->verify-options arg))) + (alist-cons 'action 'verify + (alist-cons 'verify-options options + (alist-delete 'action + result)))))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index 57c5e7dd61..efbc7e759c 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -39,6 +39,9 @@ do if guix gc $option whatever; then false; else true; fi done +# This should fail. +if guix gc --verify=foo; then false; else true; fi + # Check the references of a .drv. drv="`guix build guile-bootstrap -d`" out="`guix build guile-bootstrap`" -- cgit v1.2.3