* [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps @ 2018-05-28 21:56 Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès 2018-06-01 7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic 0 siblings, 2 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:56 UTC (permalink / raw) To: 31633 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 ^ permalink raw reply [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions'. 2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès ` (5 more replies) 2018-06-01 7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic 1 sibling, 6 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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))))))))) + \f (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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker). 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès ` (4 subsequent siblings) 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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@elephly.net> -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Chris Marusich <cmmarusich@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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions'. 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès ` (3 subsequent siblings) 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Marius Bakke <mbakke@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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png'. 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès ` (2 subsequent siblings) 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions'. 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès ` (2 preceding siblings ...) 2018-05-28 21:59 ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Andy Wingo <wingo@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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 6/7] profiles: Use 'with-extensions'. 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès ` (3 preceding siblings ...) 2018-05-28 21:59 ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 7/7] vm: Use 'with-extensions'. 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès ` (4 preceding siblings ...) 2018-05-28 21:59 ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès @ 2018-05-28 21:59 ` Ludovic Courtès 5 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw) To: 31633 * 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 ^ permalink raw reply related [flat|nested] 10+ messages in thread
* [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps 2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès @ 2018-06-01 7:37 ` Danny Milosavljevic 2018-06-01 13:42 ` bug#31633: " Ludovic Courtès 1 sibling, 1 reply; 10+ messages in thread From: Danny Milosavljevic @ 2018-06-01 7:37 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 31633 [-- Attachment #1: Type: text/plain, Size: 45 bytes --] Hi Ludo, good idea. This series LGTM! [-- Attachment #2: OpenPGP digital signature --] [-- Type: application/pgp-signature, Size: 488 bytes --] ^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#31633: [PATCH 0/7] Add 'with-extensions' for gexps 2018-06-01 7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic @ 2018-06-01 13:42 ` Ludovic Courtès 0 siblings, 0 replies; 10+ messages in thread From: Ludovic Courtès @ 2018-06-01 13:42 UTC (permalink / raw) To: Danny Milosavljevic; +Cc: 31633-done Hello, Danny Milosavljevic <dannym@scratchpost.org> skribis: > good idea. > > This series LGTM! Thanks, I’ve pushed it now! Ludo’. ^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2018-06-01 13:43 UTC | newest] Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès 2018-05-28 21:59 ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès 2018-06-01 7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic 2018-06-01 13:42 ` bug#31633: " Ludovic Courtès
Code repositories for project(s) associated with this public inbox https://git.savannah.gnu.org/cgit/guix.git This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).