pull: Fetch source code from Git.

* guix/scripts/pull.scm (%snapshot-url, with-environment-variable)
(with-PATH): Remove.
(ensure-guile-git!): New procedure.
(%repository-url): New variable.
(%default-options): Add 'repository-url' and 'ref'.
(show-help, %options): Add '--commit' and '--url'.
(temporary-directory, first-directory, interned-then-deleted)
(unpack): Remove.
(build-from-source): Rename 'tarball' to 'source'.  Remove call to
'unpack'.
(build-and-install): Rename 'tarball' to 'source'.
(honor-lets-encrypt-certificates!, report-git-error): New procedures.
(with-git-error-handling): New macro.
(guix-pull)[fetch-tarball]: Remove.
Wrap body in 'with-git-error-handling'.  Rewrite to use
'latest-repository-commit'.
* build-aux/build-self.scm (build): Print an error message and exit when
GUILE-GIT is #f.
* doc/guix.texi (Invoking guix pull): Mention Git.  Document '--commit'
and '--branch'.

3 files changed, 153 insertions, 126 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 8fb9af23ca..4933e02712 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -224,6 +224,23 @@ files."
                                      (current-error-port)
                                      (%make-void-port "w")))))
 
+  (unless guile-git
+    ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether.
+    ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not
+    ;; build (guix git), which will leave us with an unusable 'guix pull'.  To
+    ;; avoid that, fail early.
+    (format (current-error-port)
+            "\
+Your installation is too old and lacks a '~a' package.
+Please upgrade to an intermediate version first, for instance with:
+
+  guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz
+\n"
+            (match (effective-version)
+              ("2.0" "guile2.0-git")
+              (_     "guile-git")))
+    (exit 1))
+
   (mlet %store-monad ((guile (guile-for-build)))
     (gexp->derivation "guix-latest" builder
                       #:modules '((guix build pull)
diff --git a/doc/guix.texi b/doc/guix.texi
index 7957565e85..0ea677387b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2477,7 +2477,8 @@ Packages are installed or upgraded to the latest version available in
 the distribution currently available on your local machine.  To update
 that distribution, along with the Guix tools, you must run @command{guix
 pull}: the command downloads the latest Guix source code and package
-descriptions, and deploys it.
+descriptions, and deploys it.  Source code is downloaded from a
+@uref{https://git-scm.com, Git} repository.
 
 On completion, @command{guix package} will use packages and package
 versions from this just-retrieved copy of Guix.  Not only that, but all
@@ -2503,24 +2504,18 @@ but it supports the following options:
 Produce verbose output, writing build logs to the standard error output.
 
 @item --url=@var{url}
-Download the source tarball of Guix from @var{url}.
+Download Guix from the Git repository at @var{url}.
 
-By default, the tarball is taken from its canonical address at
+By default, the source is taken from its canonical Git repository at
 @code{gnu.org}, for the stable branch of Guix.
 
-With some Git servers, this can be used to deploy any version of Guix.
-For example, to download and deploy version 0.12.0 of Guix from the
-canonical Git repo:
-
-@example
-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:
+@item --commit=@var{commit}
+Deploy @var{commit}, a valid Git commit ID represented as a hexadecimal
+string.
 
-@example
-guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/74d862e8a.tar.gz
-@end example
+@item --branch=@var{branch}
+Deploy the tip of @var{branch}, the name of a Git branch available on
+the repository at @var{url}.
 
 @item --bootstrap
 Use the bootstrap Guile to build the latest Guix.  This option is only
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58b87d4df4..e3b07e08b1 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -41,6 +41,7 @@
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
@@ -48,23 +49,39 @@
   #:use-module (ice-9 match)
   #:export (guix-pull))
 
-(define %snapshot-url
-  ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
-  "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
-  )
+(module-autoload! (resolve-module '(guix scripts pull))
+                  '(git) '(git-error? set-tls-certificate-locations!)
+                  '(guix git) '(latest-repository-commit))
 
-(define-syntax-rule (with-environment-variable variable value body ...)
-  (let ((original (getenv variable)))
-    (dynamic-wind
-      (lambda ()
-        (setenv variable value))
-      (lambda ()
-        body ...)
-      (lambda ()
-        (setenv variable original)))))
+(define (ensure-guile-git!)
+  ;; Previously Guile-Git was not a prerequisite.  Thus, someone running 'guix
+  ;; pull' on an old installation may be lacking Guile-Git.  To address this,
+  ;; we autoload things that depend on Guile-Git and check in the entry point
+  ;; whether Guile-Git is available.
+  ;;
+  ;; TODO: Remove this hack when Guile-Git is widespread or enforced.
 
-(define-syntax-rule (with-PATH value body ...)
-  (with-environment-variable "PATH" value body ...))
+  (unless (false-if-exception (resolve-interface '(git)))
+    (leave (G_ "Guile-Git is missing but it is now required by 'guix pull'.
+Install it by running:
+
+  guix package -i ~a
+  export GUILE_LOAD_PATH=$HOME/.guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH
+  export GUILE_LOAD_COMPILED_PATH=$HOME/.guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH
+\n")
+           (match (effective-version)
+             ("2.0" "guile2.0-git")
+             (_     "guile-git"))
+           (effective-version)
+           (effective-version)))
+
+  ;; XXX: For unclear reasons this is needed for
+  ;; 'set-tls-certificate-locations!'.
+  (module-use! (resolve-module '(guix scripts pull))
+               (resolve-interface '(git))))
+
+(define %repository-url
+  "https://git.savannah.gnu.org/git/guix.git")
 
 
 ;;;
@@ -73,7 +90,8 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((tarball-url . ,%snapshot-url)
+  `((repository-url . ,%repository-url)
+    (ref . (branch . "origin/master"))
     (system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
@@ -86,7 +104,11 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --verbose          produce verbose output"))
   (display (G_ "
-      --url=URL          download the Guix tarball from URL"))
+      --url=URL          download from the Git repository at URL"))
+  (display (G_ "
+      --commit=COMMIT    download the specified COMMIT"))
+  (display (G_ "
+      --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
       --bootstrap        use the bootstrap Guile to build the new Guix"))
   (newline)
@@ -105,8 +127,15 @@ Download and deploy the latest version of Guix.\n"))
                    (alist-cons 'verbose? #t result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'tarball-url arg
-                               (alist-delete 'tarball-url result))))
+                   (alist-cons 'repository-url arg
+                               (alist-delete 'repository-url result))))
+         (option '("commit") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(commit . ,arg) result)))
+         (option '("branch") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(branch . ,(string-append "origin/" arg))
+                               result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
@@ -129,81 +158,28 @@ Download and deploy the latest version of Guix.\n"))
 (define indirect-root-added
   (store-lift add-indirect-root))
 
-(define (temporary-directory)
-  "Make a temporary directory and return its name."
-  (let ((name (tmpnam)))
-    (mkdir name)
-    (chmod name #o700)
-    name))
-
-(define (first-directory directory)
-  "Return a the name of the first file found under DIRECTORY."
-  (match (scandir directory
-                  (lambda (name)
-                    (and (not (member name '("." "..")))
-                         (file-is-directory? name))))
-    ((directory)
-     directory)
-    (x
-     (raise (condition
-             (&message
-              (message "tarball did not produce a single source directory")))))))
-
-(define (interned-then-deleted directory name)
-  "Add DIRECTORY to the store under NAME, and delete it.  Return the resulting
-store file name."
-  (mlet %store-monad ((result (interned-file directory name
-                                             #:recursive? #t)))
-    (delete-file-recursively directory)
-    (return result)))
-
-(define (unpack tarball)
-  "Return the name of the directory where TARBALL has been unpacked."
-  (mlet* %store-monad ((format -> (lift format %store-monad))
-                       (tar  (package->derivation tar))
-                       (gzip (package->derivation gzip)))
-    (mbegin %store-monad
-      (what-to-build (list tar gzip))
-      (built-derivations (list tar gzip))
-      (format #t (G_ "unpacking '~a'...~%") tarball)
-
-      (let ((source (temporary-directory)))
-        (with-directory-excursion source
-          (with-PATH (string-append (derivation->output-path gzip) "/bin")
-            (unless (zero? (system* (string-append (derivation->output-path tar)
-                                                   "/bin/tar")
-                                    "xf" tarball))
-              (raise (condition
-                      (&message (message "failed to unpack source code"))))))
-
-          (interned-then-deleted (string-append source "/"
-                                                (first-directory source))
-                                 "guix-source"))))))
-
 (define %self-build-file
   ;; The file containing code to build Guix.  This serves the same purpose as
   ;; a makefile, and, similarly, is intended to always keep this name.
   "build-aux/build-self.scm")
 
-(define* (build-from-source tarball #:key verbose?)
-  "Return a derivation to build Guix from TARBALL, using the self-build script
+(define* (build-from-source source #:key verbose?)
+  "Return a derivation to build Guix from SOURCE, using the self-build script
 contained therein."
   ;; Running the self-build script makes it easier to update the build
   ;; procedure: the self-build script of the Guix-to-be-installed contains the
   ;; right dependencies, build procedure, etc., which the Guix-in-use may not
   ;; be know.
-  (mlet* %store-monad ((source (unpack tarball))
-                       (script -> (string-append source "/"
-                                                 %self-build-file))
-                       (build -> (primitive-load script)))
+  (let* ((script (string-append source "/" %self-build-file))
+         (build  (primitive-load script)))
     ;; BUILD must be a monadic procedure of at least one argument: the source
     ;; tree.
     (build source #:verbose? verbose?)))
 
-(define* (build-and-install tarball config-dir
+(define* (build-and-install source config-dir
                             #:key verbose?)
-  "Build the tool from TARBALL, and install it in CONFIG-DIR."
-  (mlet* %store-monad ((source        (build-from-source tarball
+  "Build the tool from SOURCE, and install it in CONFIG-DIR."
+  (mlet* %store-monad ((source        (build-from-source source
                                                          #:verbose? verbose?))
                        (source-dir -> (derivation->output-path source))
                        (to-do?        (what-to-build (list source)))
@@ -227,44 +203,83 @@ contained therein."
                 (return #t))))
         (leave (G_ "failed to update Guix, check the build log~%")))))
 
+(define (honor-lets-encrypt-certificates! store)
+  "Tell Guile-Git to use the Let's Encrypt certificates."
+  (let* ((drv   (package-derivation store le-certs))
+         (certs (string-append (derivation->output-path drv)
+                               "/etc/ssl/certs")))
+    (build-derivations store (list drv))
+
+    ;; In the past Guile-Git would not provide this procedure.
+    (if (module-defined? (resolve-interface '(git))
+                         'set-tls-certificate-locations!)
+        (set-tls-certificate-locations! certs)
+        (begin
+          ;; In this case we end up using whichever certificates OpenSSL
+          ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
+          (warning (G_ "cannot enforce use of the Let's Encrypt \
+certificates~%"))
+          (warning (G_ "please upgrade Guile-Git~%"))))))
+
+(define (report-git-error error)
+  "Report the given Guile-Git error."
+  ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
+  ;; errors would be represented by integers.
+  (match error
+    ((? integer? error)                           ;old Guile-Git
+     (leave (G_ "Git error ~a~%") error))
+    ((? git-error? error)                         ;new Guile-Git
+     (leave (G_ "Git error: ~a~%") (git-error-message error)))))
+
+(define-syntax-rule (with-git-error-handling body ...)
+  (catch 'git-error
+    (lambda ()
+      body ...)
+    (lambda (key err)
+      (report-git-error err))))
+
 
 (define (guix-pull . args)
   (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-command-line args %options
-                                      (list %default-options)))
-           (url   (assoc-ref opts 'tarball-url)))
-      (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?))))))))))
+    (with-git-error-handling
+     (let* ((opts  (parse-command-line args %options
+                                       (list %default-options)))
+            (url   (assoc-ref opts 'repository-url))
+            (ref   (assoc-ref opts 'ref))
+            (cache (string-append (cache-directory) "/pull")))
+       (ensure-guile-git!)
+
+       (unless (assoc-ref opts 'dry-run?)         ;XXX: not very useful
+         (with-store store
+           (set-build-options-from-command-line store opts)
+
+           ;; For reproducibility, always refer to the LE certificates when we
+           ;; know we're talking to Savannah.
+           (when (use-le-certs? url)
+             (honor-lets-encrypt-certificates! store))
+
+           (format (current-error-port)
+                   (G_ "Updating from Git repository at '~a'...~%")
+                   url)
+
+           (let-values (((checkout commit)
+                         (latest-repository-commit store url
+                                                   #:ref ref
+                                                   #:cache-directory cache)))
 
-;; Local Variables:
-;; eval: (put 'with-PATH 'scheme-indent-function 1)
-;; eval: (put 'with-temporary-directory 'scheme-indent-function 1)
-;; End:
+             (format (current-error-port)
+                     (G_ "Building from Git commit ~a...~%")
+                     commit)
+             (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 checkout (config-directory)
+                                    #:verbose? (assoc-ref opts 'verbose?)))))))))))
 
 ;;; pull.scm ends here