From 239c22663ac928618028c4ec03cefc77de788e9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 Mar 2017 16:48:40 +0100 Subject: Add 'guix pack'. * gnu/system/install.scm (self-contained-tarball): Move to... * guix/scripts/pack.scm: ... here. New file. * doc/guix.texi (Binary Installation): Mention 'guix pack'. (Invoking guix pack): New node. * build-aux/make-binary-tarball.scm: Remove. * Makefile.am (MODULES): Add guix/scripts/pack.scm. (EXTRA_DIST): Remove build-aux/make-binary-tarball.scm. (guix-binary.%.tar.xz): Rewrite using 'guix pack'. * build-aux/hydra/gnu-system.scm (tarball-jobs): Adjust accordingly. --- guix/scripts/pack.scm | 229 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 229 insertions(+) create mode 100644 guix/scripts/pack.scm (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm new file mode 100644 index 0000000000..e8f3d800a8 --- /dev/null +++ b/guix/scripts/pack.scm @@ -0,0 +1,229 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015, 2017 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts pack) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (guix gexp) + #:use-module (guix utils) + #:use-module (guix store) + #:use-module (guix grafts) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix derivations) + #:use-module (guix scripts build) + #:use-module (gnu packages) + #:use-module (gnu packages compression) + #:autoload (gnu packages base) (tar) + #:autoload (gnu packages package-management) (guix) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (compressor? + lookup-compressor + self-contained-tarball + guix-pack)) + +;; Type of a compression tool. +(define-record-type + (compressor name package extension tar-option) + 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") + +(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"))) + +(define (lookup-compressor name) + "Return the compressor object called NAME. Error out if it could not be +found." + (or (find (match-lambda + (($ name*) + (string=? name* name))) + %compressors) + (leave (_ "~a: compressor not found~%") name))) + +(define* (self-contained-tarball name profile + #:key deduplicate? + (compressor (first %compressors))) + "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." + (define build + (with-imported-modules '((guix build utils) + (guix build store-copy) + (gnu build install)) + #~(begin + (use-modules (guix build utils) + (gnu build install)) + + (define %root "root") + + ;; We need Guix here for 'guix-register'. + (setenv "PATH" + (string-append #$guix "/sbin:" #$tar "/bin:" + #$(compressor-package compressor) "/bin")) + + ;; Note: there is not much to gain here with deduplication and + ;; there is the overhead of the '.links' directory, so turn it + ;; off. + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f) + + ;; 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)))))))) + + (gexp->derivation (string-append name ".tar." + (compressor-extension compressor)) + build + #:references-graphs `(("profile" ,profile)))) + + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (graft? . #t) + (max-silent-time . 3600) + (verbosity . 0) + (compressor . ,(first %compressors)))) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix pack"))) + + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\C "compression") #t #f + (lambda (opt name arg result) + (alist-cons 'compressor (lookup-compressor arg) + result))) + + (append %transformation-options + %standard-build-options))) + +(define (show-help) + (display (_ "Usage: guix pack [OPTION]... PACKAGE... +Create a bundle of PACKAGE.\n")) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-pack . args) + (define opts + (parse-command-line args %options (list %default-options))) + + (with-error-handling + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (specs (filter-map (match-lambda + (('argument . name) + name) + (x #f)) + opts)) + (packages (map (lambda (spec) + (call-with-values + (lambda () + (specification->package+output spec)) + list)) + specs)) + (compressor (assoc-ref opts 'compressor))) + (with-store store + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + (packages->manifest packages))) + (drv (self-contained-tarball "pack" profile + #:compressor + compressor))) + (mbegin %store-monad + (show-what-to-build* (list drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + (munless dry-run? + (built-derivations (list drv)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system))))))) -- cgit v1.2.3