From 760c60d68491bd6803e86e405e765f3337663f17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Dec 2013 01:08:21 +0100 Subject: Add 'guix archive'. * guix/scripts/archive.scm, tests/guix-archive.sh: New files. * Makefile.am (MODULES): Add 'archive.scm'. (SH_TESTS): Add 'guix-archive.sh'. * doc/guix.texi (Invoking guix archive): New section. * guix/scripts/build.scm: Export 'derivation-from-expression'. * guix/scripts/package.scm: Export 'specification->package+output'. --- guix/scripts/archive.scm | 232 +++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/build.scm | 3 +- guix/scripts/package.scm | 5 +- 3 files changed, 237 insertions(+), 3 deletions(-) create mode 100644 guix/scripts/archive.scm (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm new file mode 100644 index 0000000000..df538ed1b7 --- /dev/null +++ b/guix/scripts/archive.scm @@ -0,0 +1,232 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 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 archive) + #:use-module (guix config) + #:use-module (guix utils) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (guix scripts build) + #:use-module (guix scripts package) + #:export (guix-archive)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix archive [OPTION]... PACKAGE... +Export/import one or more packages from/to the store.\n")) + (display (_ " + --export export the specified files/packages to stdout")) + (display (_ " + --import import from the archive passed on stdin")) + (newline) + (display (_ " + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --fallback fall back to building when the substituter fails")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + --max-silent-time=SECONDS + mark the build as failed after SECONDS of silence")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix build"))) + + (option '("export") #f #f + (lambda (opt name arg result) + (alist-cons 'export #t result))) + (option '("import") #f #f + (lambda (opt name arg result) + (alist-cons 'import #t result))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("fallback") #f #f + (lambda (opt name arg result) + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '("max-silent-time") #t #f + (lambda (opt name arg result) + (alist-cons 'max-silent-time (string->number* arg) + result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + +(define (options->derivations+files store opts) + "Given OPTS, the result of 'args-fold', return a list of derivations to +build and a list of store files to transfer." + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) + + (define src? (assoc-ref opts 'source?)) + (define sys (assoc-ref opts 'system)) + + (fold2 (lambda (arg derivations files) + (match arg + (('expression . str) + (let ((drv (derivation-from-expression store str + package->derivation + sys src?))) + (values (cons drv derivations) + (cons (derivation->output-path drv) files)))) + (('argument . (? store-path? file)) + (values derivations (cons file files))) + (('argument . (? string? spec)) + (let-values (((p output) + (specification->package+output spec))) + (if src? + (let* ((s (package-source p)) + (drv (package-source-derivation store s))) + (values (cons drv derivations) + (cons (derivation->output-path drv) + files))) + (let ((drv (package->derivation store p sys))) + (values (cons drv derivations) + (cons (derivation->output-path drv output) + files)))))) + (_ + (values derivations files)))) + '() + '() + opts)) + + +;;; +;;; Entry point. +;;; + +(define (export-from-store store opts) + "Export the packages or derivations specified in OPTS from STORE. Write the +resulting archive to the standard output port." + (let-values (((drv files) + (options->derivations+files store opts))) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (set-build-options store + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time)) + + (if (or (assoc-ref opts 'dry-run?) + (build-derivations store drv)) + (export-paths store files (current-output-port)) + (leave (_ "unable to export the given packages"))))) + +(define (guix-archive . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + ;; Ask for absolute file names so that .drv file names passed from the + ;; user to 'read-derivation' are absolute when it returns. + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (let* ((opts (parse-options)) + (store (open-connection))) + + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + (else + (leave + (_ "either '--export' or '--import' must be specified")))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b3d852e950..90187094c1 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -33,7 +33,8 @@ (define-module (guix scripts build) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:autoload (gnu packages) (find-best-packages-by-name) - #:export (guix-build)) + #:export (derivation-from-expression + guix-build)) (define (derivation-from-expression store str package-derivation system source?) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8c197a741e..7cebf6b4d4 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -41,7 +41,8 @@ (define-module (guix scripts package) #:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (guix gnu-maintenance) - #:export (guix-package)) + #:export (specification->package+output + guix-package)) (define %store (make-parameter #f)) @@ -293,7 +294,7 @@ (define-syntax-rule (waiting exp fmt rest ...) #f)))) (define* (specification->package+output spec #:optional (output "out")) - "Find the package and output specified by SPEC, or #f and #f; SPEC may + "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: guile -- cgit v1.2.3