From 1d3acde5087d50af6a4901fd7614f0940eb7b41d Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Tue, 2 Apr 2019 03:02:51 -0700 Subject: build-system/cargo: refactor phases to successfully build * guix/build-system/cargo.scm (%cargo-build-system-modules): Add (json parser). (cargo-build): [vendor-dir]: Define flag and pass it to builder code. [cargo-test-flags]: Likewise. [skip-build?]: Likewise. * guix/build/cargo-build/system.scm (#:use-module): use (json parser). (package-name->crate-name): Delete it. (manifest-targets): Add it. (has-executable-target?): Add it. (configure): Add #:vendor-dir name and use it. Don't touch Cargo.toml. Don't symlink to duplicate inputs. Remove useless registry line from cargo config. Define RUSTFLAGS to lift lint restrictions. (build): Add #:skip-build? flag and use it. (check): Likewise. Add #:cargo-test-flags and pass it to cargo. (install): Factor source logic to install-source. Define #:skip-build? flag and use it. Only install if executable targets are present. (install-source): Copy entire crate directory not just src. [generate-checksums] pass dummy file for unused second argument. (%standard-phases): Add install-source phase. Signed-off-by: Chris Marusich --- guix/build-system/cargo.scm | 9 ++- guix/build/cargo-build-system.scm | 155 +++++++++++++++++++++----------------- 2 files changed, 95 insertions(+), 69 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 7ff4e90f71..dc137421e9 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -59,13 +59,17 @@ (define %cargo-utils-modules (define %cargo-build-system-modules ;; Build-side modules imported by default. `((guix build cargo-build-system) + (json parser) ,@%cargo-utils-modules)) (define* (cargo-build store name inputs #:key (tests? #t) (test-target #f) + (vendor-dir "guix-vendor") (cargo-build-flags ''("--release")) + (cargo-test-flags ''("--release")) + (skip-build? #f) (phases '(@ (guix build cargo-build-system) %standard-phases)) (outputs '("out")) @@ -90,8 +94,11 @@ (define builder source)) #:system ,system #:test-target ,test-target + #:vendor-dir ,vendor-dir #:cargo-build-flags ,cargo-build-flags - #:tests? ,tests? + #:cargo-test-flags ,cargo-test-flags + #:skip-build? ,skip-build? + #:tests? ,(and tests? (not skip-build?)) #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 20087fa6c4..b68a1f90d2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019 Ivan Petkov ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ (define-module (guix build cargo-build-system) #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -37,81 +39,86 @@ (define-module (guix build cargo-build-system) ;; ;; Code: -;; FIXME: Needs to be parsed from url not package name. -(define (package-name->crate-name name) - "Return the crate name of NAME." - (match (string-split name #\-) - (("rust" rest ...) - (string-join rest "-")) - (_ #f))) - -(define* (configure #:key inputs #:allow-other-keys) - "Replace Cargo.toml [dependencies] section with guix inputs." - ;; Make sure Cargo.toml is writeable when the crate uses git-fetch. - (chmod "Cargo.toml" #o644) +(define (manifest-targets) + "Extract all targets from the Cargo.toml manifest" + (let* ((port (open-input-pipe "cargo read-manifest")) + (data (json->scm port)) + (targets (hash-ref data "targets" '()))) + (close-port port) + targets)) + +(define (has-executable-target?) + "Check if the current cargo project declares any binary targets." + (let* ((bin? (lambda (kind) (string=? kind "bin"))) + (get-kinds (lambda (dep) (hash-ref dep "kind"))) + (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) + (find bin-dep? (manifest-targets)))) + +(define* (configure #:key inputs + (vendor-dir "guix-vendor") + #:allow-other-keys) + "Vendor Cargo.toml dependencies as guix inputs." (chmod "." #o755) - (if (not (file-exists? "vendor")) - (if (not (file-exists? "Cargo.lock")) - (begin - (substitute* "Cargo.toml" - ((".*32-sys.*") " -") - ((".*winapi.*") " -") - ((".*core-foundation.*") " -")) - ;; Prepare one new directory with all the required dependencies. - ;; It's necessary to do this (instead of just using /gnu/store as the - ;; directory) because we want to hide the libraries in subdirectories - ;; share/rust-source/... instead of polluting the user's profile root. - (mkdir "vendor") - (for-each - (match-lambda - ((name . path) - (let ((crate (package-name->crate-name name))) - (when (and crate path) - (match (string-split (basename path) #\-) - ((_ ... version) - (symlink (string-append path "/share/rust-source") - (string-append "vendor/" (basename path))))))))) - inputs) - ;; Configure cargo to actually use this new directory. - (mkdir-p ".cargo") - (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) - (display " + ;; Prepare one new directory with all the required dependencies. + ;; It's necessary to do this (instead of just using /gnu/store as the + ;; directory) because we want to hide the libraries in subdirectories + ;; share/rust-source/... instead of polluting the user's profile root. + (mkdir-p vendor-dir) + (for-each + (match-lambda + ((name . path) + (let* ((rust-share (string-append path "/share/rust-source")) + (basepath (basename path)) + (link-dir (string-append vendor-dir "/" basepath))) + (and (file-exists? rust-share) + ;; Gracefully handle duplicate inputs + (not (file-exists? link-dir)) + (symlink rust-share link-dir))))) + inputs) + ;; Configure cargo to actually use this new directory. + (mkdir-p ".cargo") + (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) + (display " [source.crates-io] -registry = 'https://github.com/rust-lang/crates.io-index' replace-with = 'vendored-sources' [source.vendored-sources] directory = '" port) - (display (getcwd) port) - (display "/vendor" port) - (display "' + (display (string-append (getcwd) "/" vendor-dir) port) + (display "' " port) - (close-port port))))) - (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) + (close-port port)) - ;(setenv "CARGO_HOME" "/gnu/store") - ; (setenv "CMAKE_C_COMPILER" cc) + ;; Lift restriction on any lints: a crate author may have decided to opt + ;; into stricter lints (e.g. #![deny(warnings)]) during their own builds + ;; but we don't want any build failures that could be caused later by + ;; upgrading the compiler for example. + (setenv "RUSTFLAGS" "--cap-lints allow") + (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) #t) -(define* (build #:key (cargo-build-flags '("--release")) +(define* (build #:key + skip-build? + (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))) + (or skip-build? + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))) -(define* (check #:key tests? #:allow-other-keys) +(define* (check #:key + tests? + (cargo-test-flags '("--release")) + #:allow-other-keys) "Run tests for a given Cargo package." - (if (and tests? (file-exists? "Cargo.lock")) - (zero? (system* "cargo" "test")) + (if tests? + (zero? (apply system* `("cargo" "test" ,@cargo-test-flags))) #t)) (define (touch file-name) (call-with-output-file file-name (const #t))) -(define* (install #:key inputs outputs #:allow-other-keys) - "Install a given Cargo package." +(define* (install-source #:key inputs outputs #:allow-other-keys) + "Install the source for a given Cargo package." (let* ((out (assoc-ref outputs "out")) (src (assoc-ref inputs "source")) (rsrc (string-append (assoc-ref outputs "src") @@ -120,24 +127,36 @@ (define* (install #:key inputs outputs #:allow-other-keys) ;; Rust doesn't have a stable ABI yet. Because of this ;; Cargo doesn't have a search path for binaries yet. ;; Until this changes we are working around this by - ;; distributing crates as source and replacing - ;; references in Cargo.toml with store paths. - (copy-recursively "src" (string-append rsrc "/src")) + ;; vendoring the crates' sources by symlinking them + ;; to store paths. + (copy-recursively "." rsrc) (touch (string-append rsrc "/.cargo-ok")) - (generate-checksums rsrc src) + (generate-checksums rsrc "/dev/null") (install-file "Cargo.toml" rsrc) - ;; When the package includes executables we install - ;; it using cargo install. This fails when the crate - ;; doesn't contain an executable. - (if (file-exists? "Cargo.lock") - (zero? (system* "cargo" "install" "--root" out)) - (begin - (mkdir out) - #t)))) + #t)) + +(define* (install #:key inputs outputs skip-build? #:allow-other-keys) + "Install a given Cargo package." + (let* ((out (assoc-ref outputs "out"))) + (mkdir-p out) + + ;; Make cargo reuse all the artifacts we just built instead + ;; of defaulting to making a new temp directory + (setenv "CARGO_TARGET_DIR" "./target") + ;; Force cargo to honor our .cargo/config definitions + ;; https://github.com/rust-lang/cargo/issues/6397 + (setenv "CARGO_HOME" ".") + + ;; Only install crates which include binary targets, + ;; otherwise cargo will raise an error. + (or skip-build? + (not (has-executable-target?)) + (zero? (system* "cargo" "install" "--path" "." "--root" out))))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) + (add-before 'configure 'install-source install-source) (replace 'configure configure) (replace 'build build) (replace 'check check) -- cgit v1.2.3 From 21b3c0ca8789c22b9b689faa01286b18f103b92e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Apr 2019 22:16:37 +0200 Subject: guix package: Use absolute file names in search path recommendations. Suggested by Chris Marusich. * guix/scripts/package.scm (absolutize): New procedure. (display-search-paths): Use it. --- guix/scripts/package.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b0c6a7ced7..564236988e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -278,11 +278,19 @@ (define* (search-path-environment-variables entries profiles (evaluate-search-paths search-paths profiles getenv)))) +(define (absolutize file) + "Return an absolute file name equivalent to FILE, but without resolving +symlinks like 'canonicalize-path' would do." + (if (string-prefix? "/" file) + file + (string-append (getcwd) "/" file))) + (define* (display-search-paths entries profiles #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let* ((profiles (map user-friendly-profile profiles)) + (let* ((profiles (map (compose user-friendly-profile absolutize) + profiles)) (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) -- cgit v1.2.3 From 95207e70d561517c8db8992f61552004f8213b04 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 09:52:48 +0200 Subject: store: 'with-store' expands to a single procedure call. * guix/store.scm (call-with-store): New procedure. (with-store): Write in terms of 'call-with-store'. --- guix/store.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 0a0a7c7c52..fdd04f349d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -602,19 +602,23 @@ (define (close-connection server) "Close the connection to SERVER." (close (store-connection-socket server))) -(define-syntax-rule (with-store store exp ...) - "Bind STORE to an open connection to the store and evaluate EXPs; -automatically close the store when the dynamic extent of EXP is left." +(define (call-with-store proc) + "Call PROC with an open store connection." (let ((store (open-connection))) (dynamic-wind (const #f) (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - exp) ...) + (proc store))) (lambda () (false-if-exception (close-connection store)))))) +(define-syntax-rule (with-store store exp ...) + "Bind STORE to an open connection to the store and evaluate EXPs; +automatically close the store when the dynamic extent of EXP is left." + (call-with-store (lambda (store) exp ...))) + (define current-store-protocol-version ;; Protocol version of the store currently used. XXX: This is a hack to ;; communicate the protocol version to the build output port. It's a hack -- cgit v1.2.3 From 5d9f9ad63191646a22dc80624227aa413a4894f0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 22:39:26 +0200 Subject: Add (guix colors). * guix/colors.scm: New file. * Makefile.am (MODULES): Add it. * guix/ui.scm (color-table, color, colorize-string): Remove. * guix/status.scm (isatty?*, color-output? color-rules): Remove. --- Makefile.am | 1 + guix/colors.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/status.scm | 44 +------------------ guix/ui.scm | 55 +----------------------- 4 files changed, 132 insertions(+), 97 deletions(-) create mode 100644 guix/colors.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index c331da7267..87682b4949 100644 --- a/Makefile.am +++ b/Makefile.am @@ -138,6 +138,7 @@ MODULES = \ guix/store.scm \ guix/cvs-download.scm \ guix/svn-download.scm \ + guix/colors.scm \ guix/i18n.scm \ guix/ui.scm \ guix/status.scm \ diff --git a/guix/colors.scm b/guix/colors.scm new file mode 100644 index 0000000000..fad0bd2ab9 --- /dev/null +++ b/guix/colors.scm @@ -0,0 +1,129 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Free Software Foundation, Inc. +;;; Copyright © 2018 Sahithi Yarlagadda +;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2017, 2018, 2019 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 colors) + #:use-module (guix memoization) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:export (colorize-string + color-rules + color-output? + isatty?*)) + +;;; Commentary: +;;; +;;; This module provides tools to produce colored output using ANSI escapes. +;;; +;;; Code: + +(define color-table + `((CLEAR . "0") + (RESET . "0") + (BOLD . "1") + (DARK . "2") + (UNDERLINE . "4") + (UNDERSCORE . "4") + (BLINK . "5") + (REVERSE . "6") + (CONCEALED . "8") + (BLACK . "30") + (RED . "31") + (GREEN . "32") + (YELLOW . "33") + (BLUE . "34") + (MAGENTA . "35") + (CYAN . "36") + (WHITE . "37") + (ON-BLACK . "40") + (ON-RED . "41") + (ON-GREEN . "42") + (ON-YELLOW . "43") + (ON-BLUE . "44") + (ON-MAGENTA . "45") + (ON-CYAN . "46") + (ON-WHITE . "47"))) + +(define (color . lst) + "Return a string containing the ANSI escape sequence for producing the +requested set of attributes in LST. Unknown attributes are ignored." + (let ((color-list + (remove not + (map (lambda (color) (assq-ref color-table color)) + lst)))) + (if (null? color-list) + "" + (string-append + (string #\esc #\[) + (string-join color-list ";" 'infix) + "m")))) + +(define (colorize-string str . color-list) + "Return a copy of STR colorized using ANSI escape sequences according to the +attributes STR. At the end of the returned string, the color attributes will +be reset such that subsequent output will not have any colors in effect." + (string-append + (apply color color-list) + str + (color 'RESET))) + +(define isatty?* + (mlambdaq (port) + "Return true if PORT is a tty. Memoize the result." + (isatty? port))) + +(define (color-output? port) + "Return true if we should write colored output to PORT." + (and (not (getenv "INSIDE_EMACS")) + (not (getenv "NO_COLOR")) + (isatty?* port))) + +(define-syntax color-rules + (syntax-rules () + "Return a procedure that colorizes the string it is passed according to +the given rules. Each rule has the form: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + ((_ (regexp colors ...) rest ...) + (let ((next (color-rules rest ...)) + (rx (make-regexp regexp))) + (lambda (str) + (if (string-index str #\nul) + str + (match (regexp-exec rx str) + (#f (next str)) + (m (let loop ((n 1) + (c '(colors ...)) + (result '())) + (match c + (() + (string-concatenate-reverse result)) + ((first . tail) + (loop (+ n 1) tail + (cons (colorize-string (match:substring m n) + first) + result))))))))))) + ((_) + (lambda (str) + str)))) diff --git a/guix/status.scm b/guix/status.scm index bddaa003db..7edb558ee7 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -20,7 +20,7 @@ (define-module (guix status) #:use-module (guix records) #:use-module (guix i18n) - #:use-module ((guix ui) #:select (colorize-string)) + #:use-module (guix colors) #:use-module (guix progress) #:autoload (guix build syscalls) (terminal-columns) #:use-module ((guix build download) @@ -339,10 +339,6 @@ (define (multiplexed-output-supported?) (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) -(define isatty?* - (mlambdaq (port) - (isatty? port))) - (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (phase port) @@ -362,44 +358,6 @@ (define spin! (format port (G_ "'~a' phase") phase)) (force-output port))))))) -(define (color-output? port) - "Return true if we should write colored output to PORT." - (and (not (getenv "INSIDE_EMACS")) - (not (getenv "NO_COLOR")) - (isatty?* port))) - -(define-syntax color-rules - (syntax-rules () - "Return a procedure that colorizes the string it is passed according to -the given rules. Each rule has the form: - - (REGEXP COLOR1 COLOR2 ...) - -where COLOR1 specifies how to colorize the first submatch of REGEXP, and so -on." - ((_ (regexp colors ...) rest ...) - (let ((next (color-rules rest ...)) - (rx (make-regexp regexp))) - (lambda (str) - (if (string-index str #\nul) - str - (match (regexp-exec rx str) - (#f (next str)) - (m (let loop ((n 1) - (c '(colors ...)) - (result '())) - (match c - (() - (string-concatenate-reverse result)) - ((first . tail) - (loop (+ n 1) tail - (cons (colorize-string (match:substring m n) - first) - result))))))))))) - ((_) - (lambda (str) - str)))) - (define colorize-log-line ;; Take a string and return a possibly colorized string according to the ;; rules below. diff --git a/guix/ui.scm b/guix/ui.scm index 0070301c47..c2807b711f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -10,8 +10,6 @@ ;;; Copyright © 2016 Roel Janssen ;;; Copyright © 2016 Benz Schenk ;;; Copyright © 2018 Kyle Meyer -;;; Copyright © 2013, 2014 Free Software Foundation, Inc. -;;; Copyright © 2018 Sahithi Yarlagadda ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -118,8 +116,7 @@ (define-module (guix ui) guix-warning-port warning info - guix-main - colorize-string)) + guix-main)) ;;; Commentary: ;;; @@ -1703,54 +1700,4 @@ (define (guix-main arg0 . args) (initialize-guix) (apply run-guix args)) -(define color-table - `((CLEAR . "0") - (RESET . "0") - (BOLD . "1") - (DARK . "2") - (UNDERLINE . "4") - (UNDERSCORE . "4") - (BLINK . "5") - (REVERSE . "6") - (CONCEALED . "8") - (BLACK . "30") - (RED . "31") - (GREEN . "32") - (YELLOW . "33") - (BLUE . "34") - (MAGENTA . "35") - (CYAN . "36") - (WHITE . "37") - (ON-BLACK . "40") - (ON-RED . "41") - (ON-GREEN . "42") - (ON-YELLOW . "43") - (ON-BLUE . "44") - (ON-MAGENTA . "45") - (ON-CYAN . "46") - (ON-WHITE . "47"))) - -(define (color . lst) - "Return a string containing the ANSI escape sequence for producing the -requested set of attributes in LST. Unknown attributes are ignored." - (let ((color-list - (remove not - (map (lambda (color) (assq-ref color-table color)) - lst)))) - (if (null? color-list) - "" - (string-append - (string #\esc #\[) - (string-join color-list ";" 'infix) - "m")))) - -(define (colorize-string str . color-list) - "Return a copy of STR colorized using ANSI escape sequences according to the -attributes STR. At the end of the returned string, the color attributes will -be reset such that subsequent output will not have any colors in effect." - (string-append - (apply color color-list) - str - (color 'RESET))) - ;;; ui.scm ends here -- cgit v1.2.3 From 32813e8440ff15c9389b84b1d7450fe1d3d25bb2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 23:06:38 +0200 Subject: ui: Fix i18n for diagnostic messages. Until now, we'd pass 'gettext' the "augmented" format string, which 'gettext' would not find in message catalogs. Now we pass it FMT as is, which is what catalogs contain. * guix/ui.scm (define-diagnostic)[augmented-format-string]: Remove. Emit one 'format' call to print the prefix, and a second one to print the actual message. --- guix/ui.scm | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index c2807b711f..c57d206184 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -129,28 +129,24 @@ (define-syntax-rule (define-diagnostic name prefix) messages." (define-syntax name (lambda (x) - (define (augmented-format-string fmt) - (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt))) - (syntax-case x () ((name (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) - (with-syntax ((fmt* (augmented-format-string #'fmt)) - (prefix (datum->syntax x prefix))) - #'(format (guix-warning-port) (gettext fmt*) - (program-name) (program-name) prefix + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix) + (format (guix-warning-port) (gettext fmt) args (... ...)))) ((name (N-underscore singular plural n) args (... ...)) (and (string? (syntax->datum #'singular)) (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) - (with-syntax ((s (augmented-format-string #'singular)) - (p (augmented-format-string #'plural)) - (prefix (datum->syntax x prefix))) - #'(format (guix-warning-port) - (ngettext s p n %gettext-domain) - (program-name) (program-name) prefix + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) args (... ...)))))))) (define-diagnostic warning "warning: ") ; emit a warning -- cgit v1.2.3 From 26a2021a1f7951818539353531d56d2e8338966e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 23:44:36 +0200 Subject: ui: Make diagnostic message prefix translatable. * guix/ui.scm (define-diagnostic): Expect PREFIX to be enclosed in 'G_'. Emit call to 'gettext' on PREFIX. (warning, info, report-error): Wrap prefix in 'G_'. --- guix/ui.scm | 63 ++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 35 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index c57d206184..953cf9ea7f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -124,35 +124,42 @@ (define-module (guix ui) ;;; ;;; Code: -(define-syntax-rule (define-diagnostic name prefix) - "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +(define-syntax define-diagnostic + (syntax-rules () + "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all messages." - (define-syntax name - (lambda (x) - (syntax-case x () - ((name (underscore fmt) args (... ...)) - (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'G_)) - #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix) - (format (guix-warning-port) (gettext fmt) - args (... ...)))) - ((name (N-underscore singular plural n) args (... ...)) - (and (string? (syntax->datum #'singular)) - (string? (syntax->datum #'plural)) - (free-identifier=? #'N-underscore #'N_)) - #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix) - (format (guix-warning-port) - (ngettext singular plural n %gettext-domain) - args (... ...)))))))) - -(define-diagnostic warning "warning: ") ; emit a warning -(define-diagnostic info "") - -(define-diagnostic report-error "error: ") + ((_ name (G_ prefix)) + (define-syntax name + (lambda (x) + (syntax-case x () + ((name (underscore fmt) args (... ...)) + (and (string? (syntax->datum #'fmt)) + (free-identifier=? #'underscore #'G_)) + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (gettext prefix %gettext-domain)) + (format (guix-warning-port) (gettext fmt %gettext-domain) + args (... ...)))) + ((name (N-underscore singular plural n) args (... ...)) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural)) + (free-identifier=? #'N-underscore #'N_)) + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (gettext prefix %gettext-domain)) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) + args (... ...)))))))))) + +;; XXX: This doesn't work well for right-to-left languages. +;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; +;; "~a" is a placeholder for that phrase. +(define-diagnostic warning (G_ "warning: ")) ;emit a warning +(define-diagnostic info (G_ "")) + +(define-diagnostic report-error (G_ "error: ")) (define-syntax-rule (leave args ...) "Emit an error message and exit." (begin -- cgit v1.2.3 From cc3697d5438a861f78a1e5ed57f592ea9ee327be Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 10:26:39 +0200 Subject: ui: Factorize 'print-diagnostic-prefix'. * guix/ui.scm (define-diagnostic): Emit call to 'print-diagnostic-prefix'. (print-diagnostic-prefix): New procedure. --- guix/ui.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 953cf9ea7f..8893cc8eee 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -136,9 +136,7 @@ (define-syntax name (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (gettext prefix %gettext-domain)) + (print-diagnostic-prefix prefix) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) ((name (N-underscore singular plural n) args (... ...)) @@ -146,9 +144,7 @@ (define-syntax name (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (gettext prefix %gettext-domain)) + (print-diagnostic-prefix prefix) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) args (... ...)))))))))) @@ -166,6 +162,14 @@ (define-syntax-rule (leave args ...) (report-error args ...) (exit 1))) +(define (print-diagnostic-prefix prefix) + "Print PREFIX as a diagnostic line prefix." + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. (match args -- cgit v1.2.3 From 402627714b8ba75be48b1c8fbd46cfd4cfe8238f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 11:14:25 +0200 Subject: ui: Diagnostic procedures can display error location. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ui.scm (define-diagnostic): Add optional 'location' parameter. Pass it to 'print-diagnostic-prefix'. (print-diagnostic-prefix): Add optional 'location' parameter and honor it. (report-load-error): Use 'report-error' and 'warning' instead of (format (current-error-port) …). --- guix/ui.scm | 64 +++++++++++++++++++++++++++++++------------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 8893cc8eee..9c8f943ef1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -132,22 +132,31 @@ (define-syntax define-diagnostic (define-syntax name (lambda (x) (syntax-case x () - ((name (underscore fmt) args (... ...)) + ((name location (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (print-diagnostic-prefix prefix) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) - ((name (N-underscore singular plural n) args (... ...)) + ((name location (N-underscore singular plural n) + args (... ...)) (and (string? (syntax->datum #'singular)) (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (print-diagnostic-prefix prefix) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) - args (... ...)))))))))) + args (... ...)))) + ((name (underscore fmt) args (... ...)) + (free-identifier=? #'underscore #'G_) + #'(name #f (underscore fmt) args (... ...))) + ((name (N-underscore singular plural n) + args (... ...)) + (free-identifier=? #'N-underscore #'N_) + #'(name #f (N-underscore singular plural n) + args (... ...))))))))) ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; @@ -162,13 +171,16 @@ (define-syntax-rule (leave args ...) (report-error args ...) (exit 1))) -(define (print-diagnostic-prefix prefix) +(define* (print-diagnostic-prefix prefix #:optional location) "Print PREFIX as a diagnostic line prefix." - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (if (string-null? prefix) - prefix - (gettext prefix %gettext-domain)))) + (let ((prefix (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (if location + (format (guix-warning-port) "~a: ~a" + (location->string location) prefix) + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix)))) (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. @@ -360,21 +372,15 @@ (define* (report-load-error file args #:optional frame) (apply throw args))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: error: ~a~%") - (location->string loc) message))) + (report-error loc (G_ "~a~%") message))) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (('srfi-34 obj) (if (message-condition? obj) - (if (error-location? obj) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location obj)) - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain))) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain)) (report-error (G_ "exception thrown: ~s~%") obj)) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) @@ -398,8 +404,7 @@ (define (warn-about-load-error file args) ;FIXME: factorize with ↑ (warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: warning: ~a~%") - (location->string loc) message))) + (warning loc (G_ "~a~%") message))) (('srfi-34 obj) (if (message-condition? obj) (warning (G_ "failed to load '~a': ~a~%") @@ -731,17 +736,14 @@ (define (manifest-entry-output* entry) (cons (invoke-error-program c) (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location c)) - (gettext (condition-message c) %gettext-domain)) + (report-error (error-location c) (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1)) ((and (message-condition? c) (fix-hint? c)) - (format (current-error-port) "~a: error: ~a~%" - (program-name) - (gettext (condition-message c) %gettext-domain)) + (report-error (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (display-hint (condition-fix-hint c)) (exit 1)) ((message-condition? c) -- cgit v1.2.3 From 9e1e046040182d8c4bb6e847bcd331862f9015bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 12:00:55 +0200 Subject: ui: Colorize diagnostics. * guix/ui.scm (define-diagnostic): Add 'colors' parameter and pass it to 'print-diagnostic-prefix'. (warning, info, report-error): Add extra argument. (%warning-colors, %info-colors, %error-colors): New variables. (print-diagnostic-prefix): Add #:colors parameter and honor it. --- guix/ui.scm | 42 +++++++++++++++++++++++++++++++++--------- 1 file changed, 33 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9c8f943ef1..3869f77c15 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -29,6 +29,7 @@ (define-module (guix ui) #:use-module (guix i18n) + #:use-module (guix colors) #:use-module (guix gexp) #:use-module (guix sets) #:use-module (guix utils) @@ -128,7 +129,7 @@ (define-syntax define-diagnostic (syntax-rules () "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all messages." - ((_ name (G_ prefix)) + ((_ name (G_ prefix) colors) (define-syntax name (lambda (x) (syntax-case x () @@ -136,7 +137,8 @@ (define-syntax name (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (print-diagnostic-prefix prefix location) + (print-diagnostic-prefix prefix location + #:colors colors) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) ((name location (N-underscore singular plural n) @@ -145,7 +147,8 @@ (define-syntax name (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (print-diagnostic-prefix prefix location) + (print-diagnostic-prefix prefix location + #:colors colors) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) args (... ...)))) @@ -161,26 +164,47 @@ (define-syntax name ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; "~a" is a placeholder for that phrase. -(define-diagnostic warning (G_ "warning: ")) ;emit a warning -(define-diagnostic info (G_ "")) +(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning +(define-diagnostic info (G_ "") %info-colors) +(define-diagnostic report-error (G_ "error: ") %error-colors) -(define-diagnostic report-error (G_ "error: ")) (define-syntax-rule (leave args ...) "Emit an error message and exit." (begin (report-error args ...) (exit 1))) -(define* (print-diagnostic-prefix prefix #:optional location) +(define %warning-colors '(BOLD MAGENTA)) +(define %info-colors '(BOLD CYAN)) +(define %error-colors '(BOLD RED)) + +(define* (print-diagnostic-prefix prefix #:optional location + #:key (colors '())) "Print PREFIX as a diagnostic line prefix." + (define color? + (color-output? (guix-warning-port))) + + (define location-color + (if color? + (cut colorize-string <> 'BOLD) + identity)) + + (define prefix-color + (if color? + (lambda (prefix) + (apply colorize-string prefix colors)) + identity)) + (let ((prefix (if (string-null? prefix) prefix (gettext prefix %gettext-domain)))) (if location (format (guix-warning-port) "~a: ~a" - (location->string location) prefix) + (location-color (location->string location)) + (prefix-color prefix)) (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix)))) + (program-name) (program-name) + (prefix-color prefix))))) (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. -- cgit v1.2.3 From a7ae18b1b9a083a1fbc6c2037e45df2447f704ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 12:55:23 +0200 Subject: ui: Colorize hints. * guix/ui.scm (%info-colors): Remove CYAN. (%hint-colors): New variable. (display-hint): Adjust so that the "hint:" prefix is colorized. --- guix/ui.scm | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 3869f77c15..63977f3aec 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -175,8 +175,9 @@ (define-syntax-rule (leave args ...) (exit 1))) (define %warning-colors '(BOLD MAGENTA)) -(define %info-colors '(BOLD CYAN)) +(define %info-colors '(BOLD)) (define %error-colors '(BOLD RED)) +(define %hint-colors '(BOLD CYAN)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors '())) @@ -357,11 +358,18 @@ (define (moduleplain-text message)))) + (define colorize + (if (color-output? port) + (lambda (str) + (apply colorize-string str %hint-colors)) + identity)) + + (display (colorize (G_ "hint: ")) port) + (display + ;; XXX: We should arrange so that the initial indent is wider. + (parameterize ((%text-width (max 15 (- (terminal-columns) 5)))) + (texi->plain-text message)) + port)) (define* (report-unbound-variable-error args #:key frame) "Return the given unbound-variable error, where ARGS is the list of 'throw' -- cgit v1.2.3 From 238589e566013a36df0347b200f8a6059398666c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 16:12:54 +0200 Subject: ui: Highlight diagnostic format string arguments. * guix/ui.scm (highlight-argument): New macro. (%highlight-argument): New procedure. (define-diagnostic): Use 'highlight-argument'. --- guix/ui.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 63977f3aec..c3612d92b4 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -125,6 +125,48 @@ (define-module (guix ui) ;;; ;;; Code: +(define-syntax highlight-argument + (lambda (s) + "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT +is a trivial format string." + (define (trivial-format-string? fmt) + (define len + (string-length fmt)) + + (let loop ((start 0)) + (or (>= (+ 1 start) len) + (let ((tilde (string-index fmt #\~ start))) + (or (not tilde) + (case (string-ref fmt (+ tilde 1)) + ((#\a #\A #\%) (loop (+ tilde 2))) + (else #f))))))) + + ;; Be conservative: limit format argument highlighting to cases where the + ;; format string contains nothing but ~a escapes. If it contained ~s + ;; escapes, this strategy wouldn't work. + (syntax-case s () + ((_ "~a~%" arg) ;don't highlight whole messages + #'arg) + ((_ fmt arg) + (trivial-format-string? (syntax->datum #'fmt)) + #'(%highlight-argument arg)) + ((_ fmt arg) + #'arg)))) + +(define* (%highlight-argument arg #:optional (port (guix-warning-port))) + "Highlight ARG, a format string argument, if PORT supports colors." + (define highlight + (if (color-output? port) + (lambda (str) + (apply colorize-string str %highlight-colors)) + identity)) + + (cond ((string? arg) + (highlight arg)) + ((symbol? arg) + (highlight (symbol->string arg))) + (else arg))) + (define-syntax define-diagnostic (syntax-rules () "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all @@ -140,7 +182,7 @@ (define-syntax name (print-diagnostic-prefix prefix location #:colors colors) (format (guix-warning-port) (gettext fmt %gettext-domain) - args (... ...)))) + (highlight-argument fmt args) (... ...)))) ((name location (N-underscore singular plural n) args (... ...)) (and (string? (syntax->datum #'singular)) @@ -151,7 +193,7 @@ (define-syntax name #:colors colors) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) - args (... ...)))) + (highlight-argument singular args) (... ...)))) ((name (underscore fmt) args (... ...)) (free-identifier=? #'underscore #'G_) #'(name #f (underscore fmt) args (... ...))) @@ -178,6 +220,7 @@ (define %warning-colors '(BOLD MAGENTA)) (define %info-colors '(BOLD)) (define %error-colors '(BOLD RED)) (define %hint-colors '(BOLD CYAN)) +(define %highlight-colors '(BOLD)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors '())) -- cgit v1.2.3 From 08d0f950b3ad936b859064c070be16548684cbd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 16:13:51 +0200 Subject: pull: Remove duplicate '--dry-run' description. Reported by pkill9. * guix/scripts/pull.scm (show-help): Remove duplicate '--dry-run' description. --- guix/scripts/pull.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2aaf1cc44a..55137fce8f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -91,8 +91,6 @@ (define (show-help) (display (G_ " -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) (display (G_ " - -n, --dry-run show what would be pulled and built")) - (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) -- cgit v1.2.3 From 72eda0624be89ed18302fd7d7f22976071ab020c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:27:57 +0200 Subject: Add (guix store roots). * guix/store/roots.scm, tests/store-roots.scm: New files. * Makefile.am (STORE_MODULES): Add guix/store/roots.scm. (SCM_TESTS): Add tests/store-roots.scm. --- Makefile.am | 6 ++- guix/store/roots.scm | 120 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/store-roots.scm | 53 ++++++++++++++++++++++ 3 files changed, 177 insertions(+), 2 deletions(-) create mode 100644 guix/store/roots.scm create mode 100644 tests/store-roots.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 87682b4949..704f2451c3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -277,7 +277,8 @@ endif BUILD_DAEMON_OFFLOAD # Scheme implementation of the build daemon and related functionality. STORE_MODULES = \ guix/store/database.scm \ - guix/store/deduplication.scm + guix/store/deduplication.scm \ + guix/store/roots.scm MODULES += $(STORE_MODULES) @@ -408,7 +409,8 @@ SCM_TESTS = \ tests/pypi.scm \ tests/import-utils.scm \ tests/store-database.scm \ - tests/store-deduplication.scm + tests/store-deduplication.scm \ + tests/store-roots.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/store/roots.scm b/guix/store/roots.scm new file mode 100644 index 0000000000..4f23ae34e8 --- /dev/null +++ b/guix/store/roots.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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 store roots) + #:use-module (guix config) + #:use-module ((guix store) #:select (store-path? %gc-roots-directory)) + #:use-module (guix sets) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:re-export (%gc-roots-directory) + #:export (gc-roots + user-owned?)) + +;;; Commentary: +;;; +;;; This module provides tools to list and access garbage collector roots ("GC +;;; roots"). +;;; +;;; Code: + +(define %profile-directory + ;; Directory where user profiles are stored. + ;; XXX: This is redundant with the definition in (guix profiles) and not + ;; entirely needed since in practice /var/guix/gcroots/profiles links to + ;; it. + (string-append %state-directory "/profiles")) + +(define (gc-roots) + "Return the list of garbage collector roots (\"GC roots\"). This includes +\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that +are user-controlled symlinks stored anywhere on the file system." + (define (regular? file) + (match file + (((or "." "..") . _) #f) + (_ #t))) + + (define (file-type=? type) + (match-lambda + ((file . properties) + (match (assq-ref properties 'type) + ('unknown + (let ((stat (lstat file))) + (eq? type (stat:type stat)))) + (actual-type + (eq? type actual-type)))))) + + (define directory? + (file-type=? 'directory)) + + (define symlink? + (file-type=? 'symlink)) + + (define canonical-root + (match-lambda + ((file . properties) + (let ((target (readlink file))) + (cond ((store-path? target) + ;; Regular root: FILE points to the store. + file) + + ;; Indirect root: FILE points to a user-controlled file outside + ;; the store. + ((string-prefix? "/" target) + target) + (else + (string-append (dirname file) "/" target))))))) + + (let loop ((directories (list %gc-roots-directory + %profile-directory)) + (roots '()) + (visited (set))) + (match directories + (() + roots) + ((directory . rest) + (if (set-contains? visited directory) + (loop rest roots visited) + (let*-values (((scope) + (cut string-append directory "/" <>)) + ((sub-directories files) + (partition directory? + (map (match-lambda + ((file . properties) + (cons (scope file) properties))) + (scandir* directory regular?))))) + (loop (append rest (map first sub-directories)) + (append (map canonical-root (filter symlink? files)) + roots) + (set-insert directory visited)))))))) + +(define* (user-owned? root #:optional (uid (getuid))) + "Return true if ROOT exists and is owned by UID, false otherwise." + ;; If ROOT is an indirect root, then perhaps it no longer exists. Thus, + ;; catch 'system-error' exceptions. + (catch 'system-error + (lambda () + (define stat + (lstat root)) + + (= (stat:uid stat) uid)) + (const #f))) diff --git a/tests/store-roots.scm b/tests/store-roots.scm new file mode 100644 index 0000000000..5bcf1bc87e --- /dev/null +++ b/tests/store-roots.scm @@ -0,0 +1,53 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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 (test-store-deduplication) + #:use-module (guix tests) + #:use-module (guix store) + #:use-module (guix store roots) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %store + (open-connection)) + +(test-begin "store-roots") + +(test-assert "gc-roots, regular root" + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append %gc-roots-directory "/test-gc-root"))) + (symlink item root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))) + +(test-assert "gc-roots, indirect root" + (call-with-temporary-directory + (lambda (directory) + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append directory "/gc-root"))) + (symlink item root) + (add-indirect-root %store root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))))) + +(test-end "store-roots") -- cgit v1.2.3 From bacf980c76c94e7bda86220ca4bf662d0e34a45a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:29:18 +0200 Subject: guix gc: Add '--list-roots'. * guix/scripts/gc.scm (show-help, %options): Add '--list-roots'. (guix-gc)[list-roots]: New procedure. Handle '--list-roots'. * tests/guix-gc.sh: Test it. * doc/guix.texi (Invoking guix gc): Document it. --- doc/guix.texi | 6 +++++- guix/scripts/gc.scm | 21 ++++++++++++++++++++- tests/guix-gc.sh | 6 ++++-- 3 files changed, 29 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2f9fcbe3bf..2345617b2e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3385,7 +3385,7 @@ deleted. The set of garbage collector roots (``GC roots'' for short) includes default user profiles; by default, the symlinks under @file{/var/guix/gcroots} represent these GC roots. New GC roots can be added with @command{guix build --root}, for example (@pxref{Invoking -guix build}). +guix build}). The @command{guix gc --list-roots} command lists them. Prior to running @code{guix gc --collect-garbage} to make space, it is often useful to remove old generations from user profiles; that way, old @@ -3451,6 +3451,10 @@ This prints nothing unless the daemon was started with @option{--cache-failures} (@pxref{Invoking guix-daemon, @option{--cache-failures}}). +@item --list-roots +List the GC roots owned by the user; when run as root, list @emph{all} the GC +roots. + @item --clear-failures Remove the specified store items from the failed-build cache. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6f37b767ff..2606e20deb 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, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (guix scripts gc) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) + #:use-module (guix store roots) #:autoload (guix build syscalls) (free-disk-space) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -48,6 +49,8 @@ (define (show-help) -F, --free-space=FREE attempt to reach FREE available space in the store")) (display (G_ " -d, --delete attempt to delete PATHS")) + (display (G_ " + --list-roots list the user's garbage collector roots")) (display (G_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -135,6 +138,10 @@ (define %options (alist-cons 'verify-options options (alist-delete 'action result)))))) + (option '("list-roots") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-roots + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -205,6 +212,15 @@ (define (ensure-free-space store space) (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) + (define (list-roots) + ;; List all the user-owned GC roots. + (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?) + (gc-roots)))) + (for-each (lambda (root) + (display root) + (newline)) + roots))) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) @@ -238,6 +254,9 @@ (define (list-relatives relatives) (else (let-values (((paths freed) (collect-garbage store))) (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))))) + ((list-roots) + (assert-no-extra-arguments) + (list-roots)) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index ef2d9543b7..8284287730 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès +# Copyright © 2013, 2015, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -34,7 +34,7 @@ unset drv unset out # For some operations, passing extra arguments is an error. -for option in "" "-C 500M" "--verify" "--optimize" +for option in "" "-C 500M" "--verify" "--optimize" "--list-roots" do if guix gc $option whatever; then false; else true; fi done @@ -69,6 +69,8 @@ guix gc --delete "$drv" drv="`guix build --root=guix-gc-root lsh -d`" test -f "$drv" && test -L guix-gc-root +guix gc --list-roots | grep "$PWD/guix-gc-root" + guix gc --list-live | grep "$drv" if guix gc --delete "$drv"; then false; else true; fi -- cgit v1.2.3 From c872b952c527cb42766654d12059d5ea5224ca6c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:05:27 +0200 Subject: profiles: Add 'generation-profile'. * guix/profiles.scm (%profile-generation-rx): New variable. (generation-profile): New procedure. --- guix/profiles.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 6564526aee..dfc9ba1ca0 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -118,6 +118,7 @@ (define-module (guix profiles) profile-search-paths generation-number + generation-profile generation-numbers profile-generations relative-generation-spec->number @@ -1552,6 +1553,20 @@ (define (generation-number profile) (compose string->number (cut match:substring <> 1))) 0)) +(define %profile-generation-rx + ;; Regexp that matches profile generation. + (make-regexp "(.*)-([0-9]+)-link$")) + +(define (generation-profile file) + "If FILE is a profile generation GC root such as \"guix-profile-42-link\", +return its corresponding profile---e.g., \"guix-profile\". Otherwise return +#f." + (match (regexp-exec %profile-generation-rx file) + (#f #f) + (m (let ((profile (match:substring m 1))) + (and (file-exists? (string-append profile "/manifest")) + profile))))) + (define (generation-numbers profile) "Return the sorted list of generation numbers of PROFILE, or '(0) if no former profiles were found." -- cgit v1.2.3 From 96b8c2e6e2aa00b7b400530b62cf7479aa2d9674 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:14:19 +0200 Subject: guix gc: Add '--delete-generations'. * guix/scripts/gc.scm (show-help, %options): Add '--delete-generations'. Change '--delete' shorthand to '-D'. (delete-old-generations): New procedure. (guix-gc)[delete-generations]: New procedure. Call it when ACTION is 'collect-garbage' and OPTS contains 'delete-generations. * doc/guix.texi (Invoking guix gc): Document it. --- doc/guix.texi | 16 +++++++++++++++- guix/scripts/gc.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 59 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2345617b2e..406bea34d1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3438,8 +3438,22 @@ as @code{500MiB}, as described above. When @var{free} or more is already available in @file{/gnu/store}, do nothing and exit immediately. +@item --delete-generations[=@var{duration}] +@itemx -d [@var{duration}] +Before starting the garbage collection process, delete all the generations +older than @var{duration}, for all the user profiles; when run as root, this +applies to all the profiles @emph{of all the users}. + +For example, this command deletes all the generations of all your profiles +that are older than 2 months (except generations that are current), and then +proceeds to free space until at least 10 GiB are available: + +@example +guix gc -d 2m -F 10G +@end example + @item --delete -@itemx -d +@itemx -D Attempt to delete all the store files and directories specified as arguments. This fails if some of the files are not in the store, or if they are still live. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 2606e20deb..00f1eb8d00 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -22,6 +22,8 @@ (define-module (guix scripts gc) #:use-module (guix store) #:use-module (guix store roots) #:autoload (guix build syscalls) (free-disk-space) + #:autoload (guix profiles) (generation-profile) + #:autoload (guix scripts package) (delete-generations) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -48,7 +50,10 @@ (define (show-help) (display (G_ " -F, --free-space=FREE attempt to reach FREE available space in the store")) (display (G_ " - -d, --delete attempt to delete PATHS")) + -d, --delete-generations[=PATTERN] + delete profile generations matching PATTERN")) + (display (G_ " + -D, --delete attempt to delete PATHS")) (display (G_ " --list-roots list the user's garbage collector roots")) (display (G_ " @@ -98,6 +103,16 @@ (define argument->verify-options lst) '())))) +(define (delete-old-generations store profile pattern) + "Remove the generations of PROFILE that match PATTERN, a duration pattern. +Do nothing if none matches." + (let* ((current (generation-number profile)) + (numbers (matching-generations pattern profile + #:duration-relation >))) + + ;; Make sure we don't inadvertently remove the current generation. + (delete-generations store profile (delv current numbers)))) + (define %options ;; Specification of the command-line options. (list (option '(#\h "help") #f #f @@ -123,10 +138,25 @@ (define %options (option '(#\F "free-space") #t #f (lambda (opt name arg result) (alist-cons 'free-space (size->number arg) result))) - (option '(#\d "delete") #f #f + (option '(#\D "delete") #f #f ;used to be '-d' (lower case) (lambda (opt name arg result) (alist-cons 'action 'delete (alist-delete 'action result)))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (if (and arg (store-path? arg)) + (begin + (warning (G_ "'-d' as an alias for '--delete' \ +is deprecated; use '-D'~%")) + `((action . delete) + (argument . ,arg) + (alist-delete 'action result))) + (begin + (when (and arg (not (string->duration arg))) + (leave (G_ "~s does not denote a duration~%") + arg)) + (alist-cons 'delete-generations (or arg "") + result))))) (option '("optimize") #f #f (lambda (opt name arg result) (alist-cons 'action 'optimize @@ -212,6 +242,14 @@ (define (ensure-free-space store space) (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) + (define (delete-generations store pattern) + ;; Delete the generations matching PATTERN of all the user's profiles. + (let ((profiles (delete-duplicates + (filter-map generation-profile (gc-roots))))) + (for-each (lambda (profile) + (delete-old-generations store profile pattern)) + profiles))) + (define (list-roots) ;; List all the user-owned GC roots. (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?) @@ -245,6 +283,10 @@ (define (list-relatives relatives) (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed)) (free-space (assoc-ref opts 'free-space))) + (match (assoc-ref opts 'delete-generations) + (#f #t) + ((? string? pattern) + (delete-generations store pattern))) (cond (free-space (ensure-free-space store free-space)) -- cgit v1.2.3 From 9c074f61ef1883ae01fcb9daa0c199c46b1ea584 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:19:36 +0200 Subject: scripts: GC hint suggests 'guix gc -d 1m'. * guix/scripts.scm (warn-about-disk-space): Suggest 'guix gc -d'. --- guix/scripts.scm | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index e4b11d295d..77cbf12350 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -201,16 +201,12 @@ (define* (warn-about-disk-space #:optional profile (when (< ratio threshold) (warning (G_ "only ~,1f% of free space available on ~a~%") (* ratio 100) (%store-prefix)) - (if profile - (display-hint (format #f (G_ "Consider deleting old profile + (display-hint (format #f (G_ "Consider deleting old profile generations and collecting garbage, along these lines: @example -guix package -p ~s --delete-generations=1m -guix gc +guix gc --delete-generations=1m @end example\n") - profile)) - (display-hint (G_ "Consider running @command{guix gc} to free -space.")))))) + profile))))) ;;; scripts.scm ends here -- cgit v1.2.3 From 3e159dd0a46ba785f8a09bd86e6cacb5c1708bc9 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 3 Apr 2019 20:11:54 +0200 Subject: import: opam: Add more patterns to opam file parser. * guix/import/opam.scm: Add more patterns to peg parser. (choice-pat choice condition-not condition-paren): New patterns. (ground-value condition-content condition-var): Update patterns. --- guix/import/opam.scm | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 36028a01d6..b5069cd2f3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -58,7 +58,12 @@ (define-peg-pattern record all (and key COLON (* SP) value)) (define-peg-pattern weird-record all (and key (* SP) dict)) (define-peg-pattern key body (+ (or (range #\a #\z) "-"))) (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP))) -(define-peg-pattern ground-value body (and (or multiline-string string-pat list-pat var) (* SP))) +(define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")"))) +(define-peg-pattern choice body + (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice) + conditional-value + ground-value)) +(define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP))) (define-peg-pattern conditional-value all (and ground-value (* SP) condition)) (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE)) (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]"))) @@ -80,7 +85,8 @@ (define-peg-pattern condition-form body (define-peg-pattern condition-form2 body (and (* SP) (or condition-greater-or-equal condition-greater condition-lower-or-equal condition-lower - condition-neq condition-eq condition-content) (* SP))) + condition-neq condition-eq condition-not + condition-content) (* SP))) ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string)) (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string)) @@ -91,10 +97,12 @@ (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&" (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form)) (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content)) (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content)) -(define-peg-pattern condition-content body (or condition-string condition-var)) +(define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content)) +(define-peg-pattern condition-content body (or condition-paren condition-string condition-var)) (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) +(define-peg-pattern condition-paren body (and "(" condition-form ")")) (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) -(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-"))) +(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":"))) (define (get-opam-repository) "Update or fetch the latest version of the opam repository and return the @@ -171,18 +179,24 @@ (define (native? condition) (define (dependency->input dependency) (match dependency (('string-pat str) str) + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (if (native? condition) "" (dependency->input val))))) (define (dependency->native-input dependency) (match dependency (('string-pat str) "") + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (if (native? condition) (dependency->input val) "")))) (define (dependency->name dependency) (match dependency (('string-pat str) str) + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (dependency->name val)))) -- cgit v1.2.3 From 7b1c7ecdfbe26b56dbb19aa82874f3ef2df8ab08 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 3 Apr 2019 20:19:24 +0200 Subject: import: opam: Use dune-build-system when possible. * guix/import/opam.scm (opam->guix-package): Detect when dune can be used. --- guix/import/opam.scm | 80 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 48 insertions(+), 32 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index b5069cd2f3..5dcc0e97a3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -247,39 +247,55 @@ (define (opam->guix-package name) (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) - (dependencies (dependency-list->names requirements)) + (dependencies (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + (dependency-list->names requirements))) + (native-dependencies (depends->native-inputs requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) - (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) - (call-with-temporary-output-file - (lambda (temp port) - (and (url-fetch source-url temp) - (values - `(package - (name ,(ocaml-name->guix-name name)) - (version ,(if (string-prefix? "v" version) - (substring version 1) - version)) - (source - (origin - (method url-fetch) - (uri ,source-url) - (sha256 (base32 ,(guix-hash-url temp))))) - (build-system ocaml-build-system) - ,@(if (null? inputs) - '() - `((inputs ,(list 'quasiquote inputs)))) - ,@(if (null? native-inputs) - '() - `((native-inputs ,(list 'quasiquote native-inputs)))) - ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) - '() - `((properties - ,(list 'quasiquote `((upstream-name . ,name)))))) - (home-page ,(metadata-ref opam-content "homepage")) - (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) - (license #f)) - dependencies)))))) + (native-inputs (dependency-list->inputs + ;; Do not add dune nor jbuilder since they are + ;; implicit inputs of the dune-build-system. + (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + native-dependencies)))) + ;; If one of these are required at build time, it means we + ;; can use the much nicer dune-build-system. + (let ((use-dune? (or (member "dune" native-dependencies) + (member "jbuilder" native-dependencies)))) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch source-url temp) + (values + `(package + (name ,(ocaml-name->guix-name name)) + (version ,(if (string-prefix? "v" version) + (substring version 1) + version)) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ,(if use-dune? + 'dune-build-system + 'ocaml-build-system)) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) + '() + `((properties + ,(list 'quasiquote `((upstream-name . ,name)))))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f)) + dependencies))))))) (define (opam-recursive-import package-name) (recursive-import package-name #f -- cgit v1.2.3 From ce6312999f20bb8d7e73c29b315747b1f4d184aa Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 5 Apr 2019 11:41:17 +0200 Subject: Add (guix build-system linux-module). * guix/build/linux-module-build-system.scm: New file. * guix/build-system/linux-module.scm: New file. * doc/guix.texi (Build Systems): Document it. * Makefile.am (MODULES): Add them. --- Makefile.am | 2 + doc/guix.texi | 27 +++++ guix/build-system/linux-module.scm | 166 +++++++++++++++++++++++++++++++ guix/build/linux-module-build-system.scm | 78 +++++++++++++++ 4 files changed, 273 insertions(+) create mode 100644 guix/build-system/linux-module.scm create mode 100644 guix/build/linux-module-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 704f2451c3..8d523262cb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -120,6 +120,7 @@ MODULES = \ guix/build-system/gnu.scm \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ + guix/build-system/linux-module.scm \ guix/build-system/perl.scm \ guix/build-system/python.scm \ guix/build-system/ocaml.scm \ @@ -173,6 +174,7 @@ MODULES = \ guix/build/texlive-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ + guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ guix/build/utils.scm \ guix/build/union.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 7dc4e1894a..9be7d9a27b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6210,6 +6210,33 @@ is not enabled by default. It can be enabled with @code{#:glib-or-gtk?}. @end table @end defvr +@defvr {Scheme Variable} linux-module-build-system +@var{linux-module-build-system} allows building Linux kernel modules. + +@cindex build phases +This build system is an extension of @var{gnu-build-system}, but with the +following phases changed: + +@table @code + +@item configure +This phase configures the environment so that the Linux kernel's Makefile +can be used to build the external kernel module. + +@item build +This phase uses the Linux kernel's Makefile in order to build the external +kernel module. + +@item install +This phase uses the Linux kernel's Makefile in order to install the external +kernel module. +@end table + +It is possible and useful to specify the Linux kernel to use for building +the module (in the "arguments" form of a package using the +linux-module-build-system, use the key #:linux to specify it). +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm new file mode 100644 index 0000000000..3ed3351353 --- /dev/null +++ b/guix/build-system/linux-module.scm @@ -0,0 +1,166 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic +;;; +;;; 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 linux-module) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (%linux-module-build-system-modules + linux-module-build + linux-module-build-system)) + +;; Commentary: +;; +;; Code: + +(define %linux-module-build-system-modules + ;; Build-side modules imported by default. + `((guix build linux-module-build-system) + ,@%gnu-build-system-modules)) + +(define (default-linux) + "Return the default Linux package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages linux)))) + (module-ref module 'linux-libre))) + +(define (default-kmod) + "Return the default kmod package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages linux)))) + (module-ref module 'kmod))) + +(define (default-gcc) + "Return the default gcc package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages gcc)))) + (module-ref module 'gcc-7))) + +(define (make-linux-module-builder linux) + (package + (inherit linux) + (name (string-append (package-name linux) "-module-builder")) + (arguments + (substitute-keyword-arguments (package-arguments linux) + ((#:phases phases) + `(modify-phases ,phases + (replace 'build + (lambda _ + (invoke "make" "modules_prepare"))) + (delete 'strip) ; faster. + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (out-lib-build (string-append out "/lib/modules/build"))) + ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config". + (copy-recursively "." out-lib-build) + #t))))))))) + +(define* (lower name + #:key source inputs native-inputs outputs + system target + (linux (default-linux)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs `(("linux" ,linux) ; for "Module.symvers". + ("linux-module-builder" + ,(make-linux-module-builder linux)) + ,@native-inputs + ;; TODO: Remove "gmp", "mpfr", "mpc" since they are only needed to compile the gcc plugins. Maybe remove "flex", "bison", "elfutils", "perl", "openssl". That leaves very little ("bc", "gcc", "kmod"). + ,@(package-native-inputs linux))) + (outputs outputs) + (build linux-module-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (linux-module-build store name inputs + #:key + (search-paths '()) + (tests? #t) + (phases '(@ (guix build linux-module-build-system) + %standard-phases)) + (outputs '("out")) + (system (%current-system)) + (guile #f) + (imported-modules + %linux-module-build-system-modules) + (modules '((guix build linux-module-build-system) + (guix build utils)))) + "Build SOURCE using LINUX, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (linux-module-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:system ,system + #:tests? ,tests? + #:outputs %outputs + #: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 + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define linux-module-build-system + (build-system + (name 'linux-module) + (description "The Linux module build system") + (lower lower))) + +;;; linux-module.scm ends here diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm new file mode 100644 index 0000000000..a6664f1eca --- /dev/null +++ b/guix/build/linux-module-build-system.scm @@ -0,0 +1,78 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic +;;; +;;; 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 linux-module-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + linux-module-build)) + +;; Commentary: +;; +;; Builder-side code of linux-module build. +;; +;; Code: + +;; TODO: It might make sense to provide "Module.symvers" in the future. +(define* (configure #:key inputs #:allow-other-keys) + #t) + +(define* (build #:key inputs make-flags #:allow-other-keys) + (apply invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (or make-flags '()))) + +;; This block was copied from make-linux-libre--only took the "modules_install" +;; part. +(define* (install #:key inputs native-inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (moddir (string-append out "/lib/modules")) + (kmod (assoc-ref (or native-inputs inputs) "kmod"))) + ;; Install kernel modules + (mkdir-p moddir) + (invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (string-append "DEPMOD=" kmod "/bin/depmod") + (string-append "MODULE_DIR=" moddir) + (string-append "INSTALL_PATH=" out) + (string-append "INSTALL_MOD_PATH=" out) + "INSTALL_MOD_STRIP=1" + "modules_install"))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'install install))) + +(define* (linux-module-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) + +;;; linux-module-build-system.scm ends here -- cgit v1.2.3 From c1df77e215b6e69dccbe781307836a3b962c5968 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 16:55:13 +0200 Subject: guix gc: '-d' does not attempt to delete non-user-owned roots. * guix/scripts/gc.scm (guix-gc)[delete-generations]: Limit to user-owned roots, unless we're running as root. --- guix/scripts/gc.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 00f1eb8d00..9a57e5fd1e 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -245,7 +245,11 @@ (define (ensure-free-space store space) (define (delete-generations store pattern) ;; Delete the generations matching PATTERN of all the user's profiles. (let ((profiles (delete-duplicates - (filter-map generation-profile (gc-roots))))) + (filter-map (lambda (root) + (and (or (zero? (getuid)) + (user-owned? root)) + (generation-profile root))) + (gc-roots))))) (for-each (lambda (profile) (delete-old-generations store profile pattern)) profiles))) -- cgit v1.2.3 From 2569ef9dab4f796a75b8cdddd57d3be37b142036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 16:57:38 +0200 Subject: colors: Introduce a disjoint type and pre-compute ANSI escapes. * guix/colors.scm (color-table, color): Remove. (): New record type. (print-color): New procedure. (define-color-table, color): New macros. (color-codes->ansi): New procedure. (%reset): New variable. (colorize-string): Rewrite accordingly. (color-rules): Adjust accordingly. * guix/status.scm (print-build-event): Adjust to new 'colorize-string' interface. * guix/ui.scm (%highlight-argument): Likewise. (%warning-colors, %info-colors, %error-colors, %hint-colors) (%highlight-colors): Remove. (%warning-color, %info-color, %error-color, %hint-color) (%highlight-color): New variables. --- guix/colors.scm | 138 +++++++++++++++++++++++++++++++++++--------------------- guix/status.scm | 6 +-- guix/ui.scm | 26 +++++------ 3 files changed, 103 insertions(+), 67 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index fad0bd2ab9..b7d3f6d4ec 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -22,9 +22,14 @@ (define-module (guix colors) #:use-module (guix memoization) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:export (colorize-string + #:export (color + color? + + colorize-string color-rules color-output? isatty?*)) @@ -35,55 +40,86 @@ (define-module (guix colors) ;;; ;;; Code: -(define color-table - `((CLEAR . "0") - (RESET . "0") - (BOLD . "1") - (DARK . "2") - (UNDERLINE . "4") - (UNDERSCORE . "4") - (BLINK . "5") - (REVERSE . "6") - (CONCEALED . "8") - (BLACK . "30") - (RED . "31") - (GREEN . "32") - (YELLOW . "33") - (BLUE . "34") - (MAGENTA . "35") - (CYAN . "36") - (WHITE . "37") - (ON-BLACK . "40") - (ON-RED . "41") - (ON-GREEN . "42") - (ON-YELLOW . "43") - (ON-BLUE . "44") - (ON-MAGENTA . "45") - (ON-CYAN . "46") - (ON-WHITE . "47"))) - -(define (color . lst) - "Return a string containing the ANSI escape sequence for producing the -requested set of attributes in LST. Unknown attributes are ignored." - (let ((color-list - (remove not - (map (lambda (color) (assq-ref color-table color)) - lst)))) - (if (null? color-list) - "" - (string-append - (string #\esc #\[) - (string-join color-list ";" 'infix) - "m")))) - -(define (colorize-string str . color-list) - "Return a copy of STR colorized using ANSI escape sequences according to the -attributes STR. At the end of the returned string, the color attributes will -be reset such that subsequent output will not have any colors in effect." - (string-append - (apply color color-list) - str - (color 'RESET))) +;; Record type for "colors", which are actually lists of color attributes. +(define-record-type + (make-color symbols ansi) + color? + (symbols color-symbols) + (ansi color-ansi)) + +(define (print-color color port) + (format port "#" + (string-join (map symbol->string + (color-symbols color))))) + +(set-record-type-printer! print-color) + +(define-syntax define-color-table + (syntax-rules () + "Define NAME as a macro that builds a list of color attributes." + ((_ name (color escape) ...) + (begin + (define-syntax color-codes + (syntax-rules (color ...) + ((_) + '()) + ((_ color rest (... ...)) + `(escape ,@(color-codes rest (... ...)))) + ...)) + + (define-syntax-rule (name colors (... ...)) + "Return a list of color attributes that can be passed to +'colorize-string'." + (make-color '(colors (... ...)) + (color-codes->ansi (color-codes colors (... ...))))))))) + +(define-color-table color + (CLEAR "0") + (RESET "0") + (BOLD "1") + (DARK "2") + (UNDERLINE "4") + (UNDERSCORE "4") + (BLINK "5") + (REVERSE "6") + (CONCEALED "8") + (BLACK "30") + (RED "31") + (GREEN "32") + (YELLOW "33") + (BLUE "34") + (MAGENTA "35") + (CYAN "36") + (WHITE "37") + (ON-BLACK "40") + (ON-RED "41") + (ON-GREEN "42") + (ON-YELLOW "43") + (ON-BLUE "44") + (ON-MAGENTA "45") + (ON-CYAN "46") + (ON-WHITE "47")) + +(define (color-codes->ansi codes) + "Convert CODES, a list of color attribute codes, to a ANSI escape string." + (match codes + (() + "") + (_ + (string-append (string #\esc #\[) + (string-join codes ";" 'infix) + "m")))) + +(define %reset + (color RESET)) + +(define (colorize-string str color) + "Return a copy of STR colorized using ANSI escape sequences according to +COLOR. At the end of the returned string, the color attributes are reset such +that subsequent output will not have any colors in effect." + (string-append (color-ansi color) + str + (color-ansi %reset))) (define isatty?* (mlambdaq (port) @@ -114,7 +150,7 @@ (define-syntax color-rules (match (regexp-exec rx str) (#f (next str)) (m (let loop ((n 1) - (c '(colors ...)) + (c (list (color colors) ...)) (result '())) (match c (() diff --git a/guix/status.scm b/guix/status.scm index 7edb558ee7..cbea4151f2 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -410,17 +410,17 @@ (define* (print-build-event event old-status status addition to build events." (define info (if colorize? - (cut colorize-string <> 'BOLD) + (cute colorize-string <> (color BOLD)) identity)) (define success (if colorize? - (cut colorize-string <> 'GREEN 'BOLD) + (cute colorize-string <> (color GREEN BOLD)) identity)) (define failure (if colorize? - (cut colorize-string <> 'RED 'BOLD) + (cute colorize-string <> (color RED BOLD)) identity)) (define (report-build-progress phase %) diff --git a/guix/ui.scm b/guix/ui.scm index c3612d92b4..2481a1b78b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -158,7 +158,7 @@ (define* (%highlight-argument arg #:optional (port (guix-warning-port))) (define highlight (if (color-output? port) (lambda (str) - (apply colorize-string str %highlight-colors)) + (colorize-string str %highlight-color)) identity)) (cond ((string? arg) @@ -206,9 +206,9 @@ (define-syntax name ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; "~a" is a placeholder for that phrase. -(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning -(define-diagnostic info (G_ "") %info-colors) -(define-diagnostic report-error (G_ "error: ") %error-colors) +(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning +(define-diagnostic info (G_ "") %info-color) +(define-diagnostic report-error (G_ "error: ") %error-color) (define-syntax-rule (leave args ...) "Emit an error message and exit." @@ -216,27 +216,27 @@ (define-syntax-rule (leave args ...) (report-error args ...) (exit 1))) -(define %warning-colors '(BOLD MAGENTA)) -(define %info-colors '(BOLD)) -(define %error-colors '(BOLD RED)) -(define %hint-colors '(BOLD CYAN)) -(define %highlight-colors '(BOLD)) +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) +(define %hint-color (color BOLD CYAN)) +(define %highlight-color (color BOLD)) (define* (print-diagnostic-prefix prefix #:optional location - #:key (colors '())) + #:key (colors (color))) "Print PREFIX as a diagnostic line prefix." (define color? (color-output? (guix-warning-port))) (define location-color (if color? - (cut colorize-string <> 'BOLD) + (cut colorize-string <> (color BOLD)) identity)) (define prefix-color (if color? (lambda (prefix) - (apply colorize-string prefix colors)) + (colorize-string prefix colors)) identity)) (let ((prefix (if (string-null? prefix) @@ -404,7 +404,7 @@ (define* (display-hint message #:optional (port (current-error-port))) (define colorize (if (color-output? port) (lambda (str) - (apply colorize-string str %hint-colors)) + (colorize-string str %hint-color)) identity)) (display (colorize (G_ "hint: ")) port) -- cgit v1.2.3 From 544265acba89a41691c6be5b4af8e3c2237cd5c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 17:17:38 +0200 Subject: colors: Add 'colorize-matches'. * guix/colors.scm (colorize-matches): New procedure. (color-rules): Rewrite in terms of 'colorize-matches'. --- guix/colors.scm | 55 ++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 34 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index b7d3f6d4ec..30ad231dfe 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -132,34 +132,47 @@ (define (color-output? port) (not (getenv "NO_COLOR")) (isatty?* port))) -(define-syntax color-rules - (syntax-rules () - "Return a procedure that colorizes the string it is passed according to -the given rules. Each rule has the form: +(define (colorize-matches rules) + "Return a procedure that, when passed a string, returns that string +colorized according to RULES. RULES must be a list of tuples like: (REGEXP COLOR1 COLOR2 ...) where COLOR1 specifies how to colorize the first submatch of REGEXP, and so on." - ((_ (regexp colors ...) rest ...) - (let ((next (color-rules rest ...)) - (rx (make-regexp regexp))) - (lambda (str) - (if (string-index str #\nul) - str - (match (regexp-exec rx str) - (#f (next str)) + (lambda (str) + (if (string-index str #\nul) + str + (let loop ((rules rules)) + (match rules + (() + str) + (((regexp . colors) . rest) + (match (regexp-exec regexp str) + (#f (loop rest)) (m (let loop ((n 1) - (c (list (color colors) ...)) - (result '())) - (match c + (colors colors) + (result (list (match:prefix m)))) + (match colors (() - (string-concatenate-reverse result)) + (string-concatenate-reverse + (cons (match:suffix m) result))) ((first . tail) - (loop (+ n 1) tail + (loop (+ n 1) + tail (cons (colorize-string (match:substring m n) first) - result))))))))))) - ((_) - (lambda (str) - str)))) + result))))))))))))) + +(define-syntax color-rules + (syntax-rules () + "Return a procedure that colorizes the string it is passed according to +the given rules. Each rule has the form: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + ((_ (regexp colors ...) ...) + (colorize-matches `((,(make-regexp regexp) ,(color colors) ...) + ...))))) -- cgit v1.2.3 From 88e13c2587ab9a0f96bb63488c253fb14ac9ff60 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Thu, 11 Apr 2019 23:49:43 +0200 Subject: build-system/linux-module: Support module source versioning. * guix/build-system/linux-module.scm (make-linux-module-builder) [native-inputs]: Add linux. [arguments]<#:phases>[install]: Install "System.map" and "Module.symvers". * guix/build/linux-module-build-system.scm (configure): Delete procedure. (%standard-phases): Delete "configure" phase. --- guix/build-system/linux-module.scm | 11 ++++++++++- guix/build/linux-module-build-system.scm | 6 +----- 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 3ed3351353..6084d22210 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -63,6 +63,9 @@ (define (make-linux-module-builder linux) (package (inherit linux) (name (string-append (package-name linux) "-module-builder")) + (native-inputs + `(("linux" ,linux) + ,@(package-native-inputs linux))) (arguments (substitute-keyword-arguments (package-arguments linux) ((#:phases phases) @@ -72,11 +75,17 @@ (define (make-linux-module-builder linux) (invoke "make" "modules_prepare"))) (delete 'strip) ; faster. (replace 'install - (lambda* (#:key outputs #:allow-other-keys) + (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (out-lib-build (string-append out "/lib/modules/build"))) ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config". (copy-recursively "." out-lib-build) + (let* ((linux (assoc-ref inputs "linux"))) + (install-file (string-append linux "/System.map") + out-lib-build) + (let ((source (string-append linux "/Module.symvers"))) + (if (file-exists? source) + (install-file source out-lib-build)))) #t))))))))) (define* (lower name diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index a6664f1eca..01cb8cef6c 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -32,10 +32,6 @@ (define-module (guix build linux-module-build-system) ;; ;; Code: -;; TODO: It might make sense to provide "Module.symvers" in the future. -(define* (configure #:key inputs #:allow-other-keys) - #t) - (define* (build #:key inputs make-flags #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") @@ -64,7 +60,7 @@ (define* (install #:key inputs native-inputs outputs #:allow-other-keys) (define %standard-phases (modify-phases gnu:%standard-phases - (replace 'configure configure) + (delete 'configure) (replace 'build build) (replace 'install install))) -- cgit v1.2.3 From 0b30a1a072de0dd288519bde6b401a3e906eff84 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 12 Apr 2019 00:43:36 +0200 Subject: build-system/linux-module: Configure module like the kernel. * guix/build/linux-module-build-system.scm (configure): New procedure. (%standard-phases): Add "configure" phase. --- guix/build/linux-module-build-system.scm | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 01cb8cef6c..cd76df2de7 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -32,6 +32,23 @@ (define-module (guix build linux-module-build-system) ;; ;; Code: +;; Copied from make-linux-libre's "configure" phase. +(define* (configure #:key inputs target #:allow-other-keys) + (setenv "KCONFIG_NOTIMESTAMP" "1") + (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) + ;(let ((arch ,(system->linux-architecture + ; (or (%current-target-system) + ; (%current-system))))) + ; (setenv "ARCH" arch) + ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))) + (when target + (setenv "CROSS_COMPILE" (string-append target "-")) + (format #t "`CROSS_COMPILE' set to `~a'~%" + (getenv "CROSS_COMPILE"))) + ; TODO: (setenv "EXTRA_VERSION" ,extra-version) + ; TODO: kernel ".config". + #t) + (define* (build #:key inputs make-flags #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") @@ -60,7 +77,7 @@ (define* (install #:key inputs native-inputs outputs #:allow-other-keys) (define %standard-phases (modify-phases gnu:%standard-phases - (delete 'configure) + (replace 'configure configure) (replace 'build build) (replace 'install install))) -- cgit v1.2.3 From c1c5d68a94e219d0e56d5dc0e0d6ed9b08076a30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Apr 2019 19:48:19 +0200 Subject: colors: Add 'highlight'. * guix/colors.scm (%highlight-color): New variable. (highlight): New procedure. * guix/ui.scm (%highlight-argument)[highlight]: Remove. (%highlight-color): Remove. --- guix/colors.scm | 10 ++++++++++ guix/ui.scm | 11 ++--------- 2 files changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index 30ad231dfe..7949cf5763 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -30,6 +30,7 @@ (define-module (guix colors) color? colorize-string + highlight color-rules color-output? isatty?*)) @@ -132,6 +133,15 @@ (define (color-output? port) (not (getenv "NO_COLOR")) (isatty?* port))) +(define %highlight-color (color BOLD)) + +(define* (highlight str #:optional (port (current-output-port))) + "Return STR with extra ANSI color attributes to highlight it if PORT +supports it." + (if (color-output? port) + (colorize-string str %highlight-color) + str)) + (define (colorize-matches rules) "Return a procedure that, when passed a string, returns that string colorized according to RULES. RULES must be a list of tuples like: diff --git a/guix/ui.scm b/guix/ui.scm index 2481a1b78b..39b13fd4bc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -155,16 +155,10 @@ (define len (define* (%highlight-argument arg #:optional (port (guix-warning-port))) "Highlight ARG, a format string argument, if PORT supports colors." - (define highlight - (if (color-output? port) - (lambda (str) - (colorize-string str %highlight-color)) - identity)) - (cond ((string? arg) - (highlight arg)) + (highlight arg port)) ((symbol? arg) - (highlight (symbol->string arg))) + (highlight (symbol->string arg) port)) (else arg))) (define-syntax define-diagnostic @@ -220,7 +214,6 @@ (define %warning-color (color BOLD MAGENTA)) (define %info-color (color BOLD)) (define %error-color (color BOLD RED)) (define %hint-color (color BOLD CYAN)) -(define %highlight-color (color BOLD)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors (color))) -- cgit v1.2.3 From 3dae43a92975cb6a1055e928523122bc340272fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Apr 2019 19:49:38 +0200 Subject: ui: Highlight heading of generation lists. * guix/ui.scm (display-generation): Highlight the "Generation" heading. --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 39b13fd4bc..92c845e944 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1564,7 +1564,7 @@ (define generation-ctime-alist (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (G_ "Generation ~a\t~a") number + (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number (date->string (time-utc->date (generation-time profile number)) -- cgit v1.2.3 From 4aea820f0954fce4d076718072faf211f62f3f9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Apr 2019 16:57:12 +0200 Subject: guix build: Fix relative file name canonicalization for '--root'. Fixes . Reported by rendaw <7e9wc56emjakcm@s.rendaw.me>. * guix/scripts/build.scm (register-root): When ROOT is a relative file name, append the basename of ROOT, not ROOT itself. * tests/guix-build.sh: Add test. --- guix/scripts/build.scm | 2 +- tests/guix-build.sh | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 28864435df..fc0c0e2ad3 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,7 @@ (define (register-root store paths root) (let* ((root (if (string-prefix? "/" root) root (string-append (canonicalize-path (dirname root)) - "/" root)))) + "/" (basename root))))) (catch 'system-error (lambda () (match paths diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 66bf6be8d0..d479296ef1 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -183,6 +183,13 @@ then false; else true; fi rm -f "$result" +# Check relative file name canonicalization: . +mkdir "$result" +guix build -r "$result/x" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' +test -x "$result/x/bin/guile" +rm "$result/x" +rmdir "$result" + # Cross building. guix build coreutils --target=mips64el-linux-gnu --dry-run --no-substitutes -- cgit v1.2.3 From 3961edf2304bcff4c402a29868f8c559a03c0663 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 10:26:46 +0200 Subject: store: Memoize 'built-in-builders' call directly in . The caching strategy introduced in 40cc850aebb497faed0a11d867d8fcee729023df was ineffective since we regularly start from an empty object cache. For example, "guix build inkscape -n" would make 241 'built-in-builders' RPCs. * guix/store.scm ()[built-in-builders]: New field. (open-connection): Adjust '%make-store-connection' call accordingly. (port->connection): Likewise. (built-in-builders): Rename to... (%built-in-builders): ... this. (built-in-builders): New procedure. * guix/download.scm (built-in-builders*): Remove 'mcached' call. --- guix/download.scm | 8 ++------ guix/store.scm | 49 ++++++++++++++++++++++++++++++++----------------- 2 files changed, 34 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 8865777818..11984cf671 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Andreas Enge ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Alex Griffin @@ -415,11 +415,7 @@ (define %content-addressed-mirror-file (object->string %content-addressed-mirrors))) (define built-in-builders* - (let ((proc (store-lift built-in-builders))) - (lambda () - "Return, as a monadic value, the list of built-in builders supported by -the daemon; cache the return value." - (mcached (proc) built-in-builders)))) + (store-lift built-in-builders)) (define* (built-in-download file-name url #:key system hash-algo hash diff --git a/guix/store.scm b/guix/store.scm index fdd04f349d..9c195c335c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -368,7 +368,9 @@ (define-record-type* store-connection %make-store-connection (ats-cache store-connection-add-to-store-cache) (atts-cache store-connection-add-text-to-store-cache) (object-cache store-connection-object-cache - (default vlist-null))) ;vhash + (default vlist-null)) ;vhash + (built-in-builders store-connection-built-in-builders + (default (delay '())))) ;promise (set-record-type-printer! (lambda (obj port) @@ -557,13 +559,17 @@ (define* (open-connection #:optional (uri (%daemon-socket-uri)) (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-store-connection port - (protocol-major v) - (protocol-minor v) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (letrec* ((built-in-builders + (delay (%built-in-builders conn))) + (conn + (%make-store-connection port + (protocol-major v) + (protocol-minor v) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null + built-in-builders))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn))))))))) @@ -578,13 +584,17 @@ (define* (port->connection port connection. Use with care." (let-values (((output flush) (buffering-output-port port (make-bytevector 8192)))) - (%make-store-connection port - (protocol-major version) - (protocol-minor version) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (define connection + (%make-store-connection port + (protocol-major version) + (protocol-minor version) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null + (delay (%built-in-builders connection)))) + + connection)) (define (store-connection-version store) "Return the protocol version of STORE as an integer." @@ -1371,13 +1381,13 @@ (define substitutable-path-info order of PATHS." substitutable-path-list)) -(define built-in-builders +(define %built-in-builders (let ((builders (operation (built-in-builders) "Return the built-in builders." string-list))) (lambda (store) "Return the names of the supported built-in derivation builders -supported by STORE." +supported by STORE. The result is memoized for STORE." ;; Check whether STORE's version supports this RPC and built-in ;; derivation builders in general, which appeared in Guix > 0.11.0. ;; Return the empty list if it doesn't. Note that this RPC does not @@ -1388,6 +1398,11 @@ (define built-in-builders (builders store) '())))) +(define (built-in-builders store) + "Return the names of the supported built-in derivation builders +supported by STORE." + (force (store-connection-built-in-builders store))) + (define-operation (optimize-store) "Optimize the store by hard-linking identical files (\"deduplication\".) Return #t on success." -- cgit v1.2.3 From e856177597b5a7f1b75bb4083ad1e0b50323c82e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 11:42:18 +0200 Subject: derivations: Reduce 'valid-path?' RPCs in 'derivation-prerequisites-to-build'. On a profile with 280 packages, this reduces the number of 'valid-paths?' RPCs made by 'guix package -nu' from 6K to 500. * guix/derivations.scm (derivation-prerequisites-to-build)[built?]: Memoize 'valid-path?' calls. --- guix/derivations.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index fb2fa177be..7a5c3bca94 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -344,7 +344,8 @@ (define* (derivation-prerequisites-to-build store drv 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 <>)) + (mlambda (item) + (valid-path? store item))) (define input-built? (compose (cut any built? <>) derivation-input-output-paths)) -- cgit v1.2.3 From d1f7748a2e41f2ca320eca56b366933b8aa1123c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 11:46:17 +0200 Subject: store: Add "add-data-to-store-cache" profiling component. * guix/store.scm (add-data-to-store): Define 'lookup' and use it instead of 'hash-ref'. --- guix/store.scm | 42 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 40 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 9c195c335c..1b485ab5fa 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -996,14 +996,52 @@ (define add-data-to-store (operation (add-text-to-store (string name) (bytevector text) (string-list references)) #f - store-path))) + store-path)) + (lookup (if (profiled? "add-data-to-store-cache") + (let ((lookups 0) + (hits 0) + (drv 0) + (scheme 0)) + (define (show-stats) + (define (% n) + (if (zero? lookups) + 100. + (* 100. (/ n lookups)))) + + (format (current-error-port) " +'add-data-to-store' cache: + lookups: ~5@a + hits: ~5@a (~,1f%) + .drv files: ~5@a (~,1f%) + Scheme files: ~5@a (~,1f%)~%" + lookups hits (% hits) + drv (% drv) + scheme (% scheme))) + + (register-profiling-hook! "add-data-to-store-cache" + show-stats) + (lambda (cache args) + (let ((result (hash-ref cache args))) + (set! lookups (+ 1 lookups)) + (when result + (set! hits (+ 1 hits))) + (match args + ((_ name _) + (cond ((string-suffix? ".drv" name) + (set! drv (+ drv 1))) + ((string-suffix? "-builder" name) + (set! scheme (+ scheme 1))) + ((string-suffix? ".scm" name) + (set! scheme (+ scheme 1)))))) + result))) + hash-ref))) (lambda* (server name bytes #:optional (references '())) "Add BYTES under file NAME in the store, and return its store path. REFERENCES is the list of store paths referred to by the resulting store path." (let* ((args `(,bytes ,name ,references)) (cache (store-connection-add-text-to-store-cache server))) - (or (hash-ref cache args) + (or (lookup cache args) (let ((path (add-text-to-store server name bytes references))) (hash-set! cache args path) path)))))) -- cgit v1.2.3