diff options
author | Marius Bakke <mbakke@fastmail.com> | 2017-03-15 17:52:26 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2017-03-15 17:52:26 +0100 |
commit | 4b7e5c1131430f10e6211879836cf17447ef5bbc (patch) | |
tree | 54155070ec4044a78c1abf20f879fded47b5baf2 /guix/scripts | |
parent | adb984d23c003d5d48ada47bf5ad8105a3b8e412 (diff) | |
parent | 608e42e7c92114497e7908980424288079acee1e (diff) | |
download | guix-patches-4b7e5c1131430f10e6211879836cf17447ef5bbc.tar guix-patches-4b7e5c1131430f10e6211879836cf17447ef5bbc.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/pack.scm | 151 |
1 files changed, 114 insertions, 37 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e8f3d800a8..067b1227e0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -43,20 +43,19 @@ ;; Type of a compression tool. (define-record-type <compressor> - (compressor name package extension tar-option) + (compressor name package extension command) compressor? (name compressor-name) ;string (e.g., "gzip") (package compressor-package) ;package (extension compressor-extension) ;string (e.g., "lz") - (tar-option compressor-tar-option)) ;string (e.g., "--lzip") + (command compressor-command)) ;list (e.g., '("gzip" "-9n")) (define %compressors ;; Available compression tools. - ;; FIXME: Use '--no-name' for gzip. - (list (compressor "gzip" gzip "gz" "--gzip") - (compressor "lzip" lzip "lz" "--lzip") - (compressor "xz" xz "xz" "--xz") - (compressor "bzip2" bzip2 "bz2" "--bzip2"))) + (list (compressor "gzip" gzip "gz" '("gzip" "-9n")) + (compressor "lzip" lzip "lz" '("lzip" "-9")) + (compressor "xz" xz "xz" '("xz" "-e")) + (compressor "bzip2" bzip2 "bz2" '("bzip2" "-9")))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -69,23 +68,57 @@ found." (define* (self-contained-tarball name profile #:key deduplicate? - (compressor (first %compressors))) + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (tar tar)) "Return a self-contained tarball containing a store initialized with the -closure of PROFILE, a derivation. The tarball contains /gnu/store, /var/guix, -and PROFILE is available as /root/.guix-profile." +closure of PROFILE, a derivation. The tarball contains /gnu/store; if +LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db +with a properly initialized store database. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." (define build (with-imported-modules '((guix build utils) (guix build store-copy) (gnu build install)) #~(begin (use-modules (guix build utils) - (gnu build install)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) (define %root "root") + (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))) + `((directory ,(dirname source)) + (,source -> ,target)))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + ;; We need Guix here for 'guix-register'. (setenv "PATH" - (string-append #$guix "/sbin:" #$tar "/bin:" + (string-append #$(if localstatedir? + (file-append guix "/sbin:") + "") + #$tar "/bin:" #$(compressor-package compressor) "/bin")) ;; Note: there is not much to gain here with deduplication and @@ -94,33 +127,50 @@ and PROFILE is available as /root/.guix-profile." (populate-single-profile-directory %root #:profile #$profile #:closure "profile" - #:deduplicate? #f) + #:deduplicate? #f + #:register? #$localstatedir?) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) ;; Create the tarball. Use GNU format so there's no file name ;; length limitation. (with-directory-excursion %root - (zero? (system* "tar" #$(compressor-tar-option compressor) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - "--sort=name" - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - "./var/guix" - (string-append "." (%store-directory)))))))) + (exit + (zero? (apply system* "tar" + "-I" #$(string-join (compressor-command compressor)) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar." (compressor-extension compressor)) @@ -140,6 +190,7 @@ and PROFILE is available as /root/.guix-profile." (graft? . #t) (max-silent-time . 3600) (verbosity . 0) + (symlinks . ()) (compressor . ,(first %compressors)))) (define %options @@ -163,6 +214,22 @@ and PROFILE is available as /root/.guix-profile." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) + (option '(#\S "symlink") #t #f + (lambda (opt name arg result) + (match (string-tokenize arg + (char-set-complement + (char-set #\=))) + ((source target) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (_ "~a: invalid symlink specification~%") + arg))))) + (option '("localstatedir") #f #f + (lambda (opt name arg result) + (alist-cons 'localstatedir? #t result))) (append %transformation-options %standard-build-options))) @@ -178,6 +245,10 @@ Create a bundle of PACKAGE.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) + (display (_ " + -S, --symlink=SPEC create symlinks to the profile according to SPEC")) + (display (_ " + --localstatedir include /var/guix in the resulting pack")) (newline) (display (_ " -h, --help display this help and exit")) @@ -209,14 +280,20 @@ Create a bundle of PACKAGE.\n")) (specification->package+output spec)) list)) specs)) - (compressor (assoc-ref opts 'compressor))) + (compressor (assoc-ref opts 'compressor)) + (symlinks (assoc-ref opts 'symlinks)) + (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store (run-with-store store (mlet* %store-monad ((profile (profile-derivation (packages->manifest packages))) (drv (self-contained-tarball "pack" profile #:compressor - compressor))) + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir?))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? |