Merge remote-tracking branch 'origin/master' into staging

2 files changed, 31 insertions, 175 deletions

diff --git a/guix/build/git.scm b/guix/build/git.scm
index 2d1700a9b9..669e38cd32 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +18,8 @@
 
 (define-module (guix build git)
   #:use-module (guix build utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (ice-9 format)
   #:export (git-fetch))
 
 ;;; Commentary:
@@ -39,31 +41,39 @@ recursively.  Return #t on success, #f otherwise."
 
   (mkdir-p directory)
 
-  (with-directory-excursion directory
-    (invoke git-command "init")
-    (invoke git-command "remote" "add" "origin" url)
-    (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
-        (invoke git-command "checkout" "FETCH_HEAD")
-        (begin
-          (setvbuf (current-output-port) 'line)
-          (format #t "Failed to do a shallow fetch; retrying a full fetch...~%")
-          (invoke git-command "fetch" "origin")
-          (invoke git-command "checkout" commit)))
-    (when recursive?
-      ;; Now is the time to fetch sub-modules.
-      (unless (zero? (system* git-command "submodule" "update"
-                                          "--init" "--recursive"))
-        (error "failed to fetch sub-modules" url))
+  (guard (c ((invoke-error? c)
+             (format (current-error-port)
+                     "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
+                     (invoke-error-program c)
+                     (invoke-error-arguments c)
+                     (or (invoke-error-exit-status c) ;XXX: not quite accurate
+                         (invoke-error-stop-signal c)
+                         (invoke-error-term-signal c)))
+             (delete-file-recursively directory)
+             #f))
+    (with-directory-excursion directory
+      (invoke git-command "init")
+      (invoke git-command "remote" "add" "origin" url)
+      (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
+          (invoke git-command "checkout" "FETCH_HEAD")
+          (begin
+            (setvbuf (current-output-port) 'line)
+            (format #t "Failed to do a shallow fetch; retrying a full fetch...~%")
+            (invoke git-command "fetch" "origin")
+            (invoke git-command "checkout" commit)))
+      (when recursive?
+        ;; Now is the time to fetch sub-modules.
+        (invoke git-command "submodule" "update" "--init" "--recursive")
 
-      ;; In sub-modules, '.git' is a flat file, not a directory,
-      ;; so we can use 'find-files' here.
-      (for-each delete-file-recursively
-                (find-files directory "^\\.git$")))
+        ;; In sub-modules, '.git' is a flat file, not a directory,
+        ;; so we can use 'find-files' here.
+        (for-each delete-file-recursively
+                  (find-files directory "^\\.git$")))
 
       ;; The contents of '.git' vary as a function of the current
       ;; status of the Git repo.  Since we want a fixed output, this
       ;; directory needs to be taken out.
       (delete-file-recursively ".git")
-      #t))
+      #t)))
 
 ;;; git.scm ends here
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
deleted file mode 100644
index a011e366f6..0000000000
--- a/guix/build/pull.scm
+++ /dev/null
@@ -1,154 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix build pull)
-  #:use-module (guix modules)
-  #:use-module (guix build utils)
-  #:use-module (guix build compile)
-  #:use-module (ice-9 ftw)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 format)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-34)
-  #:export (build-guix))
-
-;;; Commentary:
-;;;
-;;; Helpers for the 'guix pull' command to unpack and build Guix.
-;;;
-;;; Code:
-
-(define (has-all-its-dependencies? file)
-  "Return true if the dependencies of the module defined in FILE are
-available, false otherwise."
-  (let ((module (call-with-input-file file
-                  (lambda (port)
-                    (match (read port)
-                      (('define-module name _ ...)
-                       name))))))
-    ;; If one of the dependencies of MODULE is missing, we get a
-    ;; '&missing-dependency-error'.
-    (guard (c ((missing-dependency-error? c) #f))
-      (source-module-closure (list module) #:select? (const #t)))))
-
-(define (all-scheme-files directory)
-  "Return a sorted list of Scheme files found in DIRECTORY."
-  ;; Load guix/ modules before gnu/ modules to get somewhat steadier
-  ;; progress reporting.
-  (sort (filter (cut string-suffix? ".scm" <>)
-                (find-files directory "\\.scm"))
-        (let ((guix (string-append directory "/guix"))
-              (gnu  (string-append directory "/gnu")))
-          (lambda (a b)
-            (or (and (string-prefix? guix a)
-                     (string-prefix? gnu  b))
-                (string<? a b))))))
-
-
-(define* (build-guix out source
-                     #:key
-                     system
-                     storedir localstatedir sysconfdir sbindir
-
-                     (package-name "GNU Guix")
-                     (package-version "0")
-                     (bug-report-address "bug-guix@gnu.org")
-                     (home-page-url "https://gnu.org/s/guix")
-
-                     libgcrypt zlib gzip bzip2 xz
-
-                     (debug-port (%make-void-port "w"))
-                     (log-port (current-error-port)))
-  "Build and install Guix in directory OUT using SOURCE, a directory
-containing the source code.  Write any debugging output to DEBUG-PORT."
-  (setvbuf (current-output-port) _IOLBF)
-  (setvbuf (current-error-port) _IOLBF)
-
-  (with-directory-excursion source
-    (format #t "copying and compiling to '~a' with Guile ~a...~%"
-            out (version))
-
-    ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
-    (copy-recursively "guix" (string-append out "/guix")
-                      #:log debug-port)
-    (copy-recursively "gnu" (string-append out "/gnu")
-                      #:log debug-port)
-    (copy-file "guix.scm" (string-append out "/guix.scm"))
-    (copy-file "gnu.scm" (string-append out "/gnu.scm"))
-
-    ;; Instantiate a (guix config) module that preserves the original
-    ;; settings.
-    (copy-file "guix/config.scm.in"
-               (string-append out "/guix/config.scm"))
-    (substitute* (string-append out "/guix/config.scm")
-      (("@PACKAGE_NAME@") package-name)
-      (("@PACKAGE_VERSION@") package-version)
-      (("@PACKAGE_BUGREPORT@") bug-report-address)
-      (("@PACKAGE_URL@") home-page-url)
-      (("@storedir@") storedir)
-      (("@guix_localstatedir@") localstatedir)
-      (("@guix_sysconfdir@") sysconfdir)
-      (("@guix_sbindir@") sbindir)
-      (("@guix_system@") system)
-      (("@LIBGCRYPT@") (string-append libgcrypt "/lib/libgcrypt"))
-      (("@LIBZ@") (string-append zlib "/lib/libz"))
-      (("@GZIP@") (string-append gzip "/bin/gzip"))
-      (("@BZIP2@") (string-append bzip2 "/bin/bzip2"))
-      (("@XZ@") (string-append xz "/bin/xz"))
-      (("@NIX_INSTANTIATE@") "nix-instantiate"))  ;for (guix import nix)
-
-    ;; Augment the search path so Scheme code can be compiled.
-    (set! %load-path (cons out %load-path))
-    (set! %load-compiled-path (cons out %load-compiled-path))
-
-    ;; Compile the .scm files.  Hide warnings.
-    (parameterize ((current-warning-port (%make-void-port "w")))
-      ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
-      (let ((files (filter has-all-its-dependencies?
-                           (all-scheme-files out))))
-        (compile-files out out files
-
-                       #:workers (parallel-job-count)
-
-                       ;; Disable warnings.
-                       #:warning-options '()
-
-                       #:report-load
-                       (lambda (file total completed)
-                         (display #\cr log-port)
-                         (format log-port
-                                 "loading...\t~5,1f% of ~d files" ;FIXME: i18n
-                                 (* 100. (/ completed total)) total)
-                         (force-output log-port)
-                         (format debug-port "~%loading '~a'...~%" file))
-
-                       #:report-compilation
-                       (lambda (file total completed)
-                         (display #\cr log-port)
-                         (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
-                                 (* 100. (/ completed total)) total)
-                         (force-output log-port)
-                         (format debug-port "~%compiling '~a'...~%" file))))))
-
-  (newline)
-  #t)
-
-;;; pull.scm ends here