diff options
Diffstat (limited to 'guix/scripts/pack.scm')
| -rw-r--r-- | guix/scripts/pack.scm | 178 |
1 files changed, 90 insertions, 88 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ee0395ea00..a9e9e7a415 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -37,6 +37,7 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix describe) + #:use-module (guix docker) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system gnu) @@ -58,7 +59,7 @@ #:export (compressor? lookup-compressor self-contained-tarball - docker-image + docker-image-pack squashfs-image guix-pack)) @@ -482,14 +483,14 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) -(define* (docker-image name profile - #:key target - (profile-name "guix-profile") - (compressor (first %compressors)) - entry-point - localstatedir? - (symlinks '()) - (archiver tar)) +(define* (docker-image-pack name profile + #:key target + (profile-name "guix-profile") + (compressor (first %compressors)) + entry-point + localstatedir? + (symlinks '()) + archiver) ; not sure why this is needed "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -500,83 +501,84 @@ the image." (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define defmod 'define-module) ;trick Geiser - - (define build - ;; Guile-JSON and Guile-Gcrypt are required by (guix build docker). - (with-extensions (list guile-json-3 guile-gcrypt) - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - `((guix build docker) - (guix build store-copy) - (guix profiles) - (guix search-paths)) - #:select? not-config?)) - #~(begin - (use-modules (guix build docker) (guix build store-copy) - (guix profiles) (guix search-paths) - (srfi srfi-1) (srfi srfi-19) - (ice-9 match)) - - (define environment - (map (match-lambda - ((spec . value) - (cons (search-path-specification-variable spec) - 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 - ;; Create a /tmp directory, as some programs expect it, and - ;; create SYMLINKS. - `((directory "/tmp" ,(getuid) ,(getgid) #o1777) - ,@(append-map symlink->directives '#$symlinks))) - - (define tag - ;; Compute a meaningful "repository" name, which will show up in - ;; the output of "docker images". - (let ((manifest (profile-manifest #$profile))) - (let loop ((names (map manifest-entry-name - (manifest-entries manifest)))) - (define str (string-join names "-")) - (if (< (string-length str) 40) - str - (match names - ((_) str) - ((names ... _) (loop names))))))) ;drop one entry - - (setenv "PATH" (string-append #$archiver "/bin")) - - (build-docker-image #$output - (map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - #$profile - #:repository tag - #:database #+database - #:system (or #$target (utsname:machine (uname))) - #:environment environment - #:entry-point - #$(and entry-point - #~(list (string-append #$profile "/" - #$entry-point))) - #:extra-files directives - #:compressor '#$(compressor-command compressor) - #:creation-time (make-time time-utc 0 1)))))) + (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 + ;; Create a /tmp directory, as some programs expect it, and + ;; create SYMLINKS. + `((directory "/tmp" ,(getuid) ,(getgid) #o1777) + ,@(append-map symlink->directives symlinks))) + + (define tag + ;; Compute a meaningful "repository" name, which will show up in + ;; the output of "docker images". + (let* ((built-profile + (with-store store + (let ((output + (build-derivations store (list profile))) + (path + (derivation-output-path + (match (derivation-outputs profile) + (((name . derivation-output)) + derivation-output))))) + path))) + (manifest (profile-manifest built-profile))) + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names))))))) ;drop one entry - (gexp->derivation (string-append name ".tar" - (compressor-extension compressor)) - build - #:references-graphs `(("profile" ,profile)))) + (define environment + (map (match-lambda + ((spec . value) + (cons (search-path-specification-variable spec) + value))) + (profile-search-paths + (with-store store + (let ((output + (build-derivations store (list profile))) + (path + (derivation-output-path + (match (derivation-outputs profile) + (((name . derivation-output)) + derivation-output))))) + path))))) + + (lower-object + (docker-image + (string-append name ".tar" + (compressor-extension compressor)) + (list (docker-image-layer + "pack-docker-image-layer" + (with-store store + (let ((output + (build-derivations store (list profile))) + (path + (derivation-output-path + (match (derivation-outputs profile) + (((name . derivation-output)) + derivation-output))))) + (requisites store (list path)))) + ;;#:extra-files directives + )) + #:repository tag + #:environment environment + #:entry-point (and entry-point + #~(list (string-append #$profile "/" + #$entry-point))) + #:compressor (compressor-command compressor)))) ;;; @@ -793,7 +795,7 @@ last resort for relocation." ;; Supported pack formats. `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) - (docker . ,docker-image))) + (docker . ,docker-image-pack))) (define (show-formats) ;; Print the supported pack formats. @@ -1016,7 +1018,7 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages)))))) - (with-error-handling + ;; (with-error-handling (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. @@ -1126,4 +1128,4 @@ to your package list."))) gc-root)) (return (format #t "~a~%" (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system)))))))) + #:system (assoc-ref opts 'system))))))) |