summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-05-09 15:45:04 +0200
committerLudovic Courtès <ludo@gnu.org>2017-05-09 18:08:24 +0200
commit4902d3c4e0376974356481f222583580b49f39e1 (patch)
treeff5ccff2d946d510af9390950a04947a986d11e8 /guix/scripts
parentf0b7dc7edea730e9648b58cc0e651678a843e490 (diff)
pull: Honor the standard build options.
Reported by Niall Dooley <dooleyn@gmail.com> in <https://lists.gnu.org/archive/html/help-guix/2017-05/msg00038.html>. * guix/scripts/pull.scm (%options): Add --dry-run and all of %STANDARD-BUILD-OPTIONS. (show-help): Add call to 'show-build-options-help'. (%default-options): Add 'system', 'substitutes?', 'graft?', 'max-silent-time', and 'verbosity'. (guix-pull)[parse-options]: Remove. Use 'parse-command-line' instead. Honor --dry-run.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/pull.scm103
1 files changed, 55 insertions, 48 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 82fcaa248c..5ab95628b4 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -28,6 +28,7 @@
#:use-module (guix download)
#:use-module (guix gexp)
#:use-module (guix monads)
+ #:use-module (guix scripts build)
#:use-module ((guix build utils)
#:select (with-directory-excursion delete-file-recursively))
#:use-module ((guix build download)
@@ -72,7 +73,12 @@
(define %default-options
;; Alist of default option values.
- `((tarball-url . ,%snapshot-url)))
+ `((tarball-url . ,%snapshot-url)
+ (system . ,(%current-system))
+ (substitutes? . #t)
+ (graft? . #t)
+ (max-silent-time . 3600)
+ (verbosity . 0)))
(define (show-help)
(display (G_ "Usage: guix pull [OPTION]...
@@ -84,6 +90,7 @@ Download and deploy the latest version of Guix.\n"))
(display (G_ "
--bootstrap use the bootstrap Guile to build the new Guix"))
(newline)
+ (show-build-options-help)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -93,24 +100,29 @@ Download and deploy the latest version of Guix.\n"))
(define %options
;; Specifications of the command-line options.
- (list (option '("verbose") #f #f
- (lambda (opt name arg result)
- (alist-cons 'verbose? #t result)))
- (option '("url") #t #f
- (lambda (opt name arg result)
- (alist-cons 'tarball-url arg
- (alist-delete 'tarball-url result))))
- (option '("bootstrap") #f #f
- (lambda (opt name arg result)
- (alist-cons 'bootstrap? #t result)))
+ (cons* (option '("verbose") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'verbose? #t result)))
+ (option '("url") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'tarball-url arg
+ (alist-delete 'tarball-url result))))
+ (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (option '("bootstrap") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'bootstrap? #t result)))
- (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix pull")))))
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix pull")))
+
+ %standard-build-options))
(define what-to-build
(store-lift show-what-to-build))
@@ -215,16 +227,8 @@ contained therein."
(return #t))))
(leave (G_ "failed to update Guix, check the build log~%")))))
+
(define (guix-pull . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (G_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (leave (G_ "~A: unexpected argument~%") arg))
- %default-options))
-
(define (use-le-certs? url)
(string-prefix? "https://git.savannah.gnu.org/" url))
@@ -232,28 +236,31 @@ contained therein."
(download-to-store store url "guix-latest.tar.gz"))
(with-error-handling
- (let* ((opts (parse-options))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
(store (open-connection))
(url (assoc-ref opts 'tarball-url)))
- (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 (G_ "failed to download up-to-date source, exiting\n")))
- (parameterize ((%guile-for-build
- (package-derivation store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.0)))))
- (run-with-store store
- (build-and-install tarball (config-directory)
- #:verbose? (assoc-ref opts 'verbose?))))))))
+ (set-build-options-from-command-line store opts)
+ (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful
+ (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 (G_ "failed to download up-to-date source, exiting\n")))
+ (parameterize ((%guile-for-build
+ (package-derivation store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.0)))))
+ (run-with-store store
+ (build-and-install tarball (config-directory)
+ #:verbose? (assoc-ref opts 'verbose?)))))))))
;; Local Variables:
;; eval: (put 'with-PATH 'scheme-indent-function 1)