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.
2017-05-09 15:45:04 +02:00 · 2017-05-09 15:45:04 +02:00 · 4902d3c4e0
parent f0b7dc7ede
commit 4902d3c4e0
2 changed files with 59 additions and 50 deletions
--- a/doc/guix.texi
+++ b/doc/guix.texi
@ -2390,13 +2390,13 @@ For example, to download and deploy version 0.12.0 of Guix from the
 canonical Git repo:

@example
-guix pull --url=http://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.12.0.tar.gz
+guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.12.0.tar.gz
@end example

 It can also be used to deploy arbitrary Git revisions:

@example
-guix pull --url=http://git.savannah.gnu.org/cgit/guix.git/snapshot/74d862e8a.tar.gz
+guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/74d862e8a.tar.gz
@end example

@item --bootstrap
@ -2404,6 +2404,8 @@ Use the bootstrap Guile to build the latest Guix.  This option is only
 useful to Guix developers.
@end table

+In addition, @command{guix pull} supports all the common build options
+(@pxref{Common Build Options}).

@node Invoking guix pack
@section Invoking @command{guix pack}
--- 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)