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 From 334c95306a298803096a0077c892d69473ad0824 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 Mar 2017 17:35:32 +0100 Subject: syscalls: Adjust 'define-bits' to macro literal semantics of 2.2. * guix/build/syscalls.scm (define-bits): Do not define NAMES... as top-level variables since that prevents literal matches in 2.2. Instead, determine constant values at expansion time. --- guix/build/syscalls.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b68c48a05a..58c23f2844 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1346,12 +1346,12 @@ given an integer, returns the list of names of the constants that are or'd." (begin (define-syntax constructor (syntax-rules (names ...) + ((_) 0) ((_ names) values) ... - ((_ several (... ...)) - (logior (constructor several) (... ...))))) + ((_ first rest (... ...)) + (logior (constructor first) rest (... ...))))) (define (bits->symbols bits) - (bits->symbols-body bits (names ...) (values ...))) - (define names values) ...)))) + (bits->symbols-body bits (names ...) (values ...))))))) ;; 'local-flags' bits from (define-bits local-flags -- cgit v1.2.3 From 7e81d699de7a2c924a048175516fe1ac3820d8e6 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Wed, 1 Mar 2017 22:11:02 +0100 Subject: pull: Default to HTTPS. * guix/scripts/pull.scm (%snapshot-url): Use HTTPS. (guix-pull): Authenticate against LE-CERTS when URL is from Savannah. --- guix/scripts/pull.scm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index a4824e4fd7..8e31ad620c 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2017 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,10 +30,13 @@ #:use-module (guix monads) #:use-module ((guix build utils) #:select (with-directory-excursion delete-file-recursively)) + #:use-module ((guix build download) + #:select (%x509-certificate-directory)) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (gnu packages compression) #:use-module (gnu packages gnupg) #:use-module (srfi srfi-1) @@ -45,7 +49,7 @@ (define %snapshot-url ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" - "http://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz" + "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz" ) (define-syntax-rule (with-environment-variable variable value body ...) @@ -221,11 +225,25 @@ contained therein." (leave (_ "~A: unexpected argument~%") arg)) %default-options)) + (define (use-le-certs? url) + (string-prefix? "https://git.savannah.gnu.org/" url)) + + (define (fetch-tarball store url) + (download-to-store store url "guix-latest.tar.gz")) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) (url (assoc-ref opts 'tarball-url))) - (let ((tarball (download-to-store store url "guix-latest.tar.gz"))) + (let ((tarball + (if (use-le-certs? url) + (let* ((drv (package-derivation store le-certs)) + (certs (string-append (derivation->output-path drv) + "/etc/ssl/certs"))) + (build-derivations store (list drv)) + (parameterize ((%x509-certificate-directory certs)) + (fetch-tarball store url))) + (fetch-tarball store url)))) (unless tarball (leave (_ "failed to download up-to-date source, exiting\n"))) (parameterize ((%guile-for-build -- cgit v1.2.3