nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

git-download: 'git-fetch' really returns #f upon error. 

This allows the fallback code in (guix git-download) to actually run.
Regression introduced in commit 329dabe13b.

Fixes <https://bugs.gnu.org/33911>.
Reported by Björn Höfling <bjoern.hoefling@bjoernhoefling.de>.

* guix/build/git.scm (git-fetch): Guard against 'invoke-error?' and
really return #f upon failure.
This commit is contained in:
Ludovic Courtès 2019-01-05 23:04:58 +01:00
parent 210e43c762
commit 18524466bb
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 33 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
guix/build/git.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,6 +18,8 @@
(define-module (guix build git) (define-module (guix build git)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (srfi srfi-34)
#:use-module (ice-9 format)
#:export (git-fetch)) #:export (git-fetch))
;;; Commentary: ;;; Commentary:
@ -39,31 +41,41 @@ recursively. Return #t on success, #f otherwise."
(mkdir-p directory) (mkdir-p directory)
(with-directory-excursion directory (guard (c ((invoke-error? c)
(invoke git-command "init") (format (current-error-port)
(invoke git-command "remote" "add" "origin" url) "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
(if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) (invoke-error-program c)
(invoke git-command "checkout" "FETCH_HEAD") (invoke-error-arguments c)
(begin (or (invoke-error-exit-status c) ;XXX: not quite accurate
(setvbuf (current-output-port) 'line) (invoke-error-stop-signal c)
(format #t "Failed to do a shallow fetch; retrying a full fetch...~%") (invoke-error-term-signal c)))
(invoke git-command "fetch" "origin") (delete-file-recursively directory)
(invoke git-command "checkout" commit))) #f))
(when recursive? (with-directory-excursion directory
;; Now is the time to fetch sub-modules. (invoke git-command "init")
(unless (zero? (system* git-command "submodule" "update" (invoke git-command "remote" "add" "origin" url)
"--init" "--recursive")) (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
(error "failed to fetch sub-modules" url)) (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))
;; In sub-modules, '.git' is a flat file, not a directory, ;; In sub-modules, '.git' is a flat file, not a directory,
;; so we can use 'find-files' here. ;; so we can use 'find-files' here.
(for-each delete-file-recursively (for-each delete-file-recursively
(find-files directory "^\\.git$"))) (find-files directory "^\\.git$")))
;; The contents of '.git' vary as a function of the current ;; The contents of '.git' vary as a function of the current
;; status of the Git repo. Since we want a fixed output, this ;; status of the Git repo. Since we want a fixed output, this
;; directory needs to be taken out. ;; directory needs to be taken out.
(delete-file-recursively ".git") (delete-file-recursively ".git")
#t)) #t)))
;;; git.scm ends here ;;; git.scm ends here