mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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
parent
887fe1fbde
commit
66e9944e07
1 changed files with 83 additions and 75 deletions
|
|
@ -88,6 +88,19 @@ (define (lookup-compressor name)
|
|||
%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 @@ (define* (self-contained-tarball name profile
|
|||
|
||||
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 @@ (define build
|
|||
(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 @@ (define* (squashfs-image name profile
|
|||
|
||||
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"))
|
||||
(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 "")))
|
||||
;; 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
|
||||
;; 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)))
|
||||
;; 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 #\/)))))
|
||||
;; 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)
|
||||
;; 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")))))
|
||||
;; 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 @@ (define* (docker-image name profile
|
|||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue