diff options
Diffstat (limited to 'guix/scripts/pull.scm')
| -rw-r--r-- | guix/scripts/pull.scm | 125 |
1 files changed, 66 insertions, 59 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 8e31ad620c..58b87d4df4 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,45 +73,56 @@ (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 (_ "Usage: guix pull [OPTION]... + (display (G_ "Usage: guix pull [OPTION]... Download and deploy the latest version of Guix.\n")) - (display (_ " + (display (G_ " --verbose produce verbose output")) - (display (_ " + (display (G_ " --url=URL download the Guix tarball from URL")) - (display (_ " + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) - (display (_ " + (show-build-options-help) + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) (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)) @@ -153,7 +165,7 @@ store file name." (mbegin %store-monad (what-to-build (list tar gzip)) (built-derivations (list tar gzip)) - (format #t (_ "unpacking '~a'...~%") tarball) + (format #t (G_ "unpacking '~a'...~%") tarball) (let ((source (temporary-directory))) (with-directory-excursion source @@ -205,26 +217,18 @@ contained therein." (if (and (file-exists? latest) (string=? (readlink latest) source-dir)) (begin - (display (_ "Guix already up to date\n")) + (display (G_ "Guix already up to date\n")) (return #t)) (begin (switch-symlinks latest source-dir) (format #t - (_ "updated ~a successfully deployed under `~a'~%") + (G_ "updated ~a successfully deployed under `~a'~%") %guix-package-name latest) (return #t)))) - (leave (_ "failed to update Guix, check the build log~%"))))) + (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 (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~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)) - (store (open-connection)) + (let* ((opts (parse-command-line args %options + (list %default-options))) (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 (_ "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?)))))))) + (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful + (with-store store + (set-build-options-from-command-line store opts) + (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) |