From 945449b40b4343f1829dfd54aa85f8568711c890 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 21 Jun 2018 16:54:06 +0200 Subject: guix: Fix system reconfigure. This is a follow-up to 378daa8cb677121e1893f9173af1db060720d6e4. * guix/scripts/system.scm (switch-to-system): Lower the script. --- guix/scripts/system.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a3f01636e6..14aedceac1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -352,8 +353,8 @@ bring the system down." #:optional (profile %system-profile)) "Make a new generation of PROFILE pointing to the directory of OS, switch to it atomically, and then run OS's activation script." - (mlet* %store-monad ((drv (operating-system-derivation os)) - (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os)) + (script (lower-object (operating-system-activation-script os)))) (let* ((system (derivation->output-path drv)) (number (+ 1 (generation-number profile))) (generation (generation-file-name profile number))) -- cgit v1.2.3 From 5970ceddfaaa449b7224e11d4f6a5f2305408179 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 22 Jun 2018 22:44:12 +0100 Subject: pack: Fix guix pack -f docker. Without this change, running guix pack fails as (guix sets) is missing when compiling (guix build store-copy). * guix/scripts/pack.scm (docker-image): Move (guix build store-copy) to within the source-module-closure call. --- guix/scripts/pack.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ed876b2592..443d199be5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -364,9 +364,9 @@ the image." (define build ;; Guile-JSON is required by (guix docker). (with-extensions (list json) - (with-imported-modules `(,@(source-module-closure '((guix docker)) + (with-imported-modules `(,@(source-module-closure '((guix docker) + (guix build store-copy)) #:select? not-config?) - (guix build store-copy) ((guix config) => ,config)) #~(begin (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) -- cgit v1.2.3 From 66e9944e078cbb9e0d618377dd6df6e639640efa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 Jun 2018 21:49:12 +0200 Subject: pack: Squashfs build expression refers to (guix store database) & co. Fixes a regression introduced in c45477d2a1a651485feede20fe0f3d15aec48b39. Reported by Christopher Baines . * guix/scripts/pack.scm (not-config?, guile-sqlite3&co): New variables. (self-contained-tarball)[not-config?]: Remove. [build]: Use GUILE-SQLITE3&CO for 'with-extensions'. (squashfs-image)[libgcrypt]: New variable. [build]: Use 'source-module-closure', 'make-config.scm', and 'with-extensions'. (docker-image)[not-config?]: Remove. --- guix/scripts/pack.scm | 170 ++++++++++++++++++++++++++------------------------ 1 file changed, 89 insertions(+), 81 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 443d199be5..7f087a3a3c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -88,6 +88,19 @@ found." %compressors) (leave (G_ "~a: compressor not found~%") name))) +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + +(define guile-sqlite3&co + ;; Guile-SQLite3 and its propagated inputs. + (cons guile-sqlite3 + (package-transitive-propagated-inputs guile-sqlite3))) + (define* (self-contained-tarball name profile #:key target deduplicate? @@ -102,13 +115,6 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix _ ...) #t) - (('gnu _ ...) #t) - (_ #f))) - (define libgcrypt (module-ref (resolve-interface '(gnu packages gnupg)) 'libgcrypt)) @@ -128,9 +134,7 @@ added to the pack." (guix build store-copy) (gnu build install)) #:select? not-config?)) - (with-extensions (cons guile-sqlite3 - (package-transitive-propagated-inputs - guile-sqlite3)) + (with-extensions guile-sqlite3&co #~(begin (use-modules (guix build utils) ((guix build union) #:select (relative-file-name)) @@ -248,71 +252,83 @@ 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 build - (with-imported-modules '((guix build utils) - (guix build store-copy) - (gnu build install)) - #~(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 `(((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)) - (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"))))) + (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")))))) (gexp->derivation (string-append name (compressor-extension compressor) @@ -332,14 +348,6 @@ 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." - ;; FIXME: Honor LOCALSTATEDIR?. - (define not-config? - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - (define defmod 'define-module) ;trick Geiser (define config -- cgit v1.2.3