diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 90 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 123 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 56 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 460 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/processes.scm | 223 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/repl.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 2 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 134 |
13 files changed, 819 insertions, 340 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 13978abb77..0b7da3189e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,8 @@ #: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)) @@ -63,7 +65,7 @@ (define %default-log-urls ;; Default base URLs for build logs. - '("http://hydra.gnu.org/log")) + '("http://ci.guix.info/log")) ;; XXX: The following procedure cannot be in (guix store) because of the ;; dependency on (guix derivations). @@ -270,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 @@ -277,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. @@ -291,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_ " @@ -302,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) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index e59502076c..7d0ecb0a4d 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,6 @@ ;;; 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. ;;; @@ -18,11 +19,13 @@ (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) @@ -38,9 +41,13 @@ ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels")) + (unless (member arg '("human" "channels" "json" "recutils")) (leave (G_ "~a: unsupported output format~%") arg)) - (alist-cons 'format 'channels result))) + (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) @@ -58,6 +65,8 @@ 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")) @@ -78,6 +87,22 @@ Display information about the channels currently in use.\n")) (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 @@ -98,10 +123,19 @@ within a Git checkout." (format #t (G_ " branch: ~a~%") (reference-shorthand head)) (format #t (G_ " commit: ~a~%") commit)) ('channels - (pretty-print `(list (channel - (name 'guix) - (url ,(dirname directory)) - (commit ,commit)))))) + (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) @@ -110,34 +144,46 @@ 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 (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. - (_ '???))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (if (zero? number) - profile - (generation-file-name profile number)))))))))) + (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)) @@ -146,15 +192,16 @@ in the format specified by FMT." ;;; (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))) + (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 (current-profile) + (match profile (#f (display-checkout-info format)) (profile diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 2bd2ac4a06..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. ;;; @@ -44,7 +45,7 @@ `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (G_ "Usage: gcrypt hash [OPTION] FILE + (display (G_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' @@ -93,7 +94,7 @@ and 'hexadecimal' can be used as well).\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "gcrypt hash"))))) + (show-version-and-exit "guix hash"))))) 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) - - ;; 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))))) + (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 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 13aa8923cd..6c6680ab58 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. ;;; @@ -38,7 +39,7 @@ #: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) @@ -52,6 +53,9 @@ #:export (compressor? lookup-compressor self-contained-tarball + docker-image + squashfs-image + guix-pack)) ;; Type of a compression tool. @@ -103,8 +107,50 @@ found." (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? @@ -117,125 +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)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-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)) - - (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 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"))) - - ;; 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) - - ;; 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" - #+@(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" - - "--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)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))))) + (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 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)) + + ;; 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")) + + ;; 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 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" + + "--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)) + + (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)) @@ -244,7 +282,7 @@ added to the pack." (define* (squashfs-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -255,75 +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 build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) - (setenv "PATH" (string-append #$archiver "/bin")) + (define build + (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)) - ;; 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 ""))) - - ;; 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 - - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) - - ;; 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 #\/))))) - - ;; 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")))))) + (define database #+database) + + (setenv "PATH" (string-append #$archiver "/bin")) + + ;; 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 ""))) + + ;; 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 + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) + + ;; 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 #\/))))) + + ;; 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) @@ -333,7 +381,7 @@ added to the pack." (define* (docker-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -343,6 +391,11 @@ 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 database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) + (define defmod 'define-module) ;trick Geiser (define build @@ -361,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) @@ -538,6 +592,7 @@ 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) @@ -555,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 @@ -571,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))) @@ -609,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))) @@ -626,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")) @@ -642,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_ " @@ -730,7 +813,8 @@ Create a bundle of PACKAGE.\n")) (#f (leave (G_ "~a: unknown pack format~%") pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest @@ -749,6 +833,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:profile-name + profile-name #:archiver archiver))) (mbegin %store-monad diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5d146b8427..5743816324 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -164,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)))))) ;;; @@ -769,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) 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/pull.scm b/guix/scripts/pull.scm index 188237aa90..dc83729911 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -87,6 +87,8 @@ Download and deploy the latest version of Guix.\n")) (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) @@ -164,15 +166,18 @@ Download and deploy the latest version of Guix.\n")) (_ #t))) (define* (build-and-install instances profile - #:key verbose?) - "Build the tool from SOURCE, and install it in 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)) (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad - (update-profile profile manifest) - (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." @@ -497,8 +502,6 @@ Use '~/.config/guix/channels.scm' instead.")) (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) - ((assoc-ref opts 'dry-run?) - #t) ;XXX: not very useful (else (with-store store (with-status-report print-build-event @@ -531,6 +534,8 @@ Use '~/.config/guix/channels.scm' instead.")) (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?)))))))))))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 58fc64db1f..1d86f949c8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -179,24 +179,24 @@ specified with `--select'.\n")) (let* ((packages (fold-packages cons '())) (total (length packages))) - (define covered - (fold (lambda (updater covered) - (let ((matches (count (upstream-updater-predicate updater) - packages))) + (define uncovered + (fold (lambda (updater uncovered) + (let ((matches (filter (upstream-updater-predicate updater) + packages))) ;; TRANSLATORS: The parenthetical expression here is rendered ;; like "(42% coverage)" and denotes the fraction of packages ;; covered by the given updater. (format #t (G_ " - ~a: ~a (~2,1f% coverage)~%") (upstream-updater-name updater) (G_ (upstream-updater-description updater)) - (* 100. (/ matches total))) - (+ covered matches))) - 0 + (* 100. (/ (length matches) total))) + (lset-difference eq? uncovered matches))) + packages (force %updaters))) (newline) (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%") - (* 100. (/ covered total)))) + (* 100. (/ (- total (length uncovered)) total)))) (exit 0)) (define (warn-no-updater package) @@ -278,7 +278,12 @@ the latest known version of ~a (~a)~%") (define (all-packages) "Return the list of all the distro's packages." - (fold-packages cons '() + (fold-packages (lambda (package result) + ;; Ignore deprecated packages. + (if (package-superseded package) + result + (cons package result))) + '() #:select? (const #t))) ;include hidden packages (define (list-dependents packages) 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/size.scm b/guix/scripts/size.scm index 344be40883..25218a2945 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -297,7 +297,7 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (G_ "missing store item argument\n"))) ((files ..1) (leave-on-EPIPE - ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; Turn off grafts because (1) substitute servers do not serve grafted ;; packages, and (2) they do not make any difference on the ;; resulting size. (parameterize ((%graft? #f)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index eb82224016..d6dc9b6448 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1052,7 +1052,7 @@ found." (#f ;; This can only happen when this script is not invoked by the ;; daemon. - '("http://hydra.gnu.org")))) + '("http://ci.guix.info")))) (define substitute-urls ;; List of substitute URLs. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f9af38b7c5..8eb32c62bc 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -175,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")) @@ -235,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)))))) ;;; @@ -486,9 +497,10 @@ STORE is an open connection to the store." (old-entries (map boot-parameters->menu-entry old-params))) (run-with-store store (mlet* %store-monad - ((bootcfg ((bootloader-configuration-file-generator bootloader) - bootloader-config entries - #:old-entries old-entries)) + ((bootcfg (lower-object + ((bootloader-configuration-file-generator bootloader) + bootloader-config entries + #:old-entries old-entries))) (bootcfg-file -> (bootloader-configuration-file bootloader)) (target -> "/") (drvs -> (list bootcfg))) @@ -783,19 +795,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? @@ -823,6 +834,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)) @@ -842,39 +872,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)) @@ -883,7 +890,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) @@ -892,7 +899,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 "/")))) @@ -904,7 +911,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. @@ -1161,7 +1168,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 |