diff options
Diffstat (limited to 'guix')
47 files changed, 2061 insertions, 580 deletions
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 @@ to NAME and VERSION." (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 @@ to NAME and VERSION." 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-system/dune.scm b/guix/build-system/dune.scm index 8bd41c89f0..6a2f3d16de 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -87,6 +87,7 @@ (build-flags ''()) (out-of-source? #t) (jbuild? #f) + (package #f) (tests? #t) (test-flags ''()) (test-target "test") @@ -125,6 +126,7 @@ provides a 'setup.ml' file as its build system." #:build-flags ,build-flags #:out-of-source? ,out-of-source? #:jbuild? ,jbuild? + #:package ,package #:tests? ,tests? #:test-target ,test-target #:install-target ,install-target diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm new file mode 100644 index 0000000000..6084d22210 --- /dev/null +++ b/guix/build-system/linux-module.scm @@ -0,0 +1,175 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system 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")) + (native-inputs + `(("linux" ,linux) + ,@(package-native-inputs linux))) + (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 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 + #: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-system/ocaml.scm b/guix/build-system/ocaml.scm index 07c69fac76..cbd33d9a89 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -28,9 +28,7 @@ #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules package-with-ocaml4.01 - package-with-ocaml4.02 strip-ocaml4.01-variant - strip-ocaml4.02-variant default-findlib default-ocaml lower @@ -94,14 +92,6 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml4.01-findlib))) -(define (default-ocaml4.02) - (let ((ocaml (resolve-interface '(gnu packages ocaml)))) - (module-ref ocaml 'ocaml-4.02))) - -(define (default-ocaml4.02-findlib) - (let ((module (resolve-interface '(gnu packages ocaml)))) - (module-ref module 'ocaml4.02-findlib))) - (define* (package-with-explicit-ocaml ocaml findlib old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package @@ -161,24 +151,12 @@ pre-defined variants." "ocaml-" "ocaml4.01-" #:variant-property 'ocaml4.01-variant)) -(define package-with-ocaml4.02 - (package-with-explicit-ocaml (delay (default-ocaml4.02)) - (delay (default-ocaml4.02-findlib)) - "ocaml-" "ocaml4.02-" - #:variant-property 'ocaml4.02-variant)) - (define (strip-ocaml4.01-variant p) "Remove the 'ocaml4.01-variant' property from P." (package (inherit p) (properties (alist-delete 'ocaml4.01-variant (package-properties p))))) -(define (strip-ocaml4.02-variant p) - "Remove the 'ocaml4.02-variant' property from P." - (package - (inherit p) - (properties (alist-delete 'ocaml4.02-variant (package-properties p))))) - (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) 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 <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #: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 @@ ;; ;; 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 @@ directory = '" port) ;; 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) diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index 027777b4d1..9f7334bc8d 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -215,7 +215,7 @@ results from compiling LIB." (define* (include-list\exclude-list include-list exclude-list #:key all-list) - "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurences of #:all by + "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by slicing ALL-LIST into them and compute their list difference." (define (replace-#:all ls all-ls) (append-map (match-lambda diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index 00b0c7c406..7e2ec1e3e1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -31,27 +31,30 @@ ;; Code: (define* (build #:key (build-flags '()) (jbuild? #f) - (use-make? #f) #:allow-other-keys) + (use-make? #f) (package #f) #:allow-other-keys) "Build the given package." (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "build" "@install" build-flags)) + (apply invoke program "build" "@install" + (append (if package (list "-p" package) '()) build-flags))) #t) (define* (check #:key (test-flags '()) (test-target "test") tests? - (jbuild? #f) #:allow-other-keys) + (jbuild? #f) (package #f) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target test-flags))) + (apply invoke program "runtest" test-target + (append (if package (list "-p" package) '()) test-flags)))) #t) (define* (install #:key outputs (install-target "install") (jbuild? #f) - #:allow-other-keys) + (package #f) #:allow-other-keys) "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out "--libdir" - (string-append out "/lib/ocaml/site-lib"))) + (apply invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib") + (if package (list package) '()))) #t) (define %standard-phases diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 1a716cea77..282df19f24 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -42,7 +42,7 @@ ;; structure called a 'workspace' [1]. This workspace can be found by Go via ;; the GOPATH environment variable. Typically, all Go source code and compiled ;; objects are kept in a single workspace, but GOPATH may be a list of -;; directories [2]. In this go-build-system we create a filesystem union of +;; directories [2]. In this go-build-system we create a file system union of ;; the Go-language dependencies. Previously, we made GOPATH a list of store ;; directories, but stopped because Go programs started keeping references to ;; these directories in Go 1.11: @@ -127,7 +127,7 @@ ;; Code: (define* (setup-go-environment #:key inputs outputs #:allow-other-keys) - "Prepare a Go build environment for INPUTS and OUTPUTS. Build a filesystem + "Prepare a Go build environment for INPUTS and OUTPUTS. Build a file system union of INPUTS. Export GOPATH, which helps the compiler find the source code of the package being built and its dependencies, and GOBIN, which determines where executables (\"commands\") are installed to. This phase is sometimes used diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 0bed049436..31f0d3d6f4 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -65,6 +65,62 @@ Return #false if it cannot be determined." (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")) #t))) +(define* (invoke-each commands + #:key (max-processes (current-processor-count)) + report-progress) + "Run each command in COMMANDS in a separate process, using up to +MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step. +Raise an error if one of the processes exit with non-zero." + (define total + (length commands)) + + (define (wait-for-one-process) + (match (waitpid WAIT_ANY) + ((_ . status) + (unless (zero? (status:exit-val status)) + (error "process failed" status))))) + + (define (fork-and-run-command command) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (apply execlp command)) + (lambda () + (primitive-exit 127)))) + (pid + #t))) + + (let loop ((commands commands) + (running 0) + (completed 0)) + (match commands + (() + (or (zero? running) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed)))) + ((command . rest) + (if (< running max-processes) + (let ((running (+ 1 running))) + (fork-and-run-command command) + (loop rest running completed)) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed))))))) + +(define* (report-build-progress total completed + #:optional (log-port (current-error-port))) + "Report that COMPLETED out of TOTAL files have been completed." + (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port)) + (define* (build #:key outputs inputs native-inputs (source-directory ".") (compile-flags '()) @@ -101,24 +157,30 @@ Return #false if it cannot be determined." (match (getenv "GUILE_LOAD_COMPILED_PATH") (#f "") (path (string-append ":" path))))) - (for-each (lambda (file) - (let* ((go (string-append go-dir - (file-sans-extension file) - ".go"))) - ;; Install source module. - (install-file (string-append source-directory "/" file) - (string-append module-dir - "/" (dirname file))) - - ;; Install and compile module. - (apply invoke guild "compile" "-L" source-directory - "-o" go - (string-append source-directory "/" file) - flags))) - - ;; Arrange to strip SOURCE-DIRECTORY from file names. - (with-directory-excursion source-directory - (find-files "." scheme-file-regexp))) + + (let ((source-files + (with-directory-excursion source-directory + (find-files "." scheme-file-regexp)))) + (invoke-each + (map (lambda (file) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags)) + source-files) + #:max-processes (parallel-job-count) + #:report-progress report-build-progress) + + (for-each + (lambda (file) + (install-file (string-append source-directory "/" file) + (string-append module-dir + "/" (dirname file)))) + source-files)) #t)) (define* (install-documentation #:key outputs diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm new file mode 100644 index 0000000000..cd76df2de7 --- /dev/null +++ b/guix/build/linux-module-build-system.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build 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: + +;; 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") + "/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 diff --git a/guix/build/po.scm b/guix/build/po.scm new file mode 100644 index 0000000000..47ff67541c --- /dev/null +++ b/guix/build/po.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build po) + #:use-module (ice-9 match) + #:use-module (ice-9 peg) + #:use-module (ice-9 regex) + #:use-module (ice-9 textual-ports) + #:export (read-po-file)) + +;; A small parser for po files +(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern whitespace body (or " " "\t" "\n")) +(define-peg-pattern comment-chr body (range #\space #\頋)) +(define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern entry all + (and (ignore (* whitespace)) (ignore "msgid ") msgid + (ignore (* whitespace)) (ignore "msgstr ") msgstr)) +(define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) +(define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") + "\\n" (and (ignore "\\") "\\") + (range #\# #\頋))) +(define-peg-pattern msgid all content) +(define-peg-pattern msgstr all content) +(define-peg-pattern content body + (and (ignore "\"") (* str-chr) (ignore "\"") + (? (and (ignore (* whitespace)) content)))) + +(define (parse-tree->assoc parse-tree) + "Converts a po PARSE-TREE to an association list." + (define regex (make-regexp "\\\\n")) + (match parse-tree + ('() '()) + ((entry parse-tree ...) + (match entry + ((? string? entry) + (parse-tree->assoc parse-tree)) + ;; empty msgid + (('entry ('msgid ('msgstr msgstr))) + (parse-tree->assoc parse-tree)) + ;; empty msgstr + (('entry ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (regexp-substitute/global #f regex msgid 'pre "\n" 'post) + (regexp-substitute/global #f regex msgstr 'pre "\n" 'post) + (parse-tree->assoc parse-tree))))))) + +(define (read-po-file port) + "Read a .po file from PORT and return an alist of msgid and msgstr." + (let ((tree (peg:tree (match-pattern + po-file + (get-string-all port))))) + (parse-tree->assoc tree))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index ba0de1259e..63c94765f7 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -144,6 +144,8 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (setenv "GEM_VENDOR" vendor-dir) (or (zero? + ;; 'zero? system*' allows the custom error handling to function as + ;; expected, while 'invoke' raises its own exception. (apply system* "gem" "install" gem-file "--verbose" "--local" "--ignore-dependencies" "--vendor" diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 66d63a2931..749616ceb1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -39,6 +39,7 @@ MS_NODEV MS_NOEXEC MS_REMOUNT + MS_NOATIME MS_BIND MS_MOVE MS_STRICTATIME @@ -451,6 +452,7 @@ the returned procedure is called." (define MS_NODEV 4) (define MS_NOEXEC 8) (define MS_REMOUNT 32) +(define MS_NOATIME 1024) (define MS_BIND 4096) (define MS_MOVE 8192) (define MS_STRICTATIME 16777216) @@ -690,7 +692,7 @@ mounted at FILE." (define* (device-in-use? device) "Return #t if the block DEVICE is in use, #f otherwise. This is inspired -from fdisk_device_is_used function of util-linux. This is particulary useful +from fdisk_device_is_used function of util-linux. This is particularly useful for devices that do not appear in /proc/self/mounts like overlayfs lowerdir backend device." (let*-values (((fd) (open-fdes device O_RDONLY)) diff --git a/guix/channels.scm b/guix/channels.scm index 9658cf9393..e93879e1b4 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -52,6 +52,7 @@ channel-location %default-channels + guix-channel? channel-instance? channel-instance-channel diff --git a/guix/colors.scm b/guix/colors.scm new file mode 100644 index 0000000000..7949cf5763 --- /dev/null +++ b/guix/colors.scm @@ -0,0 +1,188 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Free Software Foundation, Inc. +;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix 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 (color + color? + + colorize-string + highlight + color-rules + color-output? + isatty?*)) + +;;; Commentary: +;;; +;;; This module provides tools to produce colored output using ANSI escapes. +;;; +;;; Code: + +;; Record type for "colors", which are actually lists of color attributes. +(define-record-type <color> + (make-color symbols ansi) + color? + (symbols color-symbols) + (ansi color-ansi)) + +(define (print-color color port) + (format port "#<color ~a>" + (string-join (map symbol->string + (color-symbols color))))) + +(set-record-type-printer! <color> 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) + "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 %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: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + (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) + (colors colors) + (result (list (match:prefix m)))) + (match colors + (() + (string-concatenate-reverse + (cons (match:suffix m) result))) + ((first . tail) + (loop (+ n 1) + tail + (cons (colorize-string (match:substring m n) + first) + 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) ...) + ...))))) diff --git a/guix/config.scm.in b/guix/config.scm.in index d2ec9921c6..247b15ed81 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -33,7 +33,6 @@ %config-directory %system - %libgcrypt %libz %gzip %bzip2 @@ -88,9 +87,6 @@ (define %system "@guix_system@") -(define %libgcrypt - "@LIBGCRYPT@") - (define %libz "@LIBZ@") 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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -344,7 +344,8 @@ OUTPUTS of DRV and not already available in STORE, recursively, and the list 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)) 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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> @@ -415,11 +415,7 @@ (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/gexp.scm b/guix/gexp.scm index 5b5b064b59..4f2adba90a 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -634,6 +634,11 @@ names and file names suitable for the #:allowed-references argument to local-build? (substitutable? #t) (properties '()) + ;; TODO: This parameter is transitional; it's here + ;; to avoid a full rebuild. Remove it on the next + ;; rebuild cycle. + (pre-load-modules? #t) + deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -738,6 +743,8 @@ The other arguments are as for 'derivation'." #:module-path module-path #:extensions extensions #:guile guile-for-build + #:pre-load-modules? + pre-load-modules? #:deprecation-warnings deprecation-warnings) (return #f))) @@ -1213,7 +1220,11 @@ last one is created from the given <scheme-file> object." (guile (%guile-for-build)) (module-path %load-path) (extensions '()) - (deprecation-warnings #f)) + (deprecation-warnings #f) + + ;; TODO: This flag is here to prevent a full + ;; rebuild. Remove it on the next rebuild cycle. + (pre-load-modules? #t)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." @@ -1246,7 +1257,12 @@ they can refer to each other." (let* ((base (basename entry ".scm")) (output (string-append output "/" base ".go"))) (format #t "[~2@a/~2@a] Compiling '~a'...~%" - (+ 1 processed) (ungexp total) entry) + (+ 1 processed + (ungexp-splicing (if pre-load-modules? + (gexp ((ungexp total))) + (gexp ())))) + (ungexp (* total (if pre-load-modules? 2 1))) + entry) (compile-file entry #:output-file output #:opts %auto-compilation-options) @@ -1293,6 +1309,33 @@ they can refer to each other." (mkdir (ungexp output)) (chdir (ungexp modules)) + + (ungexp-splicing + (if pre-load-modules? + (gexp ((define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around <https://bugs.gnu.org/15602>. + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (lambda (file loaded) + (if (file-is-directory? file) + (load-from-directory file loaded) + (begin + (format #t "[~2@a/~2@a] Loading '~a'...~%" + (+ 1 loaded) + (ungexp (* 2 total)) + file) + (save-module-excursion + (lambda () + (primitive-load file))) + (+ 1 loaded)))) + loaded + entries))) + + (load-from-directory "."))) + (gexp ()))) + (process-directory "." (ungexp output) 0)))) ;; TODO: Pass MODULES as an environment variable. diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 36028a01d6..5dcc0e97a3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -58,7 +58,12 @@ (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-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-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 @@ path to the repository." (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)))) @@ -233,39 +247,55 @@ path to the repository." (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 diff --git a/guix/licenses.scm b/guix/licenses.scm index 676e71acdb..65d9c3da13 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2014, 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -38,7 +38,6 @@ boost1.0 bsd-2 bsd-3 bsd-4 non-copyleft - bsd-style ;deprecated! cc0 cc-by2.0 cc-by3.0 cc-by4.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 @@ -65,7 +64,7 @@ imlib2 ipa knuth - lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ + lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ llgpl lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ lppl1.3a lppl1.3a+ @@ -170,12 +169,6 @@ at URI, which may be a file:// URI pointing the package's tree." "Check the URI for details. " comment))) -(define bsd-style - ;; This alias is kept for backward-compatibility. Do not use it for new - ;; packages: it is ambiguous, as rightfully explained at - ;; <http://www.gnu.org/philosophy/words-to-avoid.html#BSD-style>. - non-copyleft) - (define cc0 (license "CC0" "http://directory.fsf.org/wiki/License:CC0" @@ -417,6 +410,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/lgpl.html" "https://www.gnu.org/licenses/license-list#LGPLv3")) +(define llgpl + (license "LLGPL" + "https://opensource.franz.com/preamble.html" + "Lisp Lesser General Public License")) + (define lppl (license "LPPL (any version)" "https://www.latex-project.org/lppl/lppl-1-0/" diff --git a/guix/packages.scm b/guix/packages.scm index a961dc3973..9cd4cbc416 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -48,6 +48,7 @@ search-path-specification) ;for convenience #:export (origin origin? + this-origin origin-uri origin-method origin-sha256 @@ -63,6 +64,7 @@ package package? + this-package package-name package-upstream-name package-version @@ -82,7 +84,6 @@ package-license package-home-page package-supported-systems - package-maintainers package-properties package-location hidden-package @@ -156,6 +157,7 @@ (define-record-type* <origin> origin make-origin origin? + this-origin (uri origin-uri) ; string (method origin-method) ; procedure (sha256 origin-sha256) ; bytevector @@ -247,6 +249,7 @@ name of its URI." (define-record-type* <package> package make-package package? + this-package (name package-name) ; string (version package-version) ; string (source package-source) ; <origin> instance @@ -260,9 +263,6 @@ name of its URI." (default '()) (thunked)) (native-inputs package-native-inputs ; native input packages/derivations (default '()) (thunked)) - (self-native-input? package-self-native-input? ; whether to use itself as - ; a native input when cross- - (default #f)) ; compiling (outputs package-outputs ; list of strings (default '("out"))) @@ -285,7 +285,6 @@ name of its URI." (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems)) - (maintainers package-maintainers (default '())) (properties package-properties (default '())) ; alist for anything else @@ -643,6 +642,9 @@ specifies modules in scope when evaluating SNIPPET." (let ((name (tarxz-name original-file-name))) (gexp->derivation name build + ;; TODO: Remove this on the next rebuild cycle. + #:pre-load-modules? #f + #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild @@ -1027,9 +1029,10 @@ and return it." (match (if graft? (or (package-replacement package) package) package) - (($ <package> name version source build-system - args inputs propagated-inputs native-inputs - self-native-input? outputs) + ((and self + ($ <package> name version source build-system + args inputs propagated-inputs native-inputs + outputs)) ;; Even though we prefer to use "@" to separate the package ;; name from the package version in various user-facing parts ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) @@ -1038,15 +1041,11 @@ and return it." #:system system #:target target #:source source - #:inputs (append (inputs) - (propagated-inputs)) + #:inputs (append (inputs self) + (propagated-inputs self)) #:outputs outputs - #:native-inputs `(,@(if (and target - self-native-input?) - `(("self" ,package)) - '()) - ,@(native-inputs)) - #:arguments (args)) + #:native-inputs (native-inputs self) + #:arguments (args self)) (raise (if target (condition (&package-cross-build-system-error 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 @@ profile-search-paths generation-number + generation-profile generation-numbers profile-generations relative-generation-spec->number @@ -1552,6 +1553,20 @@ already effective." (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." diff --git a/guix/records.scm b/guix/records.scm index 0649c90ea3..99507dc384 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -25,6 +25,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:export (define-record-type* + this-record + alist->record object->fields recutils->alist @@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE." (() #t))))))) +(define-syntax-parameter this-record + (lambda (s) + "Return the record being defined. This macro may only be used in the +context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-record + "cannot be used outside of a record instantiation" + #'id))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -105,6 +118,7 @@ of TYPE matches the expansion-time ABI." ((_ type name ctor (expected ...) #:abi-cookie abi-cookie #:thunked thunked + #:this-identifier this-identifier #:delayed delayed #:innate innate #:defaults defaults) @@ -148,7 +162,14 @@ of TYPE matches the expansion-time ABI." (define (wrap-field-value f value) (cond ((thunked-field? f) - #`(lambda () #,value)) + #`(lambda (x) + (syntax-parameterize ((#,this-identifier + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) ((delayed-field? f) #`(delay #,value)) (else value))) @@ -234,6 +255,7 @@ may look like this: (define-record-type* <thing> thing make-thing thing? + this-thing (name thing-name (default \"chbouib\")) (port thing-port (default (current-output-port)) (thunked)) @@ -253,7 +275,8 @@ default value specified in the 'define-record-type*' form is used: The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will actually compute the field's value in the current dynamic extent, which is -useful when referring to fluids in a field's value. +useful when referring to fluids in a field's value. Furthermore, that thunk +can access the record it belongs to via the 'this-thing' identifier. A field can also be marked as \"delayed\" instead of \"thunked\", in which case its value is effectively wrapped in a (delay …) form. @@ -308,7 +331,7 @@ inherited." (with-syntax ((real-get (wrapped-field-accessor-name field))) #'(define-inlinable (get x) ;; The real value of that field is a thunk, so call it. - ((real-get x))))))) + ((real-get x) x)))))) (define (delayed-field-accessor-definition field) ;; Return the real accessor for FIELD, which is assumed to be a @@ -332,7 +355,9 @@ inherited." (syntax-case s () ((_ type syntactic-ctor ctor pred + this-identifier (field get properties ...) ...) + (identifier? #'this-identifier) (let* ((field-spec #'((field get properties ...) ...)) (thunked (filter-map thunked-field? field-spec)) (delayed (filter-map delayed-field? field-spec)) @@ -361,15 +386,36 @@ inherited." field-spec* ...) (define #,(current-abi-identifier #'type) #,cookie) + + #,@(if (free-identifier=? #'this-identifier #'this-record) + #'() + #'((define-syntax-parameter this-identifier + (lambda (s) + "Return the record being defined. This macro may +only be used in the context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-identifier + "cannot be used outside \ +of a record instantiation" + #'id))))))) thunked-field-accessor ... delayed-field-accessor ... (make-syntactic-constructor type syntactic-ctor ctor (field ...) #:abi-cookie #,cookie #:thunked #,thunked + #:this-identifier #'this-identifier #:delayed #,delayed #:innate #,innate - #:defaults #,defaults)))))))) + #:defaults #,defaults))))) + ((_ type syntactic-ctor ctor pred + (field get properties ...) ...) + ;; When no 'this' identifier was specified, use 'this-record'. + #'(define-record-type* type syntactic-ctor ctor pred + this-record + (field get properties ...) ...))))) (define* (alist->record alist make keys #:optional (multiple-value-keys '())) diff --git a/guix/scripts.scm b/guix/scripts.scm index 75d801a466..77cbf12350 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -173,7 +173,8 @@ Show what and how will/would be built." "Your Guix installation is ~a days old.\n" (seconds->days age)) (seconds->days age))) - (when (or (not age) (>= age old)) + (when (and (or (not age) (>= age old)) + (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "Consider running 'guix pull' followed by '~a' to get up-to-date packages and security updates.\n") suggested-command) @@ -200,16 +201,12 @@ available." (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 diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 28864435df..ba143ad16b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,7 @@ found. Return #f if no build log was found." (let* ((root (if (string-prefix? "/" root) root (string-append (canonicalize-path (dirname root)) - "/" root)))) + "/" (basename root))))) (catch 'system-error (lambda () (match paths @@ -635,8 +635,7 @@ options handled by 'set-build-options-from-command-line', and listed in (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) - (build-mode . ,(build-mode normal)) + `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -729,8 +728,7 @@ must be one of 'package', 'all', or 'transitive'~%") rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) + (alist-cons 'system arg result))) (option '("target") #t #f (lambda (opt name arg result) (alist-cons 'target arg @@ -811,56 +809,71 @@ build." (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) + (define systems + (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + + (define things-to-build + (map (cut transform store <>) + (options->things-to-build opts))) + + (define (compute-derivation obj system) + ;; Compute the derivation of OBJ for SYSTEM. + (match obj + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)) + #:system system))))) ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields ;; of user packages. Since 'guix build' is the primary tool for people ;; testing new packages, report such errors gracefully. (with-unbound-variable-handling (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? file-like? obj) - (list (run-with-store store - (lower-object obj system - #:target (assoc-ref opts 'target)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)) - #:system system)))) - (map (cut transform store <>) - (options->things-to-build opts)))))) + (append-map (lambda (system) + (append-map (cut compute-derivation <> system) + things-to-build)) + systems)))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index b6287d3a4c..fa6b6cae37 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts describe) + #:use-module ((guix config) #:select (%guix-version)) #:use-module ((guix ui) #:hide (display-profile-content)) #:use-module (guix channels) #:use-module (guix scripts) @@ -114,7 +115,12 @@ within a Git checkout." (lambda () (repository-discover (dirname program))) (lambda (key err) - (leave (G_ "failed to determine origin~%"))))) + (report-error (G_ "failed to determine origin~%")) + (display-hint (format #f (G_ "Perhaps this +@command{guix} command was not obtained with @command{guix pull}? Its version +string is ~a.~%") + %guix-version)) + (exit 1)))) (repository (repository-open directory)) (head (repository-head repository)) (commit (oid->string (reference-target head)))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 63f6129279..99c351ae43 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,6 +33,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu build linux-container) + #:use-module (gnu build accounts) #:use-module (gnu system linux-container) #:use-module (gnu system file-systems) #:use-module (gnu packages) @@ -191,7 +192,7 @@ COMMAND or an interactive shell in that environment.\n")) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (debug . 0) - (verbosity . 2))) + (verbosity . 1))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either @@ -458,10 +459,22 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (return (let* ((cwd (getcwd)) (home (getenv "HOME")) - (passwd (mock-passwd (getpwuid (getuid)) - user - bash)) - (home-dir (passwd:dir passwd)) + (uid (if user 1000 (getuid))) + (gid (if user 1000 (getgid))) + (passwd (let ((pwd (getpwuid (getuid)))) + (password-entry + (name (or user (passwd:name pwd))) + (real-name (if user + "" + (passwd:gecos pwd))) + (uid uid) (gid gid) (shell bash) + (directory (if user + (string-append "/home/" user) + (passwd:dir pwd)))))) + (groups (list (group-entry (name "users") (gid gid)) + (group-entry (gid 65534) ;the overflow GID + (name "overflow")))) + (home-dir (password-entry-directory passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -519,17 +532,8 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; to read it, such as 'git clone' over SSH, a valid use-case when ;; sharing the host's network namespace. (mkdir-p "/etc") - (call-with-output-file "/etc/passwd" - (lambda (port) - (display (string-join (list (passwd:name passwd) - "x" ; but there is no shadow - "0" "0" ; user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - bash) - ":") - port) - (newline port))) + (write-passwd (list passwd)) + (write-group groups) ;; For convenience, start in the user's current working ;; directory rather than the root directory. @@ -539,36 +543,12 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; A container's environment is already purified, so no need to ;; request it be purified again. (launch-environment command profile manifest #:pure? #f))) + #:guest-uid uid + #:guest-gid gid #:namespaces (if network? (delq 'net %namespaces) ; share host network %namespaces))))))) -(define (mock-passwd passwd user-override shell) - "Generate mock information for '/etc/passwd'. If USER-OVERRIDE is not '#f', -it is expected to be a string representing the mock username; it will produce -a user of that name, with a home directory of '/home/USER-OVERRIDE', and no -GECOS field. If USER-OVERRIDE is '#f', data will be inherited from PASSWD. -In either case, the shadow password and UID/GID are cleared, since the user -runs as root within the container. SHELL will always be used in place of the -shell in PASSWD. - -The resulting vector is suitable for use with Guile's POSIX user procedures. - -See passwd(5) for more information each of the fields." - (if user-override - (vector - user-override - "x" "0" "0" ;; no shadow, user is now root - "" ;; no personal information - (user-override-home user-override) - shell) - (vector - (passwd:name passwd) - "x" "0" "0" ;; no shadow, user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - shell))) - (define (user-override-home user) "Return home directory for override user USER." (string-append "/home/" user)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6f37b767ff..9a57e5fd1e 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 <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +20,10 @@ #:use-module (guix ui) #:use-module (guix scripts) #: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) @@ -47,7 +50,12 @@ Invoke the garbage collector.\n")) (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_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -95,6 +103,16 @@ Invoke the garbage collector.\n")) 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 @@ -120,10 +138,25 @@ Invoke the garbage collector.\n")) (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 @@ -135,6 +168,10 @@ Invoke the garbage collector.\n")) (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 +242,27 @@ Invoke the garbage collector.\n")) (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 (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))) + + (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)) @@ -229,6 +287,10 @@ Invoke the garbage collector.\n")) (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)) @@ -238,6 +300,9 @@ Invoke the garbage collector.\n")) (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/guix/scripts/install.scm b/guix/scripts/install.scm new file mode 100644 index 0000000000..d88e86e77a --- /dev/null +++ b/guix/scripts/install.scm @@ -0,0 +1,80 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts install) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-install)) + +(define (show-help) + (display (G_ "Usage: guix install [OPTION] PACKAGES... +Install the given PACKAGES. +This is an alias for 'guix package -i'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix install"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-install . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'install arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ddad5b7fd0..dc338a1d7b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -45,7 +45,6 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web client) @@ -796,10 +795,13 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) -(define (check-github-url package) +(define* (check-github-url package #:key (timeout 3)) "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect uri) - (receive (response body) (http-head uri) + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) (case (response-code response) ((301 302) (uri->string (assoc-ref (response-headers response) 'location))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index d237ae6e94..2a7b84b847 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -126,13 +126,9 @@ dependencies are registered." (define build (with-extensions gcrypt-sqlite3&co - ;; XXX: Adding (gnu build install) just to work around - ;; <https://bugs.gnu.org/15602>: that way, (guix build store-copy) is - ;; copied last and the 'store-info-XXX' macros are correctly expanded. (with-imported-modules (source-module-closure '((guix build store-copy) - (guix store database) - (gnu build install))) + (guix store database))) #~(begin (use-modules (guix store database) (guix build store-copy) @@ -633,7 +629,7 @@ please email '~a'~%") (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (debug . 0) - (verbosity . 2) + (verbosity . 1) (symlinks . ()) (compressor . ,(first %compressors)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b0c6a7ced7..aa27984ea2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -58,7 +58,11 @@ delete-generations delete-matching-generations display-search-paths - guix-package)) + guix-package + + (%options . %package-options) + (%default-options . %package-default-options) + guix-package*)) (define %store (make-parameter #f)) @@ -278,11 +282,19 @@ path definition to be returned." (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) @@ -891,6 +903,11 @@ processed, #f otherwise." (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) + (guix-package* opts)) + +(define (guix-package* opts) + "Run the 'guix package' command on OPTS, an alist resulting for command-line +option processing with 'parse-command-line'." (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 730b6a0bf2..3929cd402e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -86,13 +86,13 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) (display (G_ " + -N, --news display news compared to the previous generation")) + (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) (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\"")) @@ -119,6 +119,9 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) result))) + (option '(#\N "news") #f #f + (lambda (opt name arg result) + (cons '(query display-news) result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -164,24 +167,33 @@ Download and deploy the latest version of Guix.\n")) (define indirect-root-added (store-lift add-indirect-root)) -(define (display-profile-news profile) - "Display what's up in PROFILE--new packages, and all that." +(define* (display-profile-news profile #:key concise? + current-is-newer?) + "Display what's up in PROFILE--new packages, and all that. If +CURRENT-IS-NEWER? is true, assume that the current process represents the +newest generation of PROFILE.x" (match (memv (generation-number profile) (reverse (profile-generations profile))) ((current previous _ ...) - (newline) - (let ((old (fold-available-packages - (lambda* (name version result - #:key supported? deprecated? - #:allow-other-keys) - (if (and supported? (not deprecated?)) - (alist-cons name version result) - result)) - '())) - (new (profile-package-alist - (generation-file-name profile current)))) - (display-new/upgraded-packages old new - #:heading (G_ "New in this revision:\n")))) + (let ((these (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '())) + (those (profile-package-alist + (generation-file-name profile + (if current-is-newer? + previous + current))))) + (let ((old (if current-is-newer? those these)) + (new (if current-is-newer? these those))) + (display-new/upgraded-packages old new + #:concise? concise? + #:heading + (G_ "New in this revision:\n"))))) (_ #t))) (define* (build-and-install instances profile @@ -197,7 +209,8 @@ true, display what would be built without actually building it." #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)) + (return (newline)) + (return (display-profile-news profile #:concise? #t)) (match (which "guix") (#f (return #f)) (str @@ -377,36 +390,66 @@ of packages upgraded in ALIST2." alist2))) (values new upgraded))) +(define* (ellipsis #:optional (port (current-output-port))) + "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent +it." + (match (port-encoding port) + ("UTF-8" "…") + (_ "..."))) + (define* (display-new/upgraded-packages alist1 alist2 - #:key (heading "")) + #:key (heading "") concise?) "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 -and ALIST2 differ, display HEADING upfront." +and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not +display long package lists that would fill the user's screen." + (define (pretty str column) + (indented-string (fill-paragraph str (- (%text-width) 4) + column) + 4)) + + (define concise/max-item-count + ;; Maximum number of items to display when CONCISE? is true. + 12) + + (define list->enumeration + (if concise? + (lambda* (lst #:optional (max concise/max-item-count)) + (if (> (length lst) max) + (string-append (string-join (take lst max) ", ") + ", " (ellipsis)) + (string-join lst ", "))) + (cut string-join <> ", "))) + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) + (define new-count (length new)) + (define upgraded-count (length upgraded)) + (unless (and (null? new) (null? upgraded)) (display heading)) - (match (length new) + (match new-count (0 #t) (count (format #t (N_ " ~h new package: ~a~%" " ~h new packages: ~a~%" count) count - (indented-string - (fill-paragraph (string-join (sort (map first new) string<?) - ", ") - (- (%text-width) 4) 30) - 4)))) - (match (length upgraded) + (pretty (list->enumeration (sort (map first new) string<?)) + 30)))) + (match upgraded-count (0 #t) (count (format #t (N_ " ~h package upgraded: ~a~%" " ~h packages upgraded: ~a~%" count) count - (indented-string - (fill-paragraph (string-join (sort upgraded string<?) ", ") - (- (%text-width) 4) 35) - 4)))))) + (pretty (list->enumeration (sort upgraded string<?)) + 35)))) + + (when (and concise? + (or (> new-count concise/max-item-count) + (> upgraded-count concise/max-item-count))) + (display-hint (G_ "Run @command{guix pull --news} to view the complete +list of package changes."))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." @@ -446,7 +489,12 @@ and ALIST2 differ, display HEADING upfront." (() (exit 1)) ((numbers ...) - (list-generations profile numbers))))))))) + (list-generations profile numbers))))))) + (('display-news) + ;; Display profile news, with the understanding that this process + ;; represents the newest generation. + (display-profile-news profile + #:current-is-newer? #t)))) (define (channel-list opts) "Return the list of channels to use. If OPTS specify a channel file, @@ -486,24 +534,22 @@ Use '~/.config/guix/channels.scm' instead.")) (url (or (assoc-ref opts 'repository-url) (environment-variable)))) (if (or ref url) - (match channels - ((one) - ;; When there's only one channel, apply '--url', '--commit', and - ;; '--branch' to this specific channel. - (let ((url (or url (channel-url one)))) - (list (match ref + (match (find guix-channel? channels) + ((? channel? guix) + ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel. + (let ((url (or url (channel-url guix)))) + (cons (match ref (('commit . commit) - (channel (inherit one) + (channel (inherit guix) (url url) (commit commit) (branch #f))) (('branch . branch) - (channel (inherit one) + (channel (inherit guix) (url url) (commit #f) (branch branch))) (#f - (channel (inherit one) (url url))))))) - (_ - ;; Otherwise bail out. - (leave - (G_ "'--url', '--commit', and '--branch' are not applicable~%")))) + (channel (inherit guix) (url url)))) + (remove guix-channel? channels)))) + (#f ;no 'guix' channel, failure will ensue + channels)) channels))) @@ -515,11 +561,11 @@ Use '~/.config/guix/channels.scm' instead.")) (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile))) - (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) (else (with-store store + (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 5b0f345cde..dd7026a6a4 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -297,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball changes) + (let-values (((version tarball source) (package-update store package updaters #:key-download key-download)) ((loc) @@ -330,10 +330,10 @@ warn about packages that have no matching updater." (G_ "~a: consider removing this propagated input: ~a~%"))) (package-name package) (upstream-input-change-name change))) - (changes)) + (upstream-source-input-changes source)) (let ((hash (call-with-input-file tarball port-sha256))) - (update-package-source package version hash))) + (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") (package-name package) version)))) diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm new file mode 100644 index 0000000000..2f06ea4f37 --- /dev/null +++ b/guix/scripts/remove.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts remove) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-remove)) + +(define (show-help) + (display (G_ "Usage: guix remove [OPTION] PACKAGES... +Remove the given PACKAGES. +This is an alias for 'guix package -r'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix remove"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %standard-build-options))) + +(define (guix-remove . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'remove arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm new file mode 100644 index 0000000000..8fceb83668 --- /dev/null +++ b/guix/scripts/search.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts search) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-search)) + +(define (show-help) + (display (G_ "Usage: guix search [OPTION] REGEXPS... +Search for packages matching REGEXPS.")) + (display (G_" +This is an alias for 'guix package -s'.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix search"))))) + +(define (guix-search . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query search ,(or arg "")) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no regular expressions to search for~%"))) + + (guix-package* opts)) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 25218a2945..f549ce05b8 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +34,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 vlist) #:export (profile? profile-file profile-self-size @@ -142,11 +143,20 @@ profile of ITEMS and their requisites." (lambda (size) (return (cons item size))))) refs))) + (define size-table + (fold (lambda (pair result) + (match pair + ((item . size) + (vhash-cons item size result)))) + vlist-null sizes)) + (define (dependency-size item) (mlet %store-monad ((deps (requisites* (list item)))) (foldm %store-monad (lambda (item total) - (return (+ (assoc-ref sizes item) total))) + (return (+ (match (vhash-assoc item size-table) + ((_ . size) size)) + total))) 0 (delete-duplicates (cons item deps))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 97508f4bd6..3c3d6cbd5f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -855,7 +855,7 @@ static checks." (bootloader-configuration-bootloader (operating-system-bootloader os))) (define bootcfg - (and (not (eq? 'container action)) + (and (memq action '(init reconfigure)) (operating-system-bootcfg os menu-entries))) (define bootloader-script @@ -1299,8 +1299,7 @@ argument list and OPTS is the option alist." (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) (with-status-verbosity (or (assoc-ref opts 'verbosity) - (if (memq command '(init reconfigure)) - 1 2)) + (if (eq? command 'build) 2 1)) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm new file mode 100644 index 0000000000..7f14a2fdbe --- /dev/null +++ b/guix/scripts/upgrade.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts upgrade) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-upgrade)) + +(define (show-help) + (display (G_ "Usage: guix upgrade [OPTION] [REGEXP] +Upgrade packages that match REGEXP. +This is an alias for 'guix package -u'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix upgrade"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-upgrade . args) + (define (handle-argument arg result arg-handler) + ;; Accept at most one non-option argument, and treat it as an upgrade + ;; regexp. + (match (assq-ref result 'upgrade) + (#f + (values (alist-cons 'upgrade arg + (alist-delete 'upgrade result)) + arg-handler)) + (_ + (leave (G_ "~A: extraneous argument~%") arg)))) + + (define opts + (parse-command-line args %options + (list `((upgrade . #f) + ,@%package-default-options) + #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/self.scm b/guix/self.scm index ccff9be5b3..68b87051e9 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -60,6 +60,8 @@ ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) + ("po4a" (ref '(gnu packages gettext) 'po4a)) + ("gettext" (ref '(gnu packages gettext) 'gettext-minimal)) (_ #f)))) ;no such package @@ -253,8 +255,134 @@ DOMAIN, a gettext domain." (computed-file (string-append "guix-locale-" domain) build)) +(define (translate-texi-manuals source) + "Return the translated texinfo manuals built from SOURCE." + (define po4a + (specification->package "po4a")) + + (define gettext + (specification->package "gettext")) + + (define glibc-utf8-locales + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + + (define documentation + (file-append* source "doc")) + + (define documentation-po + (file-append* source "po/doc")) + + (define build + (with-imported-modules '((guix build utils) (guix build po)) + #~(begin + (use-modules (guix build utils) (guix build po) + (ice-9 match) (ice-9 regex) (ice-9 textual-ports) + (srfi srfi-1)) + + (mkdir #$output) + + (copy-recursively #$documentation "." + #:log (%make-void-port "w")) + + (for-each + (lambda (file) + (copy-file file (basename file))) + (find-files #$documentation-po ".*.po$")) + + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setenv "PATH" #+(file-append gettext "/bin")) + (setenv "LC_ALL" "en_US.UTF-8") + (setlocale LC_ALL "en_US.UTF-8") + + (define (translate-tmp-texi po source output) + "Translate Texinfo file SOURCE using messages from PO, and write +the result to OUTPUT." + (invoke #+(file-append po4a "/bin/po4a-translate") + "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo" + "-m" source "-p" po "-l" output)) + + (define (make-ref-regex msgid end) + (make-regexp (string-append + "ref\\{" + (string-join (string-split (regexp-quote msgid) #\ ) + "[ \n]+") + end))) + + (define (translate-cross-references content translations) + "Take CONTENT, a string representing a .texi file and translate any +cross-reference in it (@ref, @xref and @pxref) that have a translation in +TRANSLATIONS, an alist of msgid and msgstr." + (fold + (lambda (elem content) + (match elem + ((msgid . msgstr) + ;; Empty translations and strings containing some special characters + ;; cannot be the name of a section. + (if (or (equal? msgstr "") + (string-any (lambda (chr) + (member chr '(#\{ #\} #\( #\) #\newline #\,))) + msgid)) + content + ;; Otherwise, they might be the name of a section, so we + ;; need to translate any occurence in @(p?x?)ref{...}. + (let ((regexp1 (make-ref-regex msgid ",")) + (regexp2 (make-ref-regex msgid "\\}"))) + (regexp-substitute/global + #f regexp2 + (regexp-substitute/global + #f regexp1 content 'pre "ref{" msgstr "," 'post) + 'pre "ref{" msgstr "}" 'post)))))) + content translations)) + + (define (translate-texi po lang) + "Translate the manual for one language LANG using the PO file." + (let ((translations (call-with-input-file po read-po-file))) + (translate-tmp-texi po "guix.texi" + (string-append "guix." lang ".texi.tmp")) + (translate-tmp-texi po "contributing.texi" + (string-append "contributing." lang ".texi.tmp")) + (let* ((texi-name (string-append "guix." lang ".texi")) + (tmp-name (string-append texi-name ".tmp"))) + (with-output-to-file texi-name + (lambda _ + (format #t "~a" + (translate-cross-references + (call-with-input-file tmp-name get-string-all) + translations))))) + (let* ((texi-name (string-append "contributing." lang ".texi")) + (tmp-name (string-append texi-name ".tmp"))) + (with-output-to-file texi-name + (lambda _ + (format #t "~a" + (translate-cross-references + (call-with-input-file tmp-name get-string-all) + translations))))))) + + (for-each (lambda (po) + (match (reverse (string-split po #\.)) + ((_ lang _ ...) + (translate-texi po lang)))) + (find-files "." "^guix-manual\\.[a-z]{2}(_[A-Z]{2})?\\.po$")) + + (for-each + (lambda (file) + (copy-file file (string-append #$output "/" file))) + (append + (find-files "." "contributing\\..*\\.texi$") + (find-files "." "guix\\..*\\.texi$")))))) + + (computed-file "guix-translated-texinfo" build)) + (define (info-manual source) "Return the Info manual built from SOURCE." + (define po4a + (specification->package "po4a")) + + (define gettext + (specification->package "gettext")) + (define texinfo (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) @@ -327,6 +455,8 @@ DOMAIN, a gettext domain." ;; see those images and produce image references in the Info output. (copy-recursively #$documentation "." #:log (%make-void-port "w")) + (copy-recursively #+(translate-texi-manuals source) "." + #:log (%make-void-port "w")) (delete-file-recursively "images") (symlink (string-append #$output "/images") "images") @@ -350,7 +480,7 @@ DOMAIN, a gettext domain." (basename texi ".texi") ".info"))) (cons "guix.texi" - (find-files "." "^guix\\.[a-z]{2}\\.texi$"))) + (find-files "." "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$"))) ;; Compress Info files. (setenv "PATH" @@ -578,6 +708,7 @@ Info manual." ;; us to avoid an extra dependency on guile-gdbm-ffi. #:extra-files `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) + ("guix/build/po.scm" ,(local-file "../guix/build/po.scm")) ("guix/store/schema.sql" ,(local-file "../guix/store/schema.sql"))) @@ -627,6 +758,7 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) + ,@(scheme-modules* source "gnu/bootloader") ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* @@ -752,10 +884,6 @@ Info manual." ;;; Generating (guix config). ;;; -(define %dependency-variables - ;; (guix config) variables corresponding to dependencies. - '(%libz %xz %gzip %bzip2)) - (define %persona-variables ;; (guix config) variables that define Guix's persona. '(%guix-package-name diff --git a/guix/status.scm b/guix/status.scm index bddaa003db..cbea4151f2 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 @@ build-log\" traces." (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 @@ the current build phase." (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. @@ -452,17 +410,17 @@ produce colorful output. When PRINT-LOG? is true, display the build log in 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/store.scm b/guix/store.scm index 0a0a7c7c52..1b485ab5fa 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -368,7 +368,9 @@ (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! <store-connection> (lambda (obj port) @@ -557,13 +559,17 @@ for this connection will be pinned. Return a server object." (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 @@ already taken place on PORT and that we're just continuing on this established 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." @@ -602,19 +612,23 @@ connection. Use with care." "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 @@ -982,14 +996,52 @@ string). Raise an error if no such path exists." (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)))))) @@ -1367,13 +1419,13 @@ that there is no guarantee that the order of the resulting list matches the 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 @@ -1384,6 +1436,11 @@ supported by STORE." (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." diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 8ca16a4cd8..d42c40932c 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -79,8 +79,8 @@ unused by the time you create anything with that name, but a good shot." (define* (get-temp-link target #:optional (link-prefix (dirname target))) "Like mkstemp!, but instead of creating a new file and giving you the name, it creates a new hardlink to TARGET and gives you the name. Since -cross-filesystem hardlinks don't work, the temp link must be created on the -same filesystem - where in that filesystem it is can be controlled by +cross-file-system hardlinks don't work, the temp link must be created on the +same file system - where in that file system it is can be controlled by LINK-PREFIX." (let try ((tempname (tempname-in link-prefix))) (catch 'system-error 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 <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix 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/guix/ui.scm b/guix/ui.scm index 2fc001d2eb..92c845e944 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -10,8 +10,6 @@ ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> -;;; Copyright © 2013, 2014 Free Software Foundation, Inc. -;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -31,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) @@ -118,8 +117,7 @@ guix-warning-port warning info - guix-main - colorize-string)) + guix-main)) ;;; Commentary: ;;; @@ -127,45 +125,124 @@ ;;; ;;; Code: -(define-syntax-rule (define-diagnostic name prefix) - "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +(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." + (cond ((string? arg) + (highlight arg port)) + ((symbol? arg) + (highlight (symbol->string arg) port)) + (else arg))) + +(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) - (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 - 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 - args (... ...)))))))) - -(define-diagnostic warning "warning: ") ; emit a warning -(define-diagnostic info "") - -(define-diagnostic report-error "error: ") + ((_ name (G_ prefix) colors) + (define-syntax name + (lambda (x) + (syntax-case x () + ((name location (underscore fmt) args (... ...)) + (and (string? (syntax->datum #'fmt)) + (free-identifier=? #'underscore #'G_)) + #'(begin + (print-diagnostic-prefix prefix location + #:colors colors) + (format (guix-warning-port) (gettext fmt %gettext-domain) + (highlight-argument fmt 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 location + #:colors colors) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) + (highlight-argument singular 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; +;; "~a" is a placeholder for that phrase. +(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." (begin (report-error args ...) (exit 1))) +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) +(define %hint-color (color BOLD CYAN)) + +(define* (print-diagnostic-prefix prefix #:optional location + #: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 <> (color BOLD)) + identity)) + + (define prefix-color + (if color? + (lambda (prefix) + (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-color (location->string location)) + (prefix-color prefix)) + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (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. (match args @@ -317,11 +394,18 @@ VARIABLE and return it, or #f if none was found." (define* (display-hint message #:optional (port (current-error-port))) "Display MESSAGE, a l10n message possibly containing Texinfo markup, to PORT." - (format port (G_ "hint: ~a~%") - ;; XXX: We should arrange so that the initial indent is wider. - (parameterize ((%text-width (max 15 - (- (terminal-columns) 5)))) - (texi->plain-text message)))) + (define colorize + (if (color-output? port) + (lambda (str) + (colorize-string str %hint-color)) + 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' @@ -356,21 +440,15 @@ ARGS is the list of arguments received by the 'throw' handler." (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)))) @@ -394,8 +472,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (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~%") @@ -727,17 +804,14 @@ directories:~{ ~a~}~%") (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) @@ -1329,8 +1403,14 @@ score, the more relevant OBJ is to REGEXPS." ;; Metrics used to compute the "relevance score" of a package against a set ;; of regexps. `((,package-name . 4) - (,package-synopsis-string . 3) - (,package-description-string . 2) + + ;; Match regexps on the raw Texinfo since formatting it is quite expensive + ;; and doesn't have much of an effect on search results. + (,(lambda (package) + (and=> (package-synopsis package) P_)) . 3) + (,(lambda (package) + (and=> (package-description package) P_)) . 2) + (,(lambda (type) (match (and=> (package-location type) location-file) ((? string? file) (basename file ".scm")) @@ -1484,7 +1564,7 @@ DURATION-RELATION with the current time." (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)) @@ -1697,54 +1777,4 @@ and signal handling has already been set up." (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 diff --git a/guix/upstream.scm b/guix/upstream.scm index 55683dd9b7..1326b3db95 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -39,6 +39,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (upstream-source @@ -344,10 +345,10 @@ values: the item from LST1 and the item from LST2 that match PRED." (define* (package-update/url-fetch store package source #:key key-download) - "Return the version, tarball, and input changes needed to update PACKAGE to + "Return the version, tarball, and SOURCE, to update PACKAGE to SOURCE, an <upstream-source>." (match source - (($ <upstream-source> _ version urls signature-urls changes) + (($ <upstream-source> _ version urls signature-urls) (let*-values (((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) @@ -371,7 +372,7 @@ SOURCE, an <upstream-source>." (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url #:key-download key-download))) - (values version tarball changes)))))) + (values version tarball source)))))) (define %method-updates ;; Mapping of origin methods to source update procedures. @@ -404,36 +405,57 @@ this method: ~s") (#f (values #f #f #f)))) -(define (update-package-source package version hash) - "Modify the source file that defines PACKAGE to refer to VERSION, -whose tarball has SHA256 HASH (a bytevector). Return the new version string -if an update was made, and #f otherwise." - (define (update-expression expr old-version version old-hash hash) - ;; Update package expression EXPR, replacing occurrences OLD-VERSION by - ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation - ;; thereof). - (let ((old-hash (bytevector->nix-base32-string old-hash)) - (hash (bytevector->nix-base32-string hash))) - (string-replace-substring - (string-replace-substring expr old-hash hash) - old-version version))) +(define* (update-package-source package source hash) + "Modify the source file that defines PACKAGE to refer to SOURCE, an +<upstream-source> whose tarball has SHA256 HASH (a bytevector). Return the +new version string if an update was made, and #f otherwise." + (define (update-expression expr replacements) + ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS + ;; must be a list of replacement pairs, either bytevectors or strings. + (fold (lambda (replacement str) + (match replacement + (((? bytevector? old-bv) . (? bytevector? new-bv)) + (string-replace-substring + str + (bytevector->nix-base32-string old-bv) + (bytevector->nix-base32-string new-bv))) + ((old . new) + (string-replace-substring str old new)))) + expr + replacements)) (let ((name (package-name package)) + (version (upstream-source-version source)) (version-loc (package-field-location package 'version))) (if version-loc (let* ((loc (package-location package)) (old-version (package-version package)) (old-hash (origin-sha256 (package-source package))) + (old-url (match (origin-uri (package-source package)) + ((? string? url) url) + (_ #f))) + (new-url (match (upstream-source-urls source) + ((first _ ...) first))) (file (and=> (location-file loc) (cut search-path %load-path <>)))) (if file - (and (edit-expression - ;; Be sure to use absolute filename. - (assq-set! (location->source-properties loc) - 'filename file) - (cut update-expression <> - old-version version old-hash hash)) - version) + ;; Be sure to use absolute filename. Replace the URL directory + ;; when OLD-URL is available; this is useful notably for + ;; mirror://cpan/ URLs where the directory may change as a + ;; function of the person who uploads the package. Note that + ;; package definitions usually concatenate fragments of the URL, + ;; which is why we only attempt to replace a subset of the URL. + (let ((properties (assq-set! (location->source-properties loc) + 'filename file)) + (replacements `((,old-version . ,version) + (,old-hash . ,hash) + ,@(if (and old-url new-url) + `((,(dirname old-url) . + ,(dirname new-url))) + '())))) + (and (edit-expression properties + (cut update-expression <> replacements)) + version)) (begin (warning (G_ "~a: could not locate source file") (location-file loc)) |