diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 112 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 208 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 111 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/pypi.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/import/stackage.scm | 46 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 54 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 610 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 135 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/processes.scm | 223 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 406 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/repl.scm | 10 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 53 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 164 |
22 files changed, 1502 insertions, 717 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index a359f405fe..fb2f61ce30 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -29,7 +29,7 @@ #:use-module (guix monads) #:use-module (guix ui) #:use-module (guix pki) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 8b19dc871b..f1fd8ee895 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -19,7 +19,7 @@ (define-module (guix scripts authenticate) #:use-module (guix config) #:use-module (guix base16) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix ui) #:use-module (ice-9 binary-ports) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4dd4fbccdf..5532c65eb6 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,11 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (specification->package %package-module-path) #:autoload (guix download) (download-to-store) + #:autoload (guix git-download) (git-reference?) + #:autoload (guix git) (git-checkout?) + #:use-module (guix status) + #:use-module ((guix progress) #:select (current-terminal-columns)) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:export (%standard-build-options set-build-options-from-command-line set-build-options-from-command-line* @@ -267,6 +272,74 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (rewrite obj) obj)))) +(define (evaluate-git-replacement-specs specs proc) + "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list +of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the +replacement package. Raise an error if an element of SPECS uses invalid +syntax, or if a package it refers to could not be found." + (define not-equal + (char-set-complement (char-set #\=))) + + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((name branch-or-commit) + (let* ((old (specification->package name)) + (source (package-source old)) + (url (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git \ +reference~%") + (package-full-name old)))))) + (cons old (proc old url branch-or-commit)))) + (x + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-source-branch replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=stable-3.0\" meaning that packages are built using +'guile-next' from the latest commit on its 'stable-3.0' branch." + (define (replace old url branch) + (package + (inherit old) + (version (string-append "git." branch)) + (source (git-checkout (url url) (branch branch))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-commit replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=cabba9e\" meaning that packages are built using +'guile-next' from commit 'cabba9e'." + (define (replace old url commit) + (package + (inherit old) + (version (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7)))) + (source (git-checkout (url url) (commit commit))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -274,7 +347,9 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." ;; things to build. `((with-source . ,transform-package-source) (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft))) + (with-graft . ,transform-package-inputs/graft) + (with-branch . ,transform-package-source-branch) + (with-commit . ,transform-package-source-commit))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -288,7 +363,11 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (option '("with-input") #t #f (parser 'with-input)) (option '("with-graft") #t #f - (parser 'with-graft))))) + (parser 'with-graft)) + (option '("with-branch") #t #f + (parser 'with-branch)) + (option '("with-commit") #t #f + (parser 'with-commit))))) (define (show-transformation-options-help) (display (G_ " @@ -299,7 +378,13 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." replace dependency PACKAGE by REPLACEMENT")) (display (G_ " --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE"))) + graft REPLACEMENT on packages that refer to PACKAGE")) + (display (G_ " + --with-branch=PACKAGE=BRANCH + build PACKAGE from the latest commit of BRANCH")) + (display (G_ " + --with-commit=PACKAGE=COMMIT + build PACKAGE from COMMIT"))) (define (options->transformation opts) @@ -390,6 +475,10 @@ options handled by 'set-build-options-from-command-line', and listed in #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) #:print-build-trace (assoc-ref opts 'print-build-trace?) + #:print-extended-build-trace? + (assoc-ref opts 'print-extended-build-trace?) + #:multiplexed-build-output? + (assoc-ref opts 'multiplexed-build-output?) #:verbosity (assoc-ref opts 'verbosity))) (define set-build-options-from-command-line* @@ -499,6 +588,8 @@ options handled by 'set-build-options-from-command-line', and listed in (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (show-help) @@ -617,7 +708,7 @@ must be one of 'package', 'all', or 'transitive'~%") "Read the arguments from OPTS and return a list of high-level objects to build---packages, gexps, derivations, and so on." (define (validate-type x) - (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) + (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x)) (leave (G_ "~s: not something we can build~%") x))) (define (ensure-list x) @@ -694,6 +785,10 @@ package '~a' has no source~%") (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))))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad @@ -733,9 +828,12 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-build-output-port (if quiet? - (%make-void-port "w") - (current-error-port)))) + (parameterize ((current-terminal-columns (terminal-columns)) + (current-build-output-port + (if quiet? + (%make-void-port "w") + (build-event-output-port + (build-status-updater print-build-event))))) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm new file mode 100644 index 0000000000..f21311af09 --- /dev/null +++ b/guix/scripts/describe.scm @@ -0,0 +1,208 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts describe) + #:use-module ((guix ui) #:hide (display-profile-content)) + #:use-module (guix channels) + #:use-module (guix scripts) + #:use-module (guix describe) + #:use-module (guix profiles) + #:use-module ((guix scripts pull) #:select (display-profile-content)) + #:use-module (git) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:autoload (ice-9 pretty-print) (pretty-print) + #:export (guix-describe)) + + +;;; +;;; Command-line options. +;;; + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (unless (member arg '("human" "channels" "json" "recutils")) + (leave (G_ "~a: unsupported output format~%") arg)) + (alist-cons 'format (string->symbol arg) result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile (canonicalize-profile arg) + result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix describe"))))) + +(define %default-options + ;; Alist of default option values. + '((format . human))) + +(define (show-help) + (display (G_ "Usage: guix describe [OPTION]... +Display information about the channels currently in use.\n")) + (display (G_ " + -f, --format=FORMAT display information in the given FORMAT")) + (display (G_ " + -p, --profile=PROFILE display information about PROFILE")) + (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 (display-package-search-path fmt) + "Display GUIX_PACKAGE_PATH, if it is set, according to FMT." + (match (getenv "GUIX_PACKAGE_PATH") + (#f #t) + (string + (match fmt + ('human + (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string)) + ('channels + (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%") + string)))))) + +(define (channel->sexp channel) + `(channel + (name ,(channel-name channel)) + (url ,(channel-url channel)) + (commit ,(channel-commit channel)))) + +(define (channel->json channel) + (scm->json-string `((name . ,(channel-name channel)) + (url . ,(channel-url channel)) + (commit . ,(channel-commit channel))))) + +(define (channel->recutils channel port) + (format port "name: ~a~%" (channel-name channel)) + (format port "url: ~a~%" (channel-url channel)) + (format port "commit: ~a~%" (channel-commit channel))) + +(define (display-checkout-info fmt) + "Display information about the current checkout according to FMT, a symbol +denoting the requested format. Exit if the current directory does not lie +within a Git checkout." + (let* ((program (car (command-line))) + (directory (catch 'git-error + (lambda () + (repository-discover (dirname program))) + (lambda (key err) + (leave (G_ "failed to determine origin~%"))))) + (repository (repository-open directory)) + (head (repository-head repository)) + (commit (oid->string (reference-target head)))) + (match fmt + ('human + (format #t (G_ "Git checkout:~%")) + (format #t (G_ " repository: ~a~%") (dirname directory)) + (format #t (G_ " branch: ~a~%") (reference-shorthand head)) + (format #t (G_ " commit: ~a~%") commit)) + ('channels + (pretty-print `(list ,(channel->sexp (channel (name 'guix) + (url (dirname directory)) + (commit commit)))))) + ('json + (display (channel->json (channel (name 'guix) + (url (dirname directory)) + (commit commit)))) + (newline)) + ('recutils + (channel->recutils (channel (name 'guix) + (url (dirname directory)) + (commit commit)) + (current-output-port)))) + (display-package-search-path fmt))) + +(define (display-profile-info profile fmt) + "Display information about PROFILE, a profile as created by (guix channels), +in the format specified by FMT." + (define number + (generation-number profile)) + + (define channels + (map (lambda (entry) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (channel (name (string->symbol (manifest-entry-name entry))) + (url url) + (commit commit))) + + ;; Pre-0.15.0 Guix does not provide that information, + ;; so there's not much we can do in that case. + (_ (channel (name 'guix) + (url "?") + (commit "?"))))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest + (if (zero? number) + profile + (generation-file-name profile number))))))) + + (match fmt + ('human + (display-profile-content profile number)) + ('channels + (pretty-print `(list ,@(map channel->sexp channels)))) + ('json + (format #t "[~a]~%" (string-join (map channel->json channels) ","))) + ('recutils + (format #t "~{~a~%~}" + (map (lambda (channel) + (with-output-to-string + (lambda () + (channel->recutils channel (current-output-port))))) + channels)))) + (display-package-search-path fmt)) + + +;;; +;;; Entry point. +;;; + +(define (guix-describe . args) + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") + name)) + cons + %default-options)) + (format (assq-ref opts 'format)) + (profile (or (assq-ref opts 'profile) (current-profile)))) + (with-error-handling + (match profile + (#f + (display-checkout-info format)) + (profile + (display-profile-info (canonicalize-profile profile) format)))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1b99bc62cf..b9162d3449 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -20,7 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base16) #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1c04800e42..5965e3426e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,6 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) @@ -173,6 +174,9 @@ COMMAND or an interactive shell in that environment.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (tag-package-arg opts arg) @@ -661,59 +665,60 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (set-build-options-from-command-line store opts) + (with-status-report print-build-event + (set-build-options-from-command-line store opts) - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) - (gc-root -> (assoc-ref opts 'gc-root))) + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (manifest->derivation + manifest system bootstrap?)) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (build-environment (if (derivation? bash) - (list prof-drv bash) - (list prof-drv)) - opts) - (mwhen gc-root - (register-gc-root profile gc-root)) + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (build-environment (if (derivation? bash) + (list prof-drv bash) + (list prof-drv)) + opts) + (mwhen gc-root + (register-gc-root profile gc-root)) - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - bash - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:link-profile? link-prof? - #:network? network?))) - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:pure? pure?))))))))))))) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:link-profile? link-prof? + #:network? network?))) + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:pure? pure?)))))))))))))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 346ca4ea88..145a574dba 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -439,6 +439,10 @@ package modules, while attempting to retain user package modules." (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -462,6 +466,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) --list-types list the available graph types")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (G_ " + -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -472,7 +478,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) - (backend . ,%graphviz-backend))) + (backend . ,%graphviz-backend) + (system . ,(%current-system)))) ;;; @@ -508,7 +515,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))))))) + #:backend backend)) + #:system (assq-ref opts 'system)))))) #t) ;;; graph.scm ends here diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index cae5d6bcdf..b8b2158195 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,7 @@ (define-module (guix scripts hash) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix scripts) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 30ae6d4342..794fb710cd 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -47,6 +47,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 59a925a3ca..7bd83818ba 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -43,6 +45,8 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -56,6 +60,9 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import pypi"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +88,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (pypi->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (pypi-recursive-import package-name)))) + ;; Single import + (let ((sexp (pypi->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index e6676e93e8..b4b12581bf 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-stackage)) @@ -43,11 +45,13 @@ (display (G_ "Usage: guix import stackage PACKAGE-NAME Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (display (G_ " - -r VERSION, --lts-version=VERSION + -l VERSION, --lts-version=VERSION specify the LTS version to use")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) (display (G_ " -V, --version display version information and exit")) @@ -68,11 +72,14 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (alist-cons 'include-test-dependencies? #f (alist-delete 'include-test-dependencies? result)))) - (option '(#\r "lts-version") #t #f + (option '(#\l "lts-version") #t #f (lambda (opt name arg result) (alist-cons 'lts-version arg (alist-delete 'lts-version result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -90,6 +97,27 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (alist-cons 'argument arg result)) %default-options)) + (define (run-importer package-name opts error-fn) + (let* ((arguments (list + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:lts-version (assoc-ref opts 'lts-version))) + (sexp (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (apply stackage-recursive-import arguments)))) + ;; Single import + (apply stackage->guix-package arguments)))) + (unless sexp (error-fn)) + sexp)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -99,15 +127,11 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (match args ((package-name) (with-error-handling - (let ((sexp (stackage->guix-package - package-name - #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?) - #:lts-version (assoc-ref opts 'lts-version)))) - (unless sexp - (leave (G_ "failed to download cabal file for package '~a'~%") - package-name)) - sexp))) + (run-importer package-name opts + (lambda () + (leave (G_ "failed to download cabal file \ +for package '~a'~%") + package-name))))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e477bf0ddc..2314f3b28c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -33,6 +33,7 @@ #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix records) + #:use-module (guix grafts) #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix utils) @@ -774,30 +775,37 @@ descriptions maintained upstream." (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." - (catch #t - (lambda () - (guard (c ((nix-protocol-error? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (nix-protocol-error-message c)))) - ((message-condition? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (package-derivation store package #:graft? #f) + (define (try system) + (catch #t + (lambda () + (guard (c ((nix-protocol-error? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (nix-protocol-error-message c)))) + ((message-condition? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement #:graft? #f)))))) - (lambda args - (emit-warning package - (format #f (G_ "failed to create derivation: ~s~%") - args))))) + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f))))))) + (lambda args + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~s") + system args))))) + + (for-each try (package-supported-systems package))) (define (check-license package) "Warn about type errors of the 'license' field of PACKAGE." diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 729850839b..98b06971bd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix modules) @@ -37,11 +39,11 @@ #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) - #:use-module (gnu packages compression) + #:use-module ((gnu packages compression) #:hide (zip)) #:use-module (gnu packages guile) #:use-module (gnu packages base) #:autoload (gnu packages package-management) (guix) - #:autoload (gnu packages gnupg) (libgcrypt) + #:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -51,6 +53,9 @@ #:export (compressor? lookup-compressor self-contained-tarball + docker-image + squashfs-image + guix-pack)) ;; Type of a compression tool. @@ -95,13 +100,57 @@ found." (('gnu _ ...) #t) (_ #f))) -(define guile-sqlite3&co - ;; Guile-SQLite3 and its propagated inputs. - (cons guile-sqlite3 - (package-transitive-propagated-inputs guile-sqlite3))) +(define gcrypt-sqlite3&co + ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. + (append-map (lambda (package) + (cons package + (package-transitive-propagated-inputs package))) + (list guile-gcrypt guile-sqlite3))) + +(define (store-database items) + "Return a directory containing a store database where all of ITEMS and their +dependencies are registered." + (define schema + (local-file (search-path %load-path + "guix/store/schema.sql"))) + + + (define labels + (map (lambda (n) + (string-append "closure" (number->string n))) + (iota (length items)))) + + (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))) + #~(begin + (use-modules (guix store database) + (guix build store-copy) + (srfi srfi-1)) + + (define (read-closure closure) + (call-with-input-file closure read-reference-graph)) + + (let ((items (append-map read-closure '#$labels))) + (register-items items + #:state-directory #$output + #:deduplicate? #f + #:reset-timestamps? #f + #:registration-time %epoch + #:schema #$schema)))))) + + (computed-file "store-database" build + #:options `(#:references-graphs ,(zip labels items)))) (define* (self-contained-tarball name profile #:key target + (profile-name "guix-profile") deduplicate? (compressor (first %compressors)) localstatedir? @@ -114,124 +163,117 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define libgcrypt - (module-ref (resolve-interface '(gnu packages gnupg)) - 'libgcrypt)) - - (define schema + (define database (and localstatedir? - (local-file (search-path %load-path - "guix/store/schema.sql")))) + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) - => ,(make-config.scm - #:libgcrypt libgcrypt)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions guile-sqlite3&co - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) - (define %root "root") + (define %root "root") - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append archiver "/bin")) + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir? - #:schema #$schema) + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-single-profile-directory %root + #:profile #$profile + #:profile-name #$profile-name + #:closure "profile" + #:database #+database) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) - "--format=gnu" + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) + "--format=gnu" - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) - (string-append "." (%store-directory)) + (string-append "." (%store-directory)) - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))))) + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -240,7 +282,7 @@ added to the pack." (define* (squashfs-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -251,83 +293,85 @@ points for virtual file systems (like procfs), and optional symlinks. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define libgcrypt - ;; XXX: Not strictly needed, but pulled by (guix store database). - (module-ref (resolve-interface '(gnu packages gnupg)) - 'libgcrypt)) - + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) - => ,(make-config.scm - #:libgcrypt libgcrypt)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions guile-sqlite3&co - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build store-copy) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + (guix build store-copy) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) - (setenv "PATH" (string-append #$archiver "/bin")) + (define database #+database) - ;; We need an empty file in order to have a valid file argument when - ;; we reparent the root file system. Read on for why that's - ;; necessary. - (with-output-to-file ".empty" (lambda () (display ""))) + (setenv "PATH" (string-append #$archiver "/bin")) - ;; Create the squashfs image in several steps. - ;; Add all store items. Unfortunately mksquashfs throws away all - ;; ancestor directories and only keeps the basename. We fix this - ;; in the following invocations of mksquashfs. - (apply invoke "mksquashfs" - `(,@(map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - ,#$output + ;; We need an empty file in order to have a valid file argument when + ;; we reparent the root file system. Read on for why that's + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + ,#$output - ;; Here we reparent the store items. For each sub-directory of - ;; the store prefix we need one invocation of "mksquashfs". - (for-each (lambda (dir) - (apply invoke "mksquashfs" - `(".empty" - ,#$output - "-root-becomes" ,dir))) - (reverse (string-tokenize (%store-directory) - (char-set-complement (char-set #\/))))) + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) - ;; Add symlinks and mount points. - (apply invoke "mksquashfs" - `(".empty" - ,#$output - ;; Create SYMLINKS via pseudo file definitions. - ,@(append-map - (match-lambda - ((source '-> target) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (string-append #$profile "/" target)))))) - '#$symlinks) + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) - ;; Create empty mount points. - "-p" "/proc d 555 0 0" - "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0")))))) + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (string-append #$profile "/" target)))))) + '#$symlinks) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0")) + + (when database + ;; Initialize /var/guix. + (install-database-and-gc-roots "var-etc" database #$profile) + (invoke "mksquashfs" "var-etc" #$output))))) (gexp->derivation (string-append name (compressor-extension compressor) @@ -337,7 +381,7 @@ added to the pack." (define* (docker-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -347,34 +391,19 @@ image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a be a GNU triplet and it is used to derive the architecture metadata in the image." - (define defmod 'define-module) ;trick Geiser - - (define config - ;; (guix config) module for consumption by (guix gcrypt). - (scheme-file "gcrypt-config.scm" - #~(begin - (#$defmod (guix config) - #:export (%libgcrypt)) - - ;; XXX: Work around <http://bugs.gnu.org/15602>. - (eval-when (expand load eval) - (define %libgcrypt - #+(file-append libgcrypt "/lib/libgcrypt")))))) + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) - (define json - ;; Pick the guile-json package that corresponds to the Guile used to build - ;; derivations. - (if (string-prefix? "2.0" (package-version (default-guile))) - guile2.0-json - guile-json)) + (define defmod 'define-module) ;trick Geiser (define build - ;; Guile-JSON is required by (guix docker). - (with-extensions (list json) - (with-imported-modules `(,@(source-module-closure '((guix docker) - (guix build store-copy)) - #:select? not-config?) - ((guix config) => ,config)) + ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). + (with-extensions (list guile-json guile-gcrypt) + (with-imported-modules (source-module-closure '((guix docker) + (guix build store-copy)) + #:select? not-config?) #~(begin (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) @@ -385,6 +414,7 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile + #:database #+database #:system (or #$target (utsname:machine (uname))) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) @@ -562,10 +592,14 @@ please email '~a'~%") (define %default-options ;; Alist of default option values. `((format . tarball) + (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -576,6 +610,18 @@ please email '~a'~%") (squashfs . ,squashfs-image) (docker . ,docker-image))) +(define (show-formats) + ;; Print the supported pack formats. + (display (G_ "The supported formats for 'guix pack' are:")) + (newline) + (display (G_ " + tarball Self-contained tarball, ready to run on another machine")) + (display (G_ " + squashfs Squashfs image suitable for Singularity")) + (display (G_ " + docker Tarball ready for 'docker load'")) + (newline)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -592,6 +638,10 @@ please email '~a'~%") (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '("list-formats") #f #f + (lambda args + (show-formats) + (exit 0))) (option '(#\R "relocatable") #f #f (lambda (opt name arg result) (alist-cons 'relocatable? #t result))) @@ -630,6 +680,13 @@ please email '~a'~%") (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) + (option '("profile-name") #t #f + (lambda (opt name arg result) + (match arg + ((or "guix-profile" "current-guix") + (alist-cons 'profile-name arg result)) + (_ + (leave (G_ "~a: unsupported profile name~%") arg))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -647,6 +704,8 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " + --list-formats list the formats available")) + (display (G_ " -R, --relocatable produce relocatable executables")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) @@ -663,6 +722,9 @@ Create a bundle of PACKAGE.\n")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) (display (G_ " + --profile-name=NAME + populate /var/guix/profiles/.../NAME")) + (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " @@ -712,72 +774,76 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) + (with-status-report print-build-event + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2)) - (assoc-ref opts 'system) - #:graft? (assoc-ref opts 'graft?)))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (relocatable? (assoc-ref opts 'relocatable?)) - (manifest (let ((manifest (manifest-from-args store opts))) - ;; Note: We cannot honor '--bootstrap' here because - ;; 'glibc-bootstrap' lacks 'libc.a'. - (if relocatable? - (map-manifest-entries wrapped-package manifest) - manifest))) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (archiver (if (equal? pack-format 'squashfs) - squashfs-tools-next - (if bootstrap? - %bootstrap-coreutils&co - tar))) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format") - format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) - (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest - #:relative-symlinks? relocatable? - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:archiver - archiver))) - (mbegin %store-monad - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - (munless dry-run? - (built-derivations (list drv)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system))))))) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + (assoc-ref opts 'system) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries wrapped-package manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools-next + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest + #:relative-symlinks? relocatable? + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:profile-name + profile-name + #:archiver + archiver))) + (mbegin %store-monad + (show-what-to-build* (list drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + (munless dry-run? + (built-derivations (list drv)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b38a55d01c..5743816324 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,6 +24,7 @@ (define-module (guix scripts package) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix derivations) @@ -35,6 +36,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix describe) (current-profile-entries) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) @@ -66,50 +68,14 @@ (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." - - (define (rtfm) - (format (current-error-port) - (G_ "Try \"info '(guix) Invoking guix package'\" for \ -more information.~%")) - (exit 1)) + (ensure-profile-directory) ;; Create ~/.guix-profile if it doesn't exist yet. (when (and %user-profile-directory %current-profile (not (false-if-exception (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory)) - - (let ((s (stat %profile-directory #f))) - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (and s (eq? 'directory (stat:type s))) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (G_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (G_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (rtfm)))) - - ;; Bail out if it's not owned by the user. - (unless (or (not s) (= (stat:uid s) (getuid))) - (format (current-error-port) - (G_ "error: directory `~a' is not owned by you~%") - %profile-directory) - (format (current-error-port) - (G_ "Please change the owner of `~a' to user ~s.~%") - %profile-directory (or (getenv "USER") - (getenv "LOGNAME") - (getuid))) - (rtfm)))) + (symlink %current-profile %user-profile-directory))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. @@ -198,7 +164,9 @@ do not treat collisions in MANIFEST as an error." count) count) (display-search-paths entries (list profile) - #:kind 'prefix)))))))) + #:kind 'prefix))) + + (warn-about-disk-space profile)))))) ;;; @@ -238,7 +206,7 @@ of relevance scores." (info (G_ "package '~a' has been superseded by '~a'~%") (manifest-entry-name old) (package-name new)) (manifest-transaction-install-entry - (package->manifest-entry new (manifest-entry-output old)) + (package->manifest-entry* new (manifest-entry-output old)) (manifest-transaction-remove-pattern (manifest-pattern (name (manifest-entry-name old)) @@ -261,7 +229,7 @@ of relevance scores." (case (version-compare candidate-version version) ((>) (manifest-transaction-install-entry - (package->manifest-entry pkg output) + (package->manifest-entry* pkg output) transaction)) ((<) transaction) @@ -274,7 +242,7 @@ of relevance scores." (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry - (package->manifest-entry pkg output) + (package->manifest-entry* pkg output) transaction)))))))) (#f (warning (G_ "package '~a' no longer exists~%") name) @@ -328,7 +296,10 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." `((verbosity . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t))) + (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... @@ -570,6 +541,52 @@ upgrading, #f otherwise." (output "out") ;XXX: wild guess (item item)))) +(define (package-provenance package) + "Return the provenance of PACKAGE as an sexp for use as the 'provenance' +property of manifest entries, or #f if it could not be determined." + (define (entry-source entry) + (match (assq 'source + (manifest-entry-properties entry)) + (('source value) value) + (_ #f))) + + (match (and=> (package-location package) location-file) + (#f #f) + (file + (let ((file (if (string-prefix? "/" file) + file + (search-path %load-path file)))) + (and file + (string-prefix? (%store-prefix) file) + + ;; Always store information about the 'guix' channel and + ;; optionally about the specific channel FILE comes from. + (or (let ((main (and=> (find (lambda (entry) + (string=? "guix" + (manifest-entry-name entry))) + (current-profile-entries)) + entry-source)) + (extra (any (lambda (entry) + (let ((item (manifest-entry-item entry))) + (and (string-prefix? item file) + (entry-source entry)))) + (current-profile-entries)))) + (and main + `(,main + ,@(if extra (list extra) '())))))))))) + +(define (package->manifest-entry* package output) + "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to +the resulting manifest entry." + (define (provenance-properties package) + (match (package-provenance package) + (#f '()) + (sexp `((provenance ,@sexp))))) + + (package->manifest-entry package output + #:properties (provenance-properties package))) + + (define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', return an variant of TRANSACTION that accounts for the specified installations @@ -590,13 +607,13 @@ and upgrades." (('install . (? package? p)) ;; When given a package via `-e', install the first of its ;; outputs (XXX). - (package->manifest-entry p "out")) + (package->manifest-entry* p "out")) (('install . (? string? spec)) (if (store-path? spec) (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (package->manifest-entry package output)))) + (package->manifest-entry* package output)))) (_ #f)) opts)) @@ -754,9 +771,13 @@ processed, #f otherwise." (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-name name version))) + (match (find-packages-by-name name version) + (() + (leave (G_ "~a~@[@~a~]: package not found~%") name version)) + (packages + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + packages)))) #t)) (('search-paths kind) @@ -883,14 +904,18 @@ processed, #f otherwise." (arg-handler arg result) (leave (G_ "~A: extraneous argument~%") arg))) - (let ((opts (parse-command-line args %options (list %default-options #f) - #:argument-handler handle-argument))) - (with-error-handling - (or (process-query opts) - (parameterize ((%store (open-connection)) - (%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line (%store) opts) + (define opts + (parse-command-line args %options (list %default-options #f) + #:argument-handler handle-argument)) + (define verbose? + (assoc-ref opts 'verbose?)) + (with-error-handling + (or (process-query opts) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) + (with-status-report print-build-event/quiet + (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation (%store) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 18e2fc92f2..df787a9940 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +41,8 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define* (perform-download drv #:optional output) +(define* (perform-download drv #:optional output + #:key print-build-trace?) "Perform the download described by DRV, a fixed-output derivation, to OUTPUT. @@ -67,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or ;; We're invoked by the daemon, which gives us write access to OUTPUT. (when (url-fetch url output + #:print-build-trace? print-build-trace? #:mirrors (if mirrors (call-with-input-file mirrors read) '()) @@ -98,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code of GnuTLS over HTTPS, before we have built GnuTLS. See <http://bugs.gnu.org/22774>." + (define print-build-trace? + (match (getenv "_NIX_OPTIONS") + (#f #f) + (str (string-contains str "print-extended-build-trace=1")))) + ;; This program must be invoked by guix-daemon under an unprivileged UID to ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code ;; execution via the content-addressed mirror procedures. (That means we @@ -107,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (((? derivation-path? drv) (? store-path? output)) (assert-low-privileges) (perform-download (read-derivation-from-file drv) - output)) + output + #:print-build-trace? print-build-trace?)) (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) - (perform-download (read-derivation-from-file drv))) + (perform-download (read-derivation-from-file drv) + #:print-build-trace? print-build-trace?)) (("--version") (show-version-and-exit)) (x diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm new file mode 100644 index 0000000000..6a2f603599 --- /dev/null +++ b/guix/scripts/processes.scm @@ -0,0 +1,223 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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 processes) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (process? + process-id + process-parent-id + process-command + processes + + daemon-session? + daemon-session-process + daemon-session-client + daemon-session-children + daemon-session-locks-held + daemon-sessions + + guix-processes)) + +;; Process as can be found in /proc on GNU/Linux. +(define-record-type <process> + (process id parent command) + process? + (id process-id) ;integer + (parent process-parent-id) ;integer | #f + (command process-command)) ;list of strings + +(define (write-process process port) + (format port "#<process ~a>" (process-id process))) + +(set-record-type-printer! <process> write-process) + +(define (read-status-ppid port) + "Read the PPID from PORT, an input port on a /proc/PID/status file. Return +#f for PID 1 and kernel pseudo-processes." + (let loop () + (match (read-line port) + ((? eof-object?) #f) + (line + (if (string-prefix? "PPid:" line) + (string->number (string-trim-both (string-drop line 5))) + (loop)))))) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (read-command-line port) + "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and +return it as a list." + (string-tokenize (read-string port) %not-nul)) + +(define (processes) + "Return a list of process records representing the currently alive +processes." + ;; This assumes a Linux-compatible /proc file system. There exists one for + ;; GNU/Hurd. + (filter-map (lambda (pid) + ;; There's a TOCTTOU race here. If we get ENOENT, simply + ;; ignore PID. + (catch 'system-error + (lambda () + (define ppid + (call-with-input-file (string-append "/proc/" pid "/status") + read-status-ppid)) + (define command + (call-with-input-file (string-append "/proc/" pid "/cmdline") + read-command-line)) + (process (string->number pid) ppid command)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (scandir "/proc" string->number))) + +(define (process-open-files process) + "Return the list of files currently open by PROCESS." + (let ((directory (string-append "/proc/" + (number->string (process-id process)) + "/fd"))) + (map (lambda (fd) + (readlink (string-append directory "/" fd))) + (or (scandir directory string->number) '())))) + +;; Daemon session. +(define-record-type <daemon-session> + (daemon-session process client children locks) + daemon-session? + (process daemon-session-process) ;<process> + (client daemon-session-client) ;<process> + (children daemon-session-children) ;list of <process> + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of <daemon-session> denoting the currently +active sessions, and the master 'guix-daemon' process." + (define (lock-file? file) + (and (string-prefix? (%store-prefix) file) + (string-suffix? ".lock" file))) + + (let* ((processes (processes)) + (daemons (filter (lambda (process) + (match (process-command process) + ((argv0 _ ...) + (string=? (basename argv0) "guix-daemon")) + (_ #f))) + processes)) + (children (filter (lambda (process) + (match (process-command process) + ((argv0 (= string->number argv1) _ ...) + (integer? argv1)) + (_ #f))) + daemons)) + (master (remove (lambda (process) + (memq process children)) + daemons))) + (define (lookup-process pid) + (find (lambda (process) + (and (process-id process) + (= pid (process-id process)))) + processes)) + + (define (lookup-children pid) + (filter (lambda (process) + (and (process-parent-id process) + (= pid (process-parent-id process)))) + processes)) + + (values (map (lambda (process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process))) + (daemon-session process + (lookup-process client) + (lookup-children (process-id process)) + (filter lock-file? files)))))) + children) + master))) + +(define (daemon-session->recutils session port) + "Display SESSION information in recutils format on PORT." + (format port "SessionPID: ~a~%" + (process-id (daemon-session-process session))) + (format port "ClientPID: ~a~%" + (process-id (daemon-session-client session))) + (format port "ClientCommand:~{ ~a~}~%" + (process-command (daemon-session-client session))) + (for-each (lambda (lock) + (format port "LockHeld: ~a~%" lock)) + (daemon-session-locks-held session)) + (for-each (lambda (process) + (format port "ChildProcess: ~a:~{ ~a~}~%" + (process-id process) + (process-command process))) + (daemon-session-children session))) + + +;;; +;;; Options. +;;; + +(define %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 processes"))))) + +(define (show-help) + (display (G_ "Usage: guix processes +List the current Guix sessions and their processes.")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-processes . args) + (define options + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + cons + '())) + + (for-each (lambda (session) + (daemon-session->recutils session (current-output-port)) + (newline)) + (daemon-sessions))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index b5dfdab32f..c5326b33da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -44,9 +44,9 @@ #:use-module (guix base64) #:use-module (guix config) #:use-module (guix derivations) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix pki) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 433502b5de..dc83729911 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix status) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -30,64 +31,26 @@ #:use-module (guix grafts) #:use-module (guix memoization) #:use-module (guix monads) + #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) - #:autoload (guix self) (whole-package) + #:use-module (guix git) + #:use-module (git) #:use-module (gnu packages) - #:autoload (gnu packages ssh) (guile-ssh) - #:autoload (gnu packages tls) (gnutls) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module ((guix build utils) - #:select (with-directory-excursion delete-file-recursively)) - #:use-module ((guix build download) - #:select (%x509-certificate-directory)) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 vlist) - #:export (guix-pull)) - -(module-autoload! (resolve-module '(guix scripts pull)) - '(git) '(git-error? set-tls-certificate-locations!) - '(guix git) '(latest-repository-commit)) - -(define (ensure-guile-git!) - ;; Previously Guile-Git was not a prerequisite. Thus, someone running 'guix - ;; pull' on an old installation may be lacking Guile-Git. To address this, - ;; we autoload things that depend on Guile-Git and check in the entry point - ;; whether Guile-Git is available. - ;; - ;; TODO: Remove this hack when Guile-Git is widespread or enforced. - - (unless (false-if-exception (resolve-interface '(git))) - (leave (G_ "Guile-Git is missing but it is now required by 'guix pull'. -Install it by running: - - guix package -i ~a - export GUILE_LOAD_PATH=$HOME/.guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH - export GUILE_LOAD_COMPILED_PATH=$HOME/.guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH -\n") - (match (effective-version) - ("2.0" "guile2.0-git") - (_ "guile-git")) - (effective-version) - (effective-version))) - - ;; XXX: For unclear reasons this is needed for - ;; 'set-tls-certificate-locations!'. - (module-use! (resolve-module '(guix scripts pull)) - (resolve-interface '(git)))) - -(define %repository-url - (or (getenv "GUIX_PULL_URL") "https://git.savannah.gnu.org/git/guix.git")) + #:export (display-profile-content + guix-pull)) ;;; @@ -96,11 +59,12 @@ Install it by running: (define %default-options ;; Alist of default option values. - `((repository-url . ,%repository-url) - (ref . (branch . "origin/master")) - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0))) @@ -110,6 +74,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --verbose produce verbose output")) (display (G_ " + -C, --channels=FILE deploy the channels defined in FILE")) + (display (G_ " --url=URL download from the Git repository at URL")) (display (G_ " --commit=COMMIT download the specified COMMIT")) @@ -119,6 +85,10 @@ Download and deploy the latest version of Guix.\n")) -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_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) @@ -134,6 +104,9 @@ Download and deploy the latest version of Guix.\n")) (cons* (option '("verbose") #f #f (lambda (opt name arg result) (alist-cons 'verbose? #t result))) + (option '(#\C "channels") #t #f + (lambda (opt name arg result) + (alist-cons 'channel-file arg result))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) @@ -149,6 +122,10 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile (canonicalize-profile arg) + result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -171,70 +148,6 @@ Download and deploy the latest version of Guix.\n")) (define indirect-root-added (store-lift add-indirect-root)) -(define %self-build-file - ;; The file containing code to build Guix. This serves the same purpose as - ;; a makefile, and, similarly, is intended to always keep this name. - "build-aux/build-self.scm") - -(define %pull-version - ;; This is the version of the 'guix pull' protocol. It specifies what's - ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd - ;; place a set of compiled Guile modules in ~/.config/guix/latest. - 1) - -(define* (build-from-source source - #:key verbose? commit) - "Return a derivation to build Guix from SOURCE, using the self-build script -contained therein. Use COMMIT as the version string." - ;; Running the self-build script makes it easier to update the build - ;; procedure: the self-build script of the Guix-to-be-installed contains the - ;; right dependencies, build procedure, etc., which the Guix-in-use may not - ;; be know. - (let* ((script (string-append source "/" %self-build-file)) - (build (primitive-load script))) - ;; BUILD must be a monadic procedure of at least one argument: the source - ;; tree. - ;; - ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In the - ;; future we'll fall back to a previous version of the protocol when that - ;; happens. - (build source #:verbose? verbose? #:version commit - #:pull-version %pull-version))) - -(define (whole-package-for-legacy name modules) - "Return a full-blown Guix package for MODULES, a derivation that builds Guix -modules in the old ~/.config/guix/latest style." - (whole-package name modules - - ;; In the "old style", %SELF-BUILD-FILE would simply return a - ;; derivation that builds modules. We have to infer what the - ;; dependencies of these modules were. - (list guile-json guile-git guile-bytestructures - guile-ssh gnutls))) - -(define* (derivation->manifest-entry drv - #:key url branch commit) - "Return a manifest entry for DRV, which represents Guix at COMMIT. Record -URL, BRANCH, and COMMIT as a property in the manifest entry." - (mbegin %store-monad - (what-to-build (list drv)) - (built-derivations (list drv)) - (let ((out (derivation->output-path drv))) - (return (manifest-entry - (name "guix") - (version (string-take commit 7)) - (item (if (file-exists? (string-append out "/bin/guix")) - drv - (whole-package-for-legacy (string-append name "-" - version) - drv))) - (properties - `((source (repository - (version 0) - (url ,url) - (branch ,branch) - (commit ,commit)))))))))) - (define (display-profile-news profile) "Display what's up in PROFILE--new packages, and all that." (match (memv (generation-number profile) @@ -252,25 +165,19 @@ URL, BRANCH, and COMMIT as a property in the manifest entry." #:heading (G_ "New in this revision:\n")))) (_ #t))) -(define* (build-and-install source config-dir - #:key verbose? url branch commit) - "Build the tool from SOURCE, and install it in CONFIG-DIR." +(define* (build-and-install instances profile + #:key verbose? dry-run?) + "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is +true, display what would be built without actually building it." (define update-profile (store-lift build-and-use-profile)) - (define profile - (string-append config-dir "/current")) - - (mlet* %store-monad ((drv (build-from-source source - #:commit commit - #:verbose? verbose?)) - (entry (derivation->manifest-entry drv - #:url url - #:branch branch - #:commit commit))) + (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad - (update-profile profile (manifest (list entry))) - (return (display-profile-news profile))))) + (update-profile profile manifest + #:dry-run? dry-run?) + (munless dry-run? + (return (display-profile-news profile)))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -278,17 +185,34 @@ URL, BRANCH, and COMMIT as a property in the manifest entry." (certs (string-append (derivation->output-path drv) "/etc/ssl/certs"))) (build-derivations store (list drv)) + (set-tls-certificate-locations! certs))) - ;; In the past Guile-Git would not provide this procedure. - (if (module-defined? (resolve-interface '(git)) - 'set-tls-certificate-locations!) - (set-tls-certificate-locations! certs) - (begin - ;; In this case we end up using whichever certificates OpenSSL - ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs. - (warning (G_ "cannot enforce use of the Let's Encrypt \ -certificates~%")) - (warning (G_ "please upgrade Guile-Git~%")))))) +(define (honor-x509-certificates store) + "Use the right X.509 certificates for Git checkouts over HTTPS." + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) + (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) + (if (or file + (and=> (stat directory #f) + (lambda (st) + (> (stat:nlink st) 2)))) + (set-tls-certificate-locations! directory file) + (honor-lets-encrypt-certificates! store)))) (define (report-git-error error) "Report the given Guile-Git error." @@ -309,6 +233,60 @@ certificates~%")) ;;; +;;; Profile. +;;; + +(define %current-profile + ;; The "real" profile under /var/guix. + (string-append %profile-directory "/current-guix")) + +(define %user-profile-directory + ;; The user-friendly name of %CURRENT-PROFILE. + (string-append (config-directory #:ensure? #f) "/current")) + +(define (migrate-generations profile directory) + "Migrate the generations of PROFILE to DIRECTORY." + (format (current-error-port) + (G_ "Migrating profile generations to '~a'...~%") + %profile-directory) + (let ((current (generation-number profile))) + (for-each (lambda (generation) + (let ((source (generation-file-name profile generation)) + (target (string-append directory "/current-guix-" + (number->string generation) + "-link"))) + ;; Note: Don't use 'rename-file' as SOURCE and TARGET might + ;; live on different file systems. + (symlink (readlink source) target) + (delete-file source))) + (profile-generations profile)) + (symlink (string-append "current-guix-" + (number->string current) "-link") + (string-append directory "/current-guix")))) + +(define (ensure-default-profile) + (ensure-profile-directory) + + ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move + ;; them to %PROFILE-DIRECTORY. + (unless (string=? %profile-directory + (dirname (canonicalize-profile %user-profile-directory))) + (migrate-generations %user-profile-directory %profile-directory)) + + ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. + (let ((link %user-profile-directory)) + (unless (equal? (false-if-exception (readlink link)) + %current-profile) + (catch 'system-error + (lambda () + (false-if-exception (delete-file link)) + (symlink %current-profile link)) + (lambda args + (leave (G_ "while creating symlink '~a': ~a~%") + link (strerror (system-error-errno args)))))))) + + +;;; ;;; Queries. ;;; @@ -335,7 +313,9 @@ way and displaying details about the channel's source code." ;; Show most recently installed packages last. (reverse (manifest-entries - (profile-manifest (generation-file-name profile number)))))) + (profile-manifest (if (zero? number) + profile + (generation-file-name profile number))))))) (define (indented-string str indent) "Return STR with each newline preceded by IDENT spaces." @@ -421,11 +401,8 @@ and ALIST2 differ, display HEADING upfront." (display-new/upgraded-packages (package-alist gen1) (package-alist gen2))) -(define (process-query opts) - "Process any query specified by OPTS." - (define profile - (string-append (config-directory) "/current")) - +(define (process-query opts profile) + "Process any query on PROFILE specified by OPTS." (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generations profile numbers) @@ -455,62 +432,111 @@ and ALIST2 differ, display HEADING upfront." ((numbers ...) (list-generations profile numbers))))))))) +(define (channel-list opts) + "Return the list of channels to use. If OPTS specify a channel file, +channels are read from there; otherwise, if ~/.config/guix/channels.scm +exists, read it; otherwise %DEFAULT-CHANNELS is used. Apply channel +transformations specified in OPTS (resulting from '--url', '--commit', or +'--branch'), if any." + (define file + (assoc-ref opts 'channel-file)) + + (define default-file + (string-append (config-directory) "/channels.scm")) + + (define (load-channels file) + (let ((result (load* file (make-user-module '((guix channels)))))) + (if (and (list? result) (every channel? result)) + result + (leave (G_ "'~a' did not return a list of channels~%") file)))) + + (define channels + (cond (file + (load-channels file)) + ((file-exists? default-file) + (load-channels default-file)) + (else + %default-channels))) + + (define (environment-variable) + (match (getenv "GUIX_PULL_URL") + (#f #f) + (url + (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated. +Use '~/.config/guix/channels.scm' instead.")) + url))) + + (let ((ref (assoc-ref opts 'ref)) + (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 + (('commit . commit) + (channel (inherit one) + (url url) (commit commit) (branch #f))) + (('branch . branch) + (channel (inherit one) + (url url) (commit #f) (branch branch))) + (#f + (channel (inherit one) (url url))))))) + (_ + ;; Otherwise bail out. + (leave + (G_ "'--url', '--commit', and '--branch' are not applicable~%")))) + channels))) + (define (guix-pull . args) - (define (use-le-certs? url) - (string-prefix? "https://git.savannah.gnu.org/" url)) - (with-error-handling (with-git-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) - (url (assoc-ref opts 'repository-url)) - (ref (assoc-ref opts 'ref)) - (cache (string-append (cache-directory) "/pull"))) - (ensure-guile-git!) - + (let* ((opts (parse-command-line args %options + (list %default-options))) + (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)) - ((assoc-ref opts 'dry-run?) - #t) ;XXX: not very useful + (process-query opts profile)) (else (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - - ;; For reproducibility, always refer to the LE certificates - ;; when we know we're talking to Savannah. - (when (use-le-certs? url) - (honor-lets-encrypt-certificates! store)) - - (format (current-error-port) - (G_ "Updating from Git repository at '~a'...~%") - url) - - (let-values (((checkout commit) - (latest-repository-commit store url - #:ref ref - #:cache-directory - cache))) + (with-status-report print-build-event + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%repository-cache-directory cache)) + (set-build-options-from-command-line store opts) + (honor-x509-certificates store) - (format (current-error-port) - (G_ "Building from Git commit ~a...~%") - commit) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:url url - #:branch (match ref - (('branch . branch) - branch) - (_ #f)) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?))))))))))))) + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install instances profile + #:dry-run? + (assoc-ref opts 'dry-run?) + #:verbose? + (assoc-ref opts 'verbose?)))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a8fe993e33..58fc64db1f 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -23,7 +23,7 @@ (define-module (guix scripts refresh) #:use-module (guix ui) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) @@ -89,6 +89,9 @@ (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '("keyring") #t #f + (lambda (opt name arg result) + (alist-cons 'keyring arg result))) (option '("key-server") #t #f (lambda (opt name arg result) (alist-cons 'key-server arg result))) @@ -139,6 +142,8 @@ specified with `--select'.\n")) be rebuilt as a result of upgrading PACKAGE...")) (newline) (display (G_ " + --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) + (display (G_ " --key-server=HOST use HOST as the OpenPGP key server")) (display (G_ " --gpg=COMMAND use COMMAND as the GnuPG 2.x command")) @@ -437,7 +442,11 @@ update would trigger a complete rebuild." (%openpgp-key-server))) (%gpg-command (or (assoc-ref opts 'gpg-command) - (%gpg-command)))) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) (for-each (cut update-package store <> updaters #:key-download key-download diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index b157833a49..02169e8004 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -188,7 +188,15 @@ call THUNK." (save-module-excursion (lambda () (set-current-module user-module) - (start-repl)))) + (and=> (getenv "HOME") + (lambda (home) + (let ((guile (string-append home "/.guile"))) + (when (file-exists? guile) + (load guile))))) + ;; Do not exit repl on SIGINT. + ((@@ (ice-9 top-repl) call-with-sigint) + (lambda () + (start-repl)))))) ((machine) (machine-repl)) (else diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 7634bb37f6..eb82224016 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -26,11 +26,11 @@ #:use-module (guix config) #:use-module (guix records) #:use-module ((guix serialization) #:select (restore-file)) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix cache) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) @@ -837,8 +837,17 @@ REPORTER, which should be a <progress-reporter> object." (make-custom-binary-input-port "progress-port-proc" read! #f #f (lambda () - (close-connection port) - (stop))))))) + ;; XXX: Kludge! When used through + ;; 'decompressed-port', this port ends + ;; up being closed twice: once in a + ;; child process early on, and at the + ;; end in the parent process. Ignore + ;; the early close so we don't output + ;; a spurious "download-succeeded" + ;; trace. + (unless (zero? total) + (stop)) + (close-port port))))))) (define-syntax with-networking (syntax-rules () @@ -930,7 +939,7 @@ authorized substitutes." (error "unknown `--query' command" wtf)))) (define* (process-substitution store-item destination - #:key cache-urls acl) + #:key cache-urls acl print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." (let* ((narinfo (lookup-narinfo cache-urls store-item @@ -943,8 +952,10 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) - (format (current-error-port) - (G_ "Downloading ~a...~%") (uri->string uri)) + (unless print-build-trace? + (format (current-error-port) + (G_ "Downloading ~a...~%") (uri->string uri))) + (let*-values (((raw download-size) ;; Note that Hydra currently generates Nars on the fly ;; and doesn't specify a Content-Length, so @@ -955,10 +966,15 @@ DESTINATION as a nar file. Verify the substitute against ACL." (dl-size (or download-size (and (equal? comp "none") (narinfo-size narinfo)))) - (reporter (progress-reporter/file - (uri->string uri) dl-size - (current-error-port) - #:abbreviation nar-uri-abbreviation))) + (reporter (if print-build-trace? + (progress-reporter/trace + destination + (uri->string uri) dl-size + (current-error-port)) + (progress-reporter/file + (uri->string uri) dl-size + (current-error-port) + #:abbreviation nar-uri-abbreviation)))) (progress-report-port reporter raw))) ((input pids) ;; NOTE: This 'progress' port of current process will be @@ -1058,6 +1074,13 @@ default value." (define (guix-substitute . args) "Implement the build daemon's substituter protocol." + (define print-build-trace? + (match (or (find-daemon-option "untrusted-print-extended-build-trace") + (find-daemon-option "print-extended-build-trace")) + (#f #f) + ((= string->number number) (> number 0)) + (_ #f))) + (mkdir-p %narinfo-cache-directory) (maybe-remove-expired-cache-entries %narinfo-cache-directory cached-narinfo-files @@ -1087,7 +1110,10 @@ default value." (#f #f) (locale (false-if-exception (setlocale LC_ALL locale)))) - (set-thread-name "guix substitute") + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' (with-networking (with-error-handling ; for signature errors @@ -1108,7 +1134,8 @@ default value." (parameterize ((current-terminal-columns (client-terminal-columns))) (process-substitution store-path destination #:cache-urls (substitute-urls) - #:acl (current-acl)))) + #:acl (current-acl) + #:print-build-trace? print-build-trace?))) ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) (("--help") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 69bd05b516..d92ec7d5a5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,6 +23,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:autoload (guix store database) (register-path) #:use-module (guix grafts) @@ -174,12 +175,16 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer-drv +(define* (install-bootloader installer #:key bootcfg bootcfg-file target) - "Call INSTALLER-DRV with error handling, in %STORE-MONAD." - (with-monad %store-monad + "Run INSTALLER, a bootloader installation script, with error handling, in +%STORE-MONAD." + (mlet %store-monad ((installer-drv (if installer + (lower-object installer) + (return #f))) + (bootcfg (lower-object bootcfg))) (let* ((gc-root (string-append target %gc-roots-directory "/bootcfg")) (temp-gc-root (string-append gc-root ".new")) @@ -234,26 +239,33 @@ When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG." the ownership of '~a' may be incorrect!~%") target)) + ;; If a previous installation was attempted, make sure we start anew; in + ;; particular, we don't want to keep a store database that might not + ;; correspond to what we're actually putting in the store. + (let ((state (string-append target "/var/guix"))) + (when (file-exists? state) + (delete-file-recursively state))) + (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) - (mbegin %store-monad - ;; Copy the closure of BOOTCFG, which includes OS-DIR, - ;; eventual background image and so on. - (maybe-copy - (derivation->output-path bootcfg)) + (mlet %store-monad ((bootcfg (lower-object bootcfg))) + (mbegin %store-monad + ;; Copy the closure of BOOTCFG, which includes OS-DIR, + ;; eventual background image and so on. + (maybe-copy (derivation->output-path bootcfg)) - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate os-dir target) + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) - (mwhen install-bootloader? - (install-bootloader bootloader-installer - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target))))) + (mwhen install-bootloader? + (install-bootloader bootloader-installer + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:target target)))))) ;;; @@ -310,9 +322,9 @@ names of services to load (upgrade), and the list of names of services to unload." (match (current-services) ((services ...) - (let-values (((to-unload to-load) + (let-values (((to-unload to-restart) (shepherd-service-upgrade services new-services))) - (mproc to-load + (mproc to-restart (map (compose first live-service-provision) to-unload)))) (#f @@ -335,25 +347,32 @@ bring the system down." ;; Arrange to simply emit a warning if the service upgrade fails. (with-shepherd-error-handling (call-with-service-upgrade-info new-services - (lambda (to-load to-unload) + (lambda (to-restart to-unload) (for-each (lambda (unload) (info (G_ "unloading service '~a'...~%") unload) (unload-service unload)) to-unload) (with-monad %store-monad - (munless (null? to-load) - (let ((to-load-names (map shepherd-service-canonical-name to-load)) - (to-start (filter shepherd-service-auto-start? to-load))) - (info (G_ "loading new services:~{ ~a~}...~%") to-load-names) + (munless (null? new-services) + (let ((new-service-names (map shepherd-service-canonical-name new-services)) + (to-restart-names (map shepherd-service-canonical-name to-restart)) + (to-start (filter shepherd-service-auto-start? new-services))) + (info (G_ "loading new services:~{ ~a~}...~%") new-service-names) + (unless (null? to-restart-names) + ;; Listing TO-RESTART-NAMES in the message below wouldn't help + ;; because many essential services cannot be meaningfully + ;; restarted. See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>. + (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop, +upgrade, and restart each service that was not automatically restarted.\n"))) (mlet %store-monad ((files (mapm %store-monad (compose lower-object shepherd-service-file) - to-load))) + new-services))) ;; Here we assume that FILES are exactly those that were computed ;; as part of the derivation that built OS, which is normally the ;; case. - (load-services (map derivation->output-path files)) + (load-services/safe (map derivation->output-path files)) (for-each start-service (map shepherd-service-canonical-name to-start)) @@ -775,19 +794,18 @@ checking this by themselves in their 'check' procedure." (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) -(define (bootloader-installer-derivation installer - bootloader device target) +(define (bootloader-installer-script installer + bootloader device target) "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE and TARGET arguments." - (with-monad %store-monad - (gexp->file "bootloader-installer" - (with-imported-modules '((gnu build bootloader) - (guix build utils)) - #~(begin - (use-modules (gnu build bootloader) - (guix build utils) - (ice-9 binary-ports)) - (#$installer #$bootloader #$device #$target)))))) + (scheme-file "bootloader-installer" + (with-imported-modules '((gnu build bootloader) + (guix build utils)) + #~(begin + (use-modules (gnu build bootloader) + (guix build utils) + (ice-9 binary-ports)) + (#$installer #$bootloader #$device #$target))))) (define* (perform-action action os #:key skip-safety-checks? @@ -815,6 +833,25 @@ static checks." (define println (cut format #t "~a~%" <>)) + (define menu-entries + (if (eq? 'init action) + '() + (map boot-parameters->menu-entry (profile-boot-parameters)))) + + (define bootloader + (bootloader-configuration-bootloader (operating-system-bootloader os))) + + (define bootcfg + (and (not (eq? 'container action)) + (operating-system-bootcfg os menu-entries))) + + (define bootloader-script + (let ((installer (bootloader-installer bootloader)) + (target (or target "/"))) + (bootloader-installer-script installer + (bootloader-package bootloader) + bootloader-target target))) + (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) @@ -834,39 +871,16 @@ static checks." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (bootloader -> (bootloader-configuration-bootloader - (operating-system-bootloader os))) - (bootloader-package - (let ((package (bootloader-package bootloader))) - (if package - (package->derivation package) - (return #f)))) - (bootcfg (if (eq? 'container action) - (return #f) - (operating-system-bootcfg - os - (if (eq? 'init action) - '() - (map boot-parameters->menu-entry - (profile-boot-parameters)))))) - (bootcfg-file -> (bootloader-configuration-file bootloader)) - (bootloader-installer - (let ((installer (bootloader-installer bootloader)) - (target (or target "/"))) - (bootloader-installer-derivation installer - bootloader-package - bootloader-target target))) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; --no-bootloader is passed, because we then use it as a GC root. ;; See <http://bugs.gnu.org/21068>. - (drvs -> (if (memq action '(init reconfigure)) - (if (and install-bootloader? bootloader-package) - (list sys bootcfg - bootloader-package - bootloader-installer) - (list sys bootcfg)) - (list sys))) + (drvs (mapm %store-monad lower-object + (if (memq action '(init reconfigure)) + (if install-bootloader? + (list sys bootcfg bootloader-script) + (list sys bootcfg)) + (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) @@ -875,7 +889,7 @@ static checks." (if (or dry-run? derivations-only?) (return #f) - (begin + (let ((bootcfg-file (bootloader-configuration-file bootloader))) (for-each (compose println derivation->output-path) drvs) @@ -884,7 +898,7 @@ static checks." (mbegin %store-monad (switch-to-system os) (mwhen install-bootloader? - (install-bootloader bootloader-installer + (install-bootloader bootloader-script #:bootcfg bootcfg #:bootcfg-file bootcfg-file #:target "/")))) @@ -896,7 +910,7 @@ static checks." #:install-bootloader? install-bootloader? #:bootcfg bootcfg #:bootcfg-file bootcfg-file - #:bootloader-installer bootloader-installer)) + #:bootloader-installer bootloader-script)) (else ;; All we had to do was to build SYS and maybe register an ;; indirect GC root. @@ -1072,6 +1086,9 @@ Some ACTIONS support additional ARGS.\n")) `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0) (file-system-type . "ext4") @@ -1150,7 +1167,8 @@ resulting from command-line parsing." #:target target #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) - #:system system)))) + #:system system)) + (warn-about-disk-space))) (define (resolve-subcommand name) (let ((module (resolve-interface @@ -1246,9 +1264,11 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (current-terminal-columns (terminal-columns))) - (process-command command args opts))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-report (if (memq command '(init reconfigure)) + print-build-event/quiet + print-build-event) + (process-command command args opts)))))) ;;; Local Variables: ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) |