Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Mon, 28 May 2018 21:57:01 UTC
Severity: normal
Tags: patch
Done: ludo <at> gnu.org (Ludovic Courtès)
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 31633 in the body.
You can then email your comments to 31633 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 21:57:02 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>:guix-patches <at> gnu.org.
(Mon, 28 May 2018 21:57:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 0/7] Add 'with-extensions' for gexps Date: Mon, 28 May 2018 23:56:29 +0200
Hello Guix! These patches add a ‘with-extensions’ form for gexps and then use it. ‘with-extensions’ is akin to ‘with-imported-modules’, except that it lists “full-blown” Guile packages where modules are available under /share/guile/site/2.2 etc. This fixes a longstanding issue where using extensions in gexps would be inconvenient to say the least. Extensions can be thought of as a generalization of “imported modules” in that the latter could be implemented in terms of the former. Perhaps we should do that eventually, though that means that ‘compiled-modules’ and ‘imported-modules’ will have to put files in /share/guile and /lib/guile like “real” packages do. Feedback welcome! Ludo’. Ludovic Courtès (7): gexp: Add 'with-extensions'. pack: Use 'with-extensions' when referring to (guix docker). tests: ssh: Use 'with-extensions'. bootloader: grub: Simplify 'svg->png'. bootloader: grub: Use 'with-extensions'. profiles: Use 'with-extensions'. vm: Use 'with-extensions'. .dir-locals.el | 1 + doc/guix.texi | 33 +++++ gnu/bootloader/grub.scm | 19 +-- gnu/build/svg.scm | 11 +- gnu/system/vm.scm | 93 +++++++------- gnu/tests/ssh.scm | 262 ++++++++++++++++++++-------------------- guix/docker.scm | 6 +- guix/gexp.scm | 168 +++++++++++++++++++------- guix/man-db.scm | 6 +- guix/profiles.scm | 60 +++++---- guix/scripts/pack.scm | 37 +++--- tests/gexp.scm | 86 +++++++++++++ 12 files changed, 477 insertions(+), 305 deletions(-) -- 2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:02 GMT) Full text and rfc822 format available.Message #8 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker). Date: Mon, 28 May 2018 23:59:25 +0200
* guix/docker.scm: Use module (json) the normal way.
* guix/scripts/pack.scm (docker-image)[build]: Wrap in
'with-extensions'.
---
guix/docker.scm | 6 ++----
guix/scripts/pack.scm | 37 +++++++++++++++++--------------------
2 files changed, 19 insertions(+), 24 deletions(-)
diff --git a/guix/docker.scm b/guix/docker.scm
index a75534c33..b86990159 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado <at> elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich <at> gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
delete-file-recursively
with-directory-excursion
invoke))
+ #:use-module (json) ;guile-json
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module ((texinfo string-utils)
@@ -34,9 +35,6 @@
#:use-module (ice-9 match)
#:export (build-docker-image))
-;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
-(module-use! (current-module) (resolve-interface '(json)))
-
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
(define docker-id
(compose bytevector->base16-string sha256 string->utf8))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1e84459e7..f5e247ed7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -256,28 +256,25 @@ the image."
guile-json))
(define build
- (with-imported-modules `(,@(source-module-closure '((guix docker))
- #:select? not-config?)
- (guix build store-copy)
- ((guix config) => ,config))
- #~(begin
- ;; Guile-JSON is required by (guix docker).
- (add-to-load-path
- (string-append #+json "/share/guile/site/"
- (effective-version)))
+ ;; Guile-JSON is required by (guix docker).
+ (with-extensions (list json)
+ (with-imported-modules `(,@(source-module-closure '((guix docker))
+ #:select? not-config?)
+ (guix build store-copy)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
- (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+ (setenv "PATH" (string-append #$tar "/bin"))
- (setenv "PATH" (string-append #$tar "/bin"))
-
- (build-docker-image #$output
- (call-with-input-file "profile"
- read-reference-graph)
- #$profile
- #:system (or #$target (utsname:machine (uname)))
- #:symlinks '#$symlinks
- #:compressor '#$(compressor-command compressor)
- #:creation-time (make-time time-utc 0 1)))))
+ (build-docker-image #$output
+ (call-with-input-file "profile"
+ read-reference-graph)
+ #$profile
+ #:system (or #$target (utsname:machine (uname)))
+ #:symlinks '#$symlinks
+ #:compressor '#$(compressor-command compressor)
+ #:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:03 GMT) Full text and rfc822 format available.Message #11 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 4/7] bootloader: grub: Simplify 'svg->png'. Date: Mon, 28 May 2018 23:59:27 +0200
* gnu/bootloader/grub.scm (svg->png): Remove now unneeded #:guile-for-build argument. --- gnu/bootloader/grub.scm | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index eca6d97b1..e90a6a11e 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -121,25 +121,21 @@ otherwise." (define* (svg->png svg #:key width height) "Build a PNG of HEIGHT x WIDTH from SVG." - ;; Note: Guile-RSVG & co. are now built for Guile 2.2, so we use 2.2 here. - ;; TODO: Remove #:guile-for-build when 2.2 has become the default. - (mlet %store-monad ((guile (package->derivation guile-2.2 #:graft? #f))) - (gexp->derivation "grub-image.png" - (with-imported-modules '((gnu build svg)) - #~(begin - ;; We need these two libraries. - (add-to-load-path (string-append #+guile-rsvg - "/share/guile/site/" - (effective-version))) - (add-to-load-path (string-append #+guile-cairo - "/share/guile/site/" - (effective-version))) + (gexp->derivation "grub-image.png" + (with-imported-modules '((gnu build svg)) + #~(begin + ;; We need these two libraries. + (add-to-load-path (string-append #+guile-rsvg + "/share/guile/site/" + (effective-version))) + (add-to-load-path (string-append #+guile-cairo + "/share/guile/site/" + (effective-version))) - (use-modules (gnu build svg)) - (svg->png #+svg #$output - #:width #$width - #:height #$height))) - #:guile-for-build guile))) + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height))))) (define* (grub-background-image config #:key (width 1024) (height 768)) "Return the GRUB background image defined in CONFIG with a ratio of -- 2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:04 GMT) Full text and rfc822 format available.Message #14 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 5/7] bootloader: grub: Use 'with-extensions'. Date: Mon, 28 May 2018 23:59:28 +0200
* gnu/bootloader/grub.scm (svg->png): Use 'with-extensions'. Remove
'add-to-load-path' calls.
* gnu/build/svg.scm: Use (rsvg) and (cairo) the normal way. Remove
'module-autoload!' calls.
---
gnu/bootloader/grub.scm | 19 ++++++-------------
gnu/build/svg.scm | 11 +++--------
2 files changed, 9 insertions(+), 21 deletions(-)
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index e90a6a11e..a131f3b50 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -123,19 +123,12 @@ otherwise."
"Build a PNG of HEIGHT x WIDTH from SVG."
(gexp->derivation "grub-image.png"
(with-imported-modules '((gnu build svg))
- #~(begin
- ;; We need these two libraries.
- (add-to-load-path (string-append #+guile-rsvg
- "/share/guile/site/"
- (effective-version)))
- (add-to-load-path (string-append #+guile-cairo
- "/share/guile/site/"
- (effective-version)))
-
- (use-modules (gnu build svg))
- (svg->png #+svg #$output
- #:width #$width
- #:height #$height)))))
+ (with-extensions (list guile-rsvg guile-cairo)
+ #~(begin
+ (use-modules (gnu build svg))
+ (svg->png #+svg #$output
+ #:width #$width
+ #:height #$height))))))
(define* (grub-background-image config #:key (width 1024) (height 768))
"Return the GRUB background image defined in CONFIG with a ratio of
diff --git a/gnu/build/svg.scm b/gnu/build/svg.scm
index b5474ec4a..6f1f4b368 100644
--- a/gnu/build/svg.scm
+++ b/gnu/build/svg.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo <at> igalia.com>
;;;
;;; This file is part of GNU Guix.
@@ -18,16 +18,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build svg)
+ #:use-module (rsvg)
+ #:use-module (cairo)
#:use-module (srfi srfi-11)
#:export (svg->png))
-;; We need Guile-RSVG and Guile-Cairo. Load them lazily, at run time, to
-;; allow compilation to proceed. See also <http://bugs.gnu.org/12202>.
-(module-autoload! (current-module)
- '(rsvg) '(rsvg-handle-new-from-file))
-(module-autoload! (current-module)
- '(cairo) '(cairo-image-surface-create))
-
(define* (downscaled-surface surface
#:key
source-width source-height
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:04 GMT) Full text and rfc822 format available.Message #17 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 3/7] tests: ssh: Use 'with-extensions'. Date: Mon, 28 May 2018 23:59:26 +0200
* gnu/tests/ssh.scm (run-ssh-test)[test]: Wrap body in
'with-extensions'. Remove %load-path manipulation code.
---
gnu/tests/ssh.scm | 262 ++++++++++++++++++++++------------------------
1 file changed, 128 insertions(+), 134 deletions(-)
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 6abc6c250..9247a43e6 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement <at> lassieur.org>
;;; Copyright © 2017 Marius Bakke <mbakke <at> fastmail.com>
;;;
@@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test."
(define test
(with-imported-modules '((gnu build marionette))
- #~(begin
- (eval-when (expand load eval)
- ;; Prepare to use Guile-SSH.
- (set! %load-path
- (cons (string-append #+guile-ssh "/share/guile/site/"
- (effective-version))
- %load-path)))
+ (with-extensions (list guile-ssh)
+ #~(begin
+ (use-modules (gnu build marionette)
+ (srfi srfi-26)
+ (srfi srfi-64)
+ (ice-9 match)
+ (ssh session)
+ (ssh auth)
+ (ssh channel)
+ (ssh sftp))
- (use-modules (gnu build marionette)
- (srfi srfi-26)
- (srfi srfi-64)
- (ice-9 match)
- (ssh session)
- (ssh auth)
- (ssh channel)
- (ssh sftp))
+ (define marionette
+ ;; Enable TCP forwarding of the guest's port 22.
+ (make-marionette (list #$vm)))
- (define marionette
- ;; Enable TCP forwarding of the guest's port 22.
- (make-marionette (list #$vm)))
+ (define (make-session-for-test)
+ "Make a session with predefined parameters for a test."
+ (make-session #:user "root"
+ #:port 2222
+ #:host "localhost"
+ #:log-verbosity 'protocol))
- (define (make-session-for-test)
- "Make a session with predefined parameters for a test."
- (make-session #:user "root"
- #:port 2222
- #:host "localhost"
- #:log-verbosity 'protocol))
-
- (define (call-with-connected-session proc)
- "Call the one-argument procedure PROC with a freshly created and
+ (define (call-with-connected-session proc)
+ "Call the one-argument procedure PROC with a freshly created and
connected SSH session object, return the result of the procedure call. The
session is disconnected when the PROC is finished."
- (let ((session (make-session-for-test)))
- (dynamic-wind
- (lambda ()
- (let ((result (connect! session)))
- (unless (equal? result 'ok)
- (error "Could not connect to a server"
- session result))))
- (lambda () (proc session))
- (lambda () (disconnect! session)))))
+ (let ((session (make-session-for-test)))
+ (dynamic-wind
+ (lambda ()
+ (let ((result (connect! session)))
+ (unless (equal? result 'ok)
+ (error "Could not connect to a server"
+ session result))))
+ (lambda () (proc session))
+ (lambda () (disconnect! session)))))
- (define (call-with-connected-session/auth proc)
- "Make an authenticated session. We should be able to connect as
+ (define (call-with-connected-session/auth proc)
+ "Make an authenticated session. We should be able to connect as
root with an empty password."
- (call-with-connected-session
- (lambda (session)
- ;; Try the simple authentication methods. Dropbear requires
- ;; 'none' when there are no passwords, whereas OpenSSH accepts
- ;; 'password' with an empty password.
- (let loop ((methods (list (cut userauth-password! <> "")
- (cut userauth-none! <>))))
- (match methods
- (()
- (error "all the authentication methods failed"))
- ((auth rest ...)
- (match (pk 'auth (auth session))
- ('success
- (proc session))
- ('denied
- (loop rest)))))))))
+ (call-with-connected-session
+ (lambda (session)
+ ;; Try the simple authentication methods. Dropbear requires
+ ;; 'none' when there are no passwords, whereas OpenSSH accepts
+ ;; 'password' with an empty password.
+ (let loop ((methods (list (cut userauth-password! <> "")
+ (cut userauth-none! <>))))
+ (match methods
+ (()
+ (error "all the authentication methods failed"))
+ ((auth rest ...)
+ (match (pk 'auth (auth session))
+ ('success
+ (proc session))
+ ('denied
+ (loop rest)))))))))
- (mkdir #$output)
- (chdir #$output)
+ (mkdir #$output)
+ (chdir #$output)
- (test-begin "ssh-daemon")
+ (test-begin "ssh-daemon")
- ;; Wait for sshd to be up and running.
- (test-eq "service running"
- 'running!
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'ssh-daemon)
- 'running!)
- marionette))
+ ;; Wait for sshd to be up and running.
+ (test-eq "service running"
+ 'running!
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd))
+ (start-service 'ssh-daemon)
+ 'running!)
+ marionette))
- ;; Check sshd's PID file.
- (test-equal "sshd PID"
- (wait-for-file #$pid-file marionette)
- (marionette-eval
- '(begin
- (use-modules (gnu services herd)
- (srfi srfi-1))
+ ;; Check sshd's PID file.
+ (test-equal "sshd PID"
+ (wait-for-file #$pid-file marionette)
+ (marionette-eval
+ '(begin
+ (use-modules (gnu services herd)
+ (srfi srfi-1))
- (live-service-running
- (find (lambda (live)
- (memq 'ssh-daemon
- (live-service-provision live)))
- (current-services))))
- marionette))
+ (live-service-running
+ (find (lambda (live)
+ (memq 'ssh-daemon
+ (live-service-provision live)))
+ (current-services))))
+ marionette))
- ;; Connect to the guest over SSH. Make sure we can run a shell
- ;; command there.
- (test-equal "shell command"
- 'hello
- (call-with-connected-session/auth
- (lambda (session)
- ;; FIXME: 'get-server-public-key' segfaults.
- ;; (get-server-public-key session)
- (let ((channel (make-channel session)))
- (channel-open-session channel)
- (channel-request-exec channel "echo hello > /root/witness")
- (and (zero? (channel-get-exit-status channel))
- (wait-for-file "/root/witness" marionette))))))
+ ;; Connect to the guest over SSH. Make sure we can run a shell
+ ;; command there.
+ (test-equal "shell command"
+ 'hello
+ (call-with-connected-session/auth
+ (lambda (session)
+ ;; FIXME: 'get-server-public-key' segfaults.
+ ;; (get-server-public-key session)
+ (let ((channel (make-channel session)))
+ (channel-open-session channel)
+ (channel-request-exec channel "echo hello > /root/witness")
+ (and (zero? (channel-get-exit-status channel))
+ (wait-for-file "/root/witness" marionette))))))
- ;; Connect to the guest over SFTP. Make sure we can write and
- ;; read a file there.
- (unless #$sftp?
- (test-skip 1))
- (test-equal "SFTP file writing and reading"
- 'hello
- (call-with-connected-session/auth
- (lambda (session)
- (let ((sftp-session (make-sftp-session session))
- (witness "/root/sftp-witness"))
- (call-with-remote-output-file sftp-session witness
- (cut display "hello" <>))
- (call-with-remote-input-file sftp-session witness
- read)))))
+ ;; Connect to the guest over SFTP. Make sure we can write and
+ ;; read a file there.
+ (unless #$sftp?
+ (test-skip 1))
+ (test-equal "SFTP file writing and reading"
+ 'hello
+ (call-with-connected-session/auth
+ (lambda (session)
+ (let ((sftp-session (make-sftp-session session))
+ (witness "/root/sftp-witness"))
+ (call-with-remote-output-file sftp-session witness
+ (cut display "hello" <>))
+ (call-with-remote-input-file sftp-session witness
+ read)))))
- ;; Connect to the guest over SSH. Make sure we can run commands
- ;; from the system profile.
- (test-equal "run executables from system profile"
- #t
- (call-with-connected-session/auth
- (lambda (session)
- (let ((channel (make-channel session)))
- (channel-open-session channel)
- (channel-request-exec
- channel
- (string-append
- "mkdir -p /root/.guix-profile/bin && "
- "touch /root/.guix-profile/bin/path-witness && "
- "chmod 755 /root/.guix-profile/bin/path-witness"))
- (zero? (channel-get-exit-status channel))))))
+ ;; Connect to the guest over SSH. Make sure we can run commands
+ ;; from the system profile.
+ (test-equal "run executables from system profile"
+ #t
+ (call-with-connected-session/auth
+ (lambda (session)
+ (let ((channel (make-channel session)))
+ (channel-open-session channel)
+ (channel-request-exec
+ channel
+ (string-append
+ "mkdir -p /root/.guix-profile/bin && "
+ "touch /root/.guix-profile/bin/path-witness && "
+ "chmod 755 /root/.guix-profile/bin/path-witness"))
+ (zero? (channel-get-exit-status channel))))))
- ;; Connect to the guest over SSH. Make sure we can run commands
- ;; from the user profile.
- (test-equal "run executable from user profile"
- #t
- (call-with-connected-session/auth
- (lambda (session)
- (let ((channel (make-channel session)))
- (channel-open-session channel)
- (channel-request-exec channel "path-witness")
- (zero? (channel-get-exit-status channel))))))
+ ;; Connect to the guest over SSH. Make sure we can run commands
+ ;; from the user profile.
+ (test-equal "run executable from user profile"
+ #t
+ (call-with-connected-session/auth
+ (lambda (session)
+ (let ((channel (make-channel session)))
+ (channel-open-session channel)
+ (channel-request-exec channel "path-witness")
+ (zero? (channel-get-exit-status channel))))))
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
(gexp->derivation name test))
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:05 GMT) Full text and rfc822 format available.Message #20 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 6/7] profiles: Use 'with-extensions'. Date: Mon, 28 May 2018 23:59:29 +0200
* guix/profiles.scm (manual-database)[build]: Use 'with-extensions'.
Remove 'add-to-load-path' call.
* guix/man-db.scm: Use (gdbm) the normal way; remove 'module-autoload!'
call.
---
guix/man-db.scm | 6 ++---
guix/profiles.scm | 60 +++++++++++++++++++++++------------------------
2 files changed, 31 insertions(+), 35 deletions(-)
diff --git a/guix/man-db.scm b/guix/man-db.scm
index 732aef108..4cef874f8 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +19,7 @@
(define-module (guix man-db)
#:use-module (guix zlib)
#:use-module ((guix build utils) #:select (find-files))
+ #:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@@ -44,9 +45,6 @@
;;;
;;; Code:
-;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
-(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT))
-
(define-record-type <mandb-entry>
(mandb-entry file-name name section synopsis kind)
mandb-entry?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fd7e5b922..9bddf8816 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1196,41 +1196,39 @@ the entries in MANIFEST."
(define build
(with-imported-modules modules
- #~(begin
- (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
- (effective-version)))
+ (with-extensions (list gdbm-ffi) ;for (guix man-db)
+ #~(begin
+ (use-modules (guix man-db)
+ (guix build utils)
+ (srfi srfi-1)
+ (srfi srfi-19))
- (use-modules (guix man-db)
- (guix build utils)
- (srfi srfi-1)
- (srfi srfi-19))
+ (define (compute-entries)
+ (append-map (lambda (directory)
+ (let ((man (string-append directory "/share/man")))
+ (if (directory-exists? man)
+ (mandb-entries man)
+ '())))
+ '#$(manifest-inputs manifest)))
- (define (compute-entries)
- (append-map (lambda (directory)
- (let ((man (string-append directory "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- '#$(manifest-inputs manifest)))
+ (define man-directory
+ (string-append #$output "/share/man"))
- (define man-directory
- (string-append #$output "/share/man"))
+ (mkdir-p man-directory)
- (mkdir-p man-directory)
-
- (format #t "Creating manual page database...~%")
- (force-output)
- (let* ((start (current-time))
- (entries (compute-entries))
- (_ (write-mandb-database (string-append man-directory
- "/index.db")
- entries))
- (duration (time-difference (current-time) start)))
- (format #t "~a entries processed in ~,1f s~%"
- (length entries)
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
- (force-output)))))
+ (format #t "Creating manual page database...~%")
+ (force-output)
+ (let* ((start (current-time))
+ (entries (compute-entries))
+ (_ (write-mandb-database (string-append man-directory
+ "/index.db")
+ entries))
+ (duration (time-difference (current-time) start)))
+ (format #t "~a entries processed in ~,1f s~%"
+ (length entries)
+ (+ (time-second duration)
+ (* (time-nanosecond duration) (expt 10 -9))))
+ (force-output))))))
(gexp->derivation "manual-database" build
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:06 GMT) Full text and rfc822 format available.Message #23 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/7] gexp: Add 'with-extensions'. Date: Mon, 28 May 2018 23:59:24 +0200
* guix/gexp.scm (<gexp>)[extensions]: New field.
(gexp-attribute): New procedure.
(gexp-modules): Write in terms of 'gexp-attribute'.
(gexp-extensions): New procedure.
(gexp->derivation): Add #:effective-version.
[extension-flags]: New procedure.
Honor extensions of EXP.
(current-imported-extensions): New syntax parameter.
(with-extensions): New macro.
(gexp): Honor CURRENT-IMPORTED-EXTENSIONS.
(compiled-modules): Add #:extensions and honor it.
(load-path-expression): Likewise.
(gexp->script, gexp->file): Honor extensions.
* tests/gexp.scm (%extension-package): New variable.
("gexp-extensions & ungexp")
("gexp-extensions & ungexp-splicing")
("gexp-extensions and literal Scheme object")
("gexp->derivation & with-extensions")
("program-file & with-extensions"): New tests.
* doc/guix.texi (G-Expressions): Document 'with-extensions'.
---
.dir-locals.el | 1 +
doc/guix.texi | 33 ++++++++++
guix/gexp.scm | 168 ++++++++++++++++++++++++++++++++++++-------------
tests/gexp.scm | 86 +++++++++++++++++++++++++
4 files changed, 246 insertions(+), 42 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index dac6cb145..2db751ca2 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -73,6 +73,7 @@
(eval . (put 'run-with-state 'scheme-indent-function 1))
(eval . (put 'wrap-program 'scheme-indent-function 1))
(eval . (put 'with-imported-modules 'scheme-indent-function 1))
+ (eval . (put 'with-extensions 'scheme-indent-function 1))
(eval . (put 'call-with-container 'scheme-indent-function 1))
(eval . (put 'container-excursion 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index 5eee40fc3..e55fecc31 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5041,6 +5041,23 @@ headers, which comes in handy in this case:
@dots{})))
@end example
+@cindex extensions, for gexps
+@findex with-extensions
+In the same vein, sometimes you want to import not just pure-Scheme
+modules, but also ``extensions'' such as Guile bindings to C libraries
+or other ``full-blown'' packages. Say you need the @code{guile-json}
+package available on the build side, here's how you would do it:
+
+@example
+(use-modules (gnu packages guile)) ;for 'guile-json'
+
+(with-extensions (list guile-json)
+ (gexp->derivation "something-with-json"
+ #~(begin
+ (use-modules (json))
+ @dots{})))
+@end example
+
The syntactic form to construct gexps is summarized below.
@deffn {Scheme Syntax} #~@var{exp}
@@ -5124,6 +5141,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in
procedures called from @var{body}@dots{}.
@end deffn
+@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{}
+Mark the gexps defined in @var{body}@dots{} as requiring
+@var{extensions} in their build and execution environment.
+@var{extensions} is typically a list of package objects such as those
+defined in the @code{(gnu packages guile)} module.
+
+Concretely, the packages listed in @var{extensions} are added to the
+load path while compiling imported modules in @var{body}@dots{}; they
+are also added to the load path of the gexp returned by
+@var{body}@dots{}.
+@end deffn
+
@deffn {Scheme Procedure} gexp? @var{obj}
Return @code{#t} if @var{obj} is a G-expression.
@end deffn
@@ -5138,6 +5167,7 @@ information about monads.)
[#:hash #f] [#:hash-algo #f] @
[#:recursive? #f] [#:env-vars '()] [#:modules '()] @
[#:module-path @var{%load-path}] @
+ [#:effective-version "2.2"] @
[#:references-graphs #f] [#:allowed-references #f] @
[#:disallowed-references #f] @
[#:leaked-env-vars #f] @
@@ -5158,6 +5188,9 @@ make @var{modules} available in the evaluation context of @var{exp};
the load path during the execution of @var{exp}---e.g., @code{((guix
build utils) (guix build gnu-build-system))}.
+@var{effective-version} determines the string to use when adding extensions of
+@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}.
+
@var{graft?} determines whether packages referred to by @var{exp} should be grafted when
applicable.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index dd5eb81bd..eda962d0a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -33,6 +33,7 @@
#:export (gexp
gexp?
with-imported-modules
+ with-extensions
gexp-input
gexp-input?
@@ -118,10 +119,11 @@
;; "G expressions".
(define-record-type <gexp>
- (make-gexp references modules proc)
+ (make-gexp references modules extensions proc)
gexp?
(references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names
+ (extensions gexp-self-extensions) ;list of lowerable things
(proc gexp-proc)) ;procedure
(define (write-gexp gexp port)
@@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
(set-record-type-printer! <gexp-output> write-gexp-output)
-(define (gexp-modules gexp)
- "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
-false, meaning that GEXP is a plain Scheme object, return the empty list."
+(define (gexp-attribute gexp self-attribute)
+ "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
(if (gexp? gexp)
(delete-duplicates
- (append (gexp-self-modules gexp)
+ (append (self-attribute gexp)
(append-map (match-lambda
(($ <gexp-input> (? gexp? exp))
- (gexp-modules exp))
+ (gexp-attribute exp self-attribute))
(($ <gexp-input> (lst ...))
(append-map (lambda (item)
(if (gexp? item)
- (gexp-modules item)
+ (gexp-attribute item
+ self-attribute)
'()))
lst))
(_
@@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
(gexp-references gexp))))
'())) ;plain Scheme data type
+(define (gexp-modules gexp)
+ "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
+false, meaning that GEXP is a plain Scheme object, return the empty list."
+ (gexp-attribute gexp gexp-self-modules))
+
+(define (gexp-extensions gexp)
+ "Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+ (gexp-attribute gexp gexp-self-extensions))
+
(define* (lower-inputs inputs
#:key system target)
"Turn any package from INPUTS into a derivation for SYSTEM; return the
@@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
(modules '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
+ (effective-version "2.2")
(graft? (%graft?))
references-graphs
allowed-references disallowed-references
@@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
compiled, and made available in the load path during the execution of
EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
+EFFECTIVE-VERSION determines the string to use when adding extensions of
+EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
+
GRAFT? determines whether packages referred to by EXP should be grafted when
applicable.
@@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda
- ;; TODO: Remove 'derivation?' special cases.
+ ;; TODO: Remove 'derivation?' special cases.
((file-name (? derivation? drv))
(cons file-name (derivation->output-path drv)))
((file-name (? derivation? drv) sub-drv)
@@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing)))
graphs))
- (mlet* %store-monad (;; The following binding forces '%current-system' and
+ (define (extension-flags extension)
+ `("-L" ,(string-append (derivation->output-path extension)
+ "/share/guile/site/" effective-version)
+ "-C" ,(string-append (derivation->output-path extension)
+ "/lib/guile/" effective-version "/site-ccache")))
+
+ (mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
@@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
#:target target))
(builder (text-file script-name
(object->string sexp)))
+ (extensions -> (gexp-extensions exp))
+ (exts (mapm %store-monad
+ (lambda (obj)
+ (lower-object obj system))
+ extensions))
(modules (if (pair? %modules)
(imported-modules %modules
#:system system
@@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
(compiled-modules %modules
#:system system
#:module-path module-path
+ #:extensions extensions
#:guile guile-for-build
#:deprecation-warnings
deprecation-warnings)
@@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
`("-L" ,(derivation->output-path modules)
"-C" ,(derivation->output-path compiled))
'())
+ ,@(append-map extension-flags exts)
,builder)
#:outputs outputs
#:env-vars env-vars
@@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs)
+ ,@(map list exts)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@@ -861,6 +893,17 @@ environment."
(identifier-syntax modules)))
body ...))
+(define-syntax-parameter current-imported-extensions
+ ;; Current list of extensions.
+ (identifier-syntax '()))
+
+(define-syntax-rule (with-extensions extensions body ...)
+ "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
+execution environment."
+ (syntax-parameterize ((current-imported-extensions
+ (identifier-syntax extensions)))
+ body ...))
+
(define-syntax gexp
(lambda (s)
(define (collect-escapes exp)
@@ -957,6 +1000,7 @@ environment."
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
+ current-imported-extensions
(lambda #,formals
#,sexp)))))))
@@ -1071,6 +1115,7 @@ last one is created from the given <scheme-file> object."
(system (%current-system))
(guile (%guile-for-build))
(module-path %load-path)
+ (extensions '())
(deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
@@ -1114,6 +1159,26 @@ they can refer to each other."
%auto-compilation-options))))
entries)))
+ ;; Add EXTENSIONS to the search path.
+ ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
+ (ungexp-splicing
+ (if (null? extensions)
+ '()
+ (gexp ((set! %load-path
+ (append (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ '((ungexp-native-splicing extensions)))
+ %load-path))
+ (set! %load-compiled-path
+ (append (map (lambda (extension)
+ (string-append extension "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ '((ungexp-native-splicing extensions)))
+ %load-compiled-path))))))
+
(set! %load-path (cons (ungexp modules) %load-path))
(mkdir (ungexp output))
(chdir (ungexp modules))
@@ -1146,20 +1211,34 @@ they can refer to each other."
(module-ref (resolve-interface '(gnu packages guile))
'guile-2.2))
-(define* (load-path-expression modules #:optional (path %load-path))
+(define* (load-path-expression modules #:optional (path %load-path)
+ #:key (extensions '()))
"Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names. MODULES
are searched for in PATH."
(mlet %store-monad ((modules (imported-modules modules
#:module-path path))
(compiled (compiled-modules modules
+ #:extensions extensions
#:module-path path)))
(return (gexp (eval-when (expand load eval)
(set! %load-path
- (cons (ungexp modules) %load-path))
+ (cons (ungexp modules)
+ (append (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ '((ungexp-native-splicing extensions)))
+ %load-path)))
(set! %load-compiled-path
(cons (ungexp compiled)
- %load-compiled-path)))))))
+ (append (map (lambda (extension)
+ (string-append extension
+ "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ '((ungexp-native-splicing extensions)))
+ %load-compiled-path))))))))
(define* (gexp->script name exp
#:key (guile (default-guile))
@@ -1168,7 +1247,9 @@ are searched for in PATH."
imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp)
- module-path)))
+ module-path
+ #:extensions
+ (gexp-extensions exp))))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
@@ -1197,35 +1278,38 @@ the resulting file.
When SET-LOAD-PATH? is true, emit code in the resulting file to set
'%load-path' and '%load-compiled-path' to honor EXP's imported modules.
Lookup EXP's modules in MODULE-PATH."
- (match (if set-load-path? (gexp-modules exp) '())
- (() ;zero modules
- (gexp->derivation name
- (gexp
- (call-with-output-file (ungexp output)
- (lambda (port)
- (for-each (lambda (exp)
- (write exp port))
- '(ungexp (if splice?
- exp
- (gexp ((ungexp exp)))))))))
- #:local-build? #t
- #:substitutable? #f))
- ((modules ...)
- (mlet %store-monad ((set-load-path (load-path-expression modules
- module-path)))
- (gexp->derivation name
- (gexp
- (call-with-output-file (ungexp output)
- (lambda (port)
- (write '(ungexp set-load-path) port)
- (for-each (lambda (exp)
- (write exp port))
- '(ungexp (if splice?
- exp
- (gexp ((ungexp exp)))))))))
- #:module-path module-path
- #:local-build? #t
- #:substitutable? #f)))))
+ (define modules (gexp-modules exp))
+ (define extensions (gexp-extensions exp))
+
+ (if (or (not set-load-path?)
+ (and (null? modules) (null? extensions)))
+ (gexp->derivation name
+ (gexp
+ (call-with-output-file (ungexp output)
+ (lambda (port)
+ (for-each (lambda (exp)
+ (write exp port))
+ '(ungexp (if splice?
+ exp
+ (gexp ((ungexp exp)))))))))
+ #:local-build? #t
+ #:substitutable? #f)
+ (mlet %store-monad ((set-load-path
+ (load-path-expression modules module-path
+ #:extensions extensions)))
+ (gexp->derivation name
+ (gexp
+ (call-with-output-file (ungexp output)
+ (lambda (port)
+ (write '(ungexp set-load-path) port)
+ (for-each (lambda (exp)
+ (write exp port))
+ '(ungexp (if splice?
+ exp
+ (gexp ((ungexp exp)))))))))
+ #:module-path module-path
+ #:local-build? #t
+ #:substitutable? #f))))
(define* (text-file* name #:rest text)
"Return as a monadic value a derivation that builds a text file containing
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 3c8b4624d..a560adfc5 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -23,6 +23,7 @@
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix build-system trivial)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory))
@@ -66,6 +67,27 @@
(run-with-store %store exp
#:guile-for-build (%guile-for-build))))
+(define %extension-package
+ ;; Example of a package to use when testing 'with-extensions'.
+ (dummy-package "extension"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:modules ((guix build utils))
+ #:builder
+ (begin
+ (use-modules (guix build utils))
+ (let* ((out (string-append (assoc-ref %outputs "out")
+ "/share/guile/site/"
+ (effective-version))))
+ (mkdir-p out)
+ (call-with-output-file (string-append out "/hg2g.scm")
+ (lambda (port)
+ (write '(define-module (hg2g)
+ #:export (the-answer))
+ port)
+ (write '(define the-answer 42) port)))))))))
+
(test-begin "gexp")
@@ -739,6 +761,54 @@
(built-derivations (list drv))
(return (= 42 (call-with-input-file out read))))))
+(test-equal "gexp-extensions & ungexp"
+ (list sed grep)
+ ((@@ (guix gexp) gexp-extensions)
+ #~(foo #$(with-extensions (list grep) #~+)
+ #+(with-extensions (list sed) #~-))))
+
+(test-equal "gexp-extensions & ungexp-splicing"
+ (list grep sed)
+ ((@@ (guix gexp) gexp-extensions)
+ #~(foo #$@(list (with-extensions (list grep) #~+)
+ (with-imported-modules '((foo))
+ (with-extensions (list sed) #~-))))))
+
+(test-equal "gexp-extensions and literal Scheme object"
+ '()
+ ((@@ (guix gexp) gexp-extensions) #t))
+
+(test-assertm "gexp->derivation & with-extensions"
+ ;; Create a fake Guile extension and make sure it is accessible both to the
+ ;; imported modules and to the derivation build script.
+ (mlet* %store-monad
+ ((extension -> %extension-package)
+ (module -> (scheme-file "x" #~( ;; splice!
+ (define-module (foo)
+ #:use-module (hg2g)
+ #:export (multiply))
+
+ (define (multiply x)
+ (* the-answer x)))
+ #:splice? #t))
+ (build -> (with-extensions (list extension)
+ (with-imported-modules `((guix build utils)
+ ((foo) => ,module))
+ #~(begin
+ (use-modules (guix build utils)
+ (hg2g) (foo))
+ (call-with-output-file #$output
+ (lambda (port)
+ (write (list the-answer (multiply 2))
+ port)))))))
+ (drv (gexp->derivation "thingie" build
+ ;; %BOOTSTRAP-GUILE is 2.0.
+ #:effective-version "2.0"))
+ (out -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (equal? '(42 84) (call-with-input-file out read))))))
+
(test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad
((one (text-file "one" (random-text)))
@@ -948,6 +1018,22 @@
(return (and (zero? (close-pipe pipe))
(string=? text str))))))))))
+(test-assertm "program-file & with-extensions"
+ (let* ((exp (with-extensions (list %extension-package)
+ (gexp (begin
+ (use-modules (hg2g))
+ (display the-answer)))))
+ (file (program-file "program" exp
+ #:guile %bootstrap-guile)))
+ (mlet* %store-monad ((drv (lower-object file))
+ (out -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((pipe (open-input-pipe out))
+ (str (get-string-all pipe)))
+ (return (and (zero? (close-pipe pipe))
+ (= 42 (string->number str)))))))))
+
(test-assertm "scheme-file"
(let* ((text (plain-file "foo" "Hello, world!"))
(scheme (scheme-file "bar" #~(list "foo" #$text))))
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Mon, 28 May 2018 22:00:06 GMT) Full text and rfc822 format available.Message #26 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 31633 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 7/7] vm: Use 'with-extensions'. Date: Mon, 28 May 2018 23:59:30 +0200
* gnu/system/vm.scm (system-docker-image)[build]: Use
'with-extensions'. Remove 'add-to-load-path' calls.
---
gnu/system/vm.scm | 93 +++++++++++++++++++++++------------------------
1 file changed, 46 insertions(+), 47 deletions(-)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4cffc71d7..66c6773c6 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -411,58 +411,57 @@ should set REGISTER-CLOSURES? to #f."
(eval-when (expand load eval)
(define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt"))))))
+
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz"))
(graph -> "system-graph"))
(define build
- (with-imported-modules `(,@(source-module-closure '((guix docker)
- (guix build utils)
- (gnu build vm))
- #:select? not-config?)
- (guix build store-copy)
- ((guix config) => ,config))
- #~(begin
- ;; Guile-JSON is required by (guix docker).
- (add-to-load-path
- (string-append #+guile-json "/share/guile/site/"
- (effective-version)))
- (use-modules (guix docker)
- (guix build utils)
- (gnu build vm)
- (srfi srfi-19)
- (guix build store-copy))
+ (with-extensions (list guile-json) ;for (guix docker)
+ (with-imported-modules `(,@(source-module-closure
+ '((guix docker)
+ (guix build utils)
+ (gnu build vm))
+ #:select? not-config?)
+ (guix build store-copy)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (guix docker)
+ (guix build utils)
+ (gnu build vm)
+ (srfi srfi-19)
+ (guix build store-copy))
- (let* ((inputs '#$(append (list tar)
- (if register-closures?
- (list guix)
- '())))
- ;; This initializer requires elevated privileges that are
- ;; not normally available in the build environment (e.g.,
- ;; it needs to create device nodes). In order to obtain
- ;; such privileges, we run it as root in a VM.
- (initialize (root-partition-initializer
- #:closures '(#$graph)
- #:register-closures? #$register-closures?
- #:system-directory #$os-drv
- ;; De-duplication would fail due to
- ;; cross-device link errors, so don't do it.
- #:deduplicate? #f))
- ;; Even as root in a VM, the initializer would fail due to
- ;; lack of privileges if we use a root-directory that is on
- ;; a file system that is shared with the host (e.g., /tmp).
- (root-directory "/guixsd-system-root"))
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (mkdir root-directory)
- (initialize root-directory)
- (build-docker-image
- (string-append "/xchg/" #$name) ;; The output file.
- (cons* root-directory
- (call-with-input-file (string-append "/xchg/" #$graph)
- read-reference-graph))
- #$os-drv
- #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
- #:creation-time (make-time time-utc 0 1)
- #:transformations `((,root-directory -> "")))))))
+ (let* ((inputs '#$(append (list tar)
+ (if register-closures?
+ (list guix)
+ '())))
+ ;; This initializer requires elevated privileges that are
+ ;; not normally available in the build environment (e.g.,
+ ;; it needs to create device nodes). In order to obtain
+ ;; such privileges, we run it as root in a VM.
+ (initialize (root-partition-initializer
+ #:closures '(#$graph)
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-drv
+ ;; De-duplication would fail due to
+ ;; cross-device link errors, so don't do it.
+ #:deduplicate? #f))
+ ;; Even as root in a VM, the initializer would fail due to
+ ;; lack of privileges if we use a root-directory that is on
+ ;; a file system that is shared with the host (e.g., /tmp).
+ (root-directory "/guixsd-system-root"))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (mkdir root-directory)
+ (initialize root-directory)
+ (build-docker-image
+ (string-append "/xchg/" #$name) ;; The output file.
+ (cons* root-directory
+ (call-with-input-file (string-append "/xchg/" #$graph)
+ read-reference-graph))
+ #$os-drv
+ #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+ #:creation-time (make-time time-utc 0 1)
+ #:transformations `((,root-directory -> ""))))))))
(expression->derivation-in-linux-vm
name
;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
--
2.17.0
guix-patches <at> gnu.org:bug#31633; Package guix-patches.
(Fri, 01 Jun 2018 07:38:02 GMT) Full text and rfc822 format available.Message #29 received at 31633 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 31633 <at> debbugs.gnu.org Subject: Re: [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Date: Fri, 1 Jun 2018 09:37:27 +0200
[Message part 1 (text/plain, inline)]
Hi Ludo, good idea. This series LGTM!
[Message part 2 (application/pgp-signature, inline)]
ludo <at> gnu.org (Ludovic Courtès):Ludovic Courtès <ludo <at> gnu.org>:Message #34 received at 31633-done <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Danny Milosavljevic <dannym <at> scratchpost.org> Cc: 31633-done <at> debbugs.gnu.org Subject: Re: [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Date: Fri, 01 Jun 2018 15:42:23 +0200
Hello, Danny Milosavljevic <dannym <at> scratchpost.org> skribis: > good idea. > > This series LGTM! Thanks, I’ve pushed it now! Ludo’.
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Sat, 30 Jun 2018 11:24:05 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.