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

vm: Use 'with-extensions'. 

* gnu/system/vm.scm (system-docker-image)[build]: Use
'with-extensions'.  Remove 'add-to-load-path' calls.
master
Ludovic Courtès 2018-05-28 23:42:28 +02:00
parent 331ac4cc23
commit 9f160a0d3c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 46 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
gnu/system/vm.scm
View File

@ -410,58 +410,57 @@ should set REGISTER-CLOSURES? to #f."
(eval-when (expand load eval) (eval-when (expand load eval)
(define %libgcrypt (define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt")))))) #+(file-append libgcrypt "/lib/libgcrypt"))))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz")) (name -> (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph -> "system-graph"))
(define build (define build
(with-imported-modules `(,@(source-module-closure '((guix docker) (with-extensions (list guile-json) ;for (guix docker)
(guix build utils) (with-imported-modules `(,@(source-module-closure
(gnu build vm)) '((guix docker)
#:select? not-config?) (guix build utils)
(guix build store-copy) (gnu build vm))
((guix config) => ,config)) #:select? not-config?)
#~(begin (guix build store-copy)
;; Guile-JSON is required by (guix docker). ((guix config) => ,config))
(add-to-load-path #~(begin
(string-append #+guile-json "/share/guile/site/" (use-modules (guix docker)
(effective-version))) (guix build utils)
(use-modules (guix docker) (gnu build vm)
(guix build utils) (srfi srfi-19)
(gnu build vm) (guix build store-copy))
(srfi srfi-19)
(guix build store-copy))
(let* ((inputs '#$(append (list tar) (let* ((inputs '#$(append (list tar)
(if register-closures? (if register-closures?
(list guix) (list guix)
'()))) '())))
;; This initializer requires elevated privileges that are ;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g., ;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain ;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM. ;; such privileges, we run it as root in a VM.
(initialize (root-partition-initializer (initialize (root-partition-initializer
#:closures '(#$graph) #:closures '(#$graph)
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:system-directory #$os-drv #:system-directory #$os-drv
;; De-duplication would fail due to ;; De-duplication would fail due to
;; cross-device link errors, so don't do it. ;; cross-device link errors, so don't do it.
#:deduplicate? #f)) #:deduplicate? #f))
;; Even as root in a VM, the initializer would fail due to ;; Even as root in a VM, the initializer would fail due to
;; lack of privileges if we use a root-directory that is on ;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp). ;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root")) (root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(mkdir root-directory) (mkdir root-directory)
(initialize root-directory) (initialize root-directory)
(build-docker-image (build-docker-image
(string-append "/xchg/" #$name) ;; The output file. (string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory (cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph) (call-with-input-file (string-append "/xchg/" #$graph)
read-reference-graph)) read-reference-graph))
#$os-drv #$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1) #:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))))))) #:transformations `((,root-directory -> ""))))))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp