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'.

1 files changed, 126 insertions, 111 deletions

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