nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

pack: Squashfs build expression refers to (guix store database) & co. 

Fixes a regression introduced in
c45477d2a1.
Reported by Christopher Baines <mail@cbaines.net>.

* 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.
This commit is contained in:
Ludovic Courtès 2018-06-25 21:49:12 +02:00
parent 887fe1fbde
commit 66e9944e07
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 83 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
guix/scripts/pack.scm
View File

@ -88,6 +88,19 @@ found."
%compressors) %compressors)
(leave (G_ "~a: compressor not found~%") name))) (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 (define* (self-contained-tarball name profile
#:key target #:key target
deduplicate? deduplicate?
@ -102,13 +115,6 @@ with a properly initialized store database.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." added to the pack."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
(define libgcrypt (define libgcrypt
(module-ref (resolve-interface '(gnu packages gnupg)) (module-ref (resolve-interface '(gnu packages gnupg))
'libgcrypt)) 'libgcrypt))
@ -128,9 +134,7 @@ added to the pack."
(guix build store-copy) (guix build store-copy)
(gnu build install)) (gnu build install))
#:select? not-config?)) #:select? not-config?))
(with-extensions (cons guile-sqlite3 (with-extensions guile-sqlite3&co
(package-transitive-propagated-inputs
guile-sqlite3))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
((guix build union) #:select (relative-file-name)) ((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 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." 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 (define build
(with-imported-modules '((guix build utils) (with-imported-modules `(((guix config)
(guix build store-copy) => ,(make-config.scm
(gnu build install)) #:libgcrypt libgcrypt))
#~(begin ,@(source-module-closure
(use-modules (guix build utils) '((guix build utils)
(gnu build install) (guix build store-copy)
(guix build store-copy) (gnu build install))
(srfi srfi-1) #:select? not-config?))
(srfi srfi-26) (with-extensions guile-sqlite3&co
(ice-9 match)) #~(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")) (setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when ;; 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 ;; we reparent the root file system. Read on for why that's
;; necessary. ;; necessary.
(with-output-to-file ".empty" (lambda () (display ""))) (with-output-to-file ".empty" (lambda () (display "")))
;; Create the squashfs image in several steps. ;; Create the squashfs image in several steps.
;; Add all store items. Unfortunately mksquashfs throws away all ;; Add all store items. Unfortunately mksquashfs throws away all
;; ancestor directories and only keeps the basename. We fix this ;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs. ;; in the following invocations of mksquashfs.
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(,@(map store-info-item `(,@(map store-info-item
(call-with-input-file "profile" (call-with-input-file "profile"
read-reference-graph)) read-reference-graph))
,#$output ,#$output
;; Do not perform duplicate checking because we ;; Do not perform duplicate checking because we
;; don't have any dupes. ;; don't have any dupes.
"-no-duplicates" "-no-duplicates"
"-comp" "-comp"
,#+(compressor-name compressor))) ,#+(compressor-name compressor)))
;; Here we reparent the store items. For each sub-directory of ;; Here we reparent the store items. For each sub-directory of
;; the store prefix we need one invocation of "mksquashfs". ;; the store prefix we need one invocation of "mksquashfs".
(for-each (lambda (dir) (for-each (lambda (dir)
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(".empty" `(".empty"
,#$output ,#$output
"-root-becomes" ,dir))) "-root-becomes" ,dir)))
(reverse (string-tokenize (%store-directory) (reverse (string-tokenize (%store-directory)
(char-set-complement (char-set #\/))))) (char-set-complement (char-set #\/)))))
;; Add symlinks and mount points. ;; Add symlinks and mount points.
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(".empty" `(".empty"
,#$output ,#$output
;; Create SYMLINKS via pseudo file definitions. ;; Create SYMLINKS via pseudo file definitions.
,@(append-map ,@(append-map
(match-lambda (match-lambda
((source '-> target) ((source '-> target)
(list "-p" (list "-p"
(string-join (string-join
;; name s mode uid gid symlink ;; name s mode uid gid symlink
(list source (list source
"s" "777" "0" "0" "s" "777" "0" "0"
(string-append #$profile "/" target)))))) (string-append #$profile "/" target))))))
'#$symlinks) '#$symlinks)
;; Create empty mount points. ;; Create empty mount points.
"-p" "/proc d 555 0 0" "-p" "/proc d 555 0 0"
"-p" "/sys d 555 0 0" "-p" "/sys d 555 0 0"
"-p" "/dev d 555 0 0"))))) "-p" "/dev d 555 0 0"))))))
(gexp->derivation (string-append name (gexp->derivation (string-append name
(compressor-extension compressor) (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 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 must a be a GNU triplet and it is used to derive the architecture metadata in
the image." 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 defmod 'define-module) ;trick Geiser
(define config (define config