From b908fcd8c02c26b1e6cdc636b63306a01a21b994 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 17:45:17 +0200 Subject: pack: '-R' honors the requested output. Fixes . Reported by Jesse Gibbons . * guix/scripts/pack.scm (wrapped-package): Add 'output*' parameter. [build]: Define 'input' and 'target'; use them instead of #$package and #$output, respectively. (wrapped-manifest-entry): New procedure. (map-manifest-entries): Call PROC directly. (guix-pack): Pass WRAPPED-MANIFEST-ENTRY to 'map-manifest-entries'. --- guix/scripts/pack.scm | 49 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 16 deletions(-) (limited to 'guix/scripts/pack.scm') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index fdb98983bf..794d2ee390 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -611,8 +611,13 @@ please email '~a'~%") ;;; (define* (wrapped-package package - #:optional (compiler (c-compiler)) + #:optional + (output* "out") + (compiler (c-compiler)) #:key proot?) + "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are +relocatable. When PROOT? is true, include PRoot in the result and use it as a +last resort for relocation." (define runner (local-file (search-auxiliary-file "run-in-namespace.c"))) @@ -629,6 +634,14 @@ please email '~a'~%") (ice-9 ftw) (ice-9 match)) + (define input + ;; The OUTPUT* output of PACKAGE. + (ungexp package output*)) + + (define target + ;; The output we are producing. + (ungexp output output*)) + (define (strip-store-prefix file) ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return ;; "/bin/foo". @@ -648,7 +661,7 @@ please email '~a'~%") (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append #$output "/" base)) + (result (string-append target "/" base)) (proot #$(and proot? #~(string-drop #$(file-append (proot) "/bin/proot") @@ -667,18 +680,18 @@ please email '~a'~%") ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. - (mkdir #$output) + (mkdir target) (for-each (lambda (file) (unless (member file '("." ".." "bin" "sbin" "libexec")) - (let ((file* (string-append #$package "/" file))) - (symlink (relative-file-name #$output file*) - (string-append #$output "/" file))))) - (scandir #$package)) + (let ((file* (string-append input "/" file))) + (symlink (relative-file-name target file*) + (string-append target "/" file))))) + (scandir input)) (for-each build-wrapper - (append (find-files #$(file-append package "/bin")) - (find-files #$(file-append package "/sbin")) - (find-files #$(file-append package "/libexec"))))))) + (append (find-files (string-append input "/bin")) + (find-files (string-append input "/sbin")) + (find-files (string-append input "/libexec"))))))) (computed-file (string-append (cond ((package? package) @@ -691,14 +704,18 @@ please email '~a'~%") "R") build)) +(define (wrapped-manifest-entry entry . args) + (manifest-entry + (inherit entry) + (item (apply wrapped-package + (manifest-entry-item entry) + (manifest-entry-output entry) + args)))) + (define (map-manifest-entries proc manifest) "Apply PROC to all the entries of MANIFEST and return a new manifest." (make-manifest - (map (lambda (entry) - (manifest-entry - (inherit entry) - (item (proc (manifest-entry-item entry))))) - (manifest-entries manifest)))) + (map proc (manifest-entries manifest)))) ;;; @@ -960,7 +977,7 @@ Create a bundle of PACKAGE.\n")) ;; 'glibc-bootstrap' lacks 'libc.a'. (if relocatable? (map-manifest-entries - (cut wrapped-package <> #:proot? proot?) + (cut wrapped-manifest-entry <> #:proot? proot?) manifest) manifest))) (pack-format (assoc-ref opts 'format)) -- cgit v1.2.3 From 2b7c89f4fcc5e1607e153939d54d32aeaf494ca9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:02:14 +0200 Subject: docker: Take a list of directives instead of a list of symlinks. * guix/docker.scm (symlink-source, topmost-component): Remove. (directive-file): New procedure. (build-docker-image): Remove #:symlinks and add #:extra-files. Make a sub-directory "extra" and call 'evaluate-populate-directive' for EXTRA-FILES in that directory. * guix/scripts/pack.scm (docker-image)[build](symlink->directives, directives): New procedures. Pass #:extra-files instead of #:symlinks to 'build-docker-image'. --- guix/docker.scm | 68 ++++++++++++++++++++++++--------------------------- guix/scripts/pack.scm | 20 +++++++++++++-- 2 files changed, 50 insertions(+), 38 deletions(-) (limited to 'guix/scripts/pack.scm') diff --git a/guix/docker.scm b/guix/docker.scm index c598a073f6..757bdeb458 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -28,11 +28,13 @@ invoke)) #:use-module (gnu build install) #:use-module (json) ;guile-json + #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) #:select (escape-special-chars)) #:use-module (rnrs bytevectors) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (build-docker-image)) @@ -99,21 +101,18 @@ '("--sort=name" "--mtime=@1" "--owner=root:0" "--group=root:0")) -(define symlink-source +(define directive-file + ;; Return the file or directory created by a 'evaluate-populate-directive' + ;; directive. (match-lambda ((source '-> target) - (string-trim source #\/)))) - -(define (topmost-component file) - "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", -return \"a\"." - (match (string-tokenize file (char-set-complement (char-set #\/))) - ((first rest ...) - first))) + (string-trim source #\/)) + (('directory name _ ...) + (string-trim name #\/)))) (define* (build-docker-image image paths prefix #:key - (symlinks '()) + (extra-files '()) (transformations '()) (system (utsname:machine (uname))) database @@ -133,8 +132,9 @@ entry point in the Docker image JSON structure. ENVIRONMENT must be a list of name/value pairs. It specifies the environment variables that must be defined in the resulting image. -SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be -created in the image, where each TARGET is relative to PREFIX. +EXTRA-FILES must be a list of directives for 'evaluate-populate-directive' +describing non-store files that must be created in the image. + TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to transform the PATHS. Any path in PATHS that begins with OLD will be rewritten in the Docker image so that it begins with NEW instead. If a path is a @@ -199,25 +199,27 @@ SRFI-19 time-utc object, as the creation time in metadata." (with-output-to-file "json" (lambda () (scm->json (image-description id time)))) - ;; Create SYMLINKS. - (for-each (match-lambda - ((source '-> target) - (let ((source (string-trim source #\/))) - (mkdir-p (dirname source)) - (symlink (string-append prefix "/" target) - source)))) - symlinks) + ;; Create a directory for the non-store files that need to go into the + ;; archive. + (mkdir "extra") + + (with-directory-excursion "extra" + ;; Create non-store files. + (for-each (cut evaluate-populate-directive <> "./") + extra-files) - (when database - ;; Initialize /var/guix, assuming PREFIX points to a profile. - (install-database-and-gc-roots "." database prefix)) + (when database + ;; Initialize /var/guix, assuming PREFIX points to a profile. + (install-database-and-gc-roots "." database prefix)) + + (apply invoke "tar" "-cf" "../layer.tar" + `(,@transformation-options + ,@%tar-determinism-options + ,@paths + ,@(scandir "." + (lambda (file) + (not (member file '("." "..")))))))) - (apply invoke "tar" "-cf" "layer.tar" - `(,@transformation-options - ,@%tar-determinism-options - ,@paths - ,@(if database '("var") '()) - ,@(map symlink-source symlinks))) ;; It is possible for "/" to show up in the archive, especially when ;; applying transformations. For example, the transformation ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform @@ -231,13 +233,7 @@ SRFI-19 time-utc object, as the creation time in metadata." (lambda () (system* "tar" "--delete" "/" "-f" "layer.tar"))) - (for-each delete-file-recursively - (map (compose topmost-component symlink-source) - symlinks)) - - ;; Delete /var/guix. - (when database - (delete-file-recursively "var"))) + (delete-file-recursively "extra")) (with-output-to-file "config.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 794d2ee390..a15530ad70 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -490,7 +490,8 @@ the image." #~(begin (use-modules (guix docker) (guix build store-copy) (guix profiles) (guix search-paths) - (srfi srfi-19) (ice-9 match)) + (srfi srfi-1) (srfi srfi-19) + (ice-9 match)) (define environment (map (match-lambda @@ -499,6 +500,21 @@ the image." value))) (profile-search-paths #$profile))) + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + `((directory ,parent) + (,source -> ,target)))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output @@ -513,7 +529,7 @@ the image." #$(and entry-point #~(list (string-append #$profile "/" #$entry-point))) - #:symlinks '#$symlinks + #:extra-files directives #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) -- cgit v1.2.3 From 7979a287f8eb84cbbfa44629951572408939a756 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:27:02 +0200 Subject: pack: Create /tmp in Docker images. Fixes . * guix/scripts/pack.scm (docker-image)[build]: Add a 'directory' entry for "/tmp" to DIRECTIVES. * tests/pack.scm ("docker-image + localstatedir"): Test the presence of /tmp. * gnu/tests/docker.scm (run-docker-test)["Load docker image and run it"]: Test the presence and permission bits of "/tmp". --- gnu/tests/docker.scm | 13 ++++++++++--- guix/scripts/pack.scm | 6 ++++-- tests/pack.scm | 1 + 3 files changed, 15 insertions(+), 5 deletions(-) (limited to 'guix/scripts/pack.scm') diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3ec5c3d6ee..3f98a1e316 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -100,7 +100,7 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - '("hello world" "hi!" "JSON!") + '("hello world" "hi!" "JSON!" #o1777) (marionette-eval `(begin (define slurp @@ -131,8 +131,15 @@ inside %DOCKER-OS." ,(string-append #$docker-cli "/bin/docker") "run" repository&tag "-c" "(use-modules (json)) - (display (json-string->scm (scm->json-string \"JSON!\")))"))) - (list response1 response2 response3))) + (display (json-string->scm (scm->json-string \"JSON!\")))")) + + ;; Check whether /tmp exists. + (response4 (slurp + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag "-c" + "(display (stat:perms (lstat \"/tmp\")))"))) + (list response1 response2 response3 + (string->number response4)))) marionette)) (test-end) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a15530ad70..dd91a24284 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -511,8 +511,10 @@ the image." (,source -> ,target)))))) (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + ;; Create a /tmp directory, as some programs expect it, and + ;; create SYMLINKS. + `((directory "/tmp" ,(getuid) ,(getgid) #o1777) + ,@(append-map symlink->directives '#$symlinks))) (setenv "PATH" (string-append #$archiver "/bin")) diff --git a/tests/pack.scm b/tests/pack.scm index ea88cd89f2..71ff5aec18 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -169,6 +169,7 @@ (when (and (file-exists? (string-append bin "/guile")) (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) (string=? (string-append #$profile "/bin/guile") -- cgit v1.2.3