Commit | Line | Data |
---|---|---|
9b5b5c17 | 1 | ;;; GNU Guix --- Functional package management for GNU |
18524466 | 2 | ;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org> |
9b5b5c17 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix build git) | |
20 | #:use-module (guix build utils) | |
18524466 LC |
21 | #:use-module (srfi srfi-34) |
22 | #:use-module (ice-9 format) | |
9b5b5c17 LC |
23 | #:export (git-fetch)) |
24 | ||
25 | ;;; Commentary: | |
26 | ;;; | |
27 | ;;; This is the build-side support code of (guix git-download). It allows a | |
28 | ;;; Git repository to be cloned and checked out at a specific commit. | |
29 | ;;; | |
30 | ;;; Code: | |
31 | ||
32 | (define* (git-fetch url commit directory | |
6750877f | 33 | #:key (git-command "git") recursive?) |
9b5b5c17 | 34 | "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit |
6750877f LC |
35 | identifier. When RECURSIVE? is true, all the sub-modules of URL are fetched, |
36 | recursively. Return #t on success, #f otherwise." | |
03178aec LC |
37 | |
38 | ;; Disable TLS certificate verification. The hash of the checkout is known | |
39 | ;; in advance anyway. | |
40 | (setenv "GIT_SSL_NO_VERIFY" "true") | |
41 | ||
329dabe1 DM |
42 | (mkdir-p directory) |
43 | ||
18524466 LC |
44 | (guard (c ((invoke-error? c) |
45 | (format (current-error-port) | |
46 | "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%" | |
47 | (invoke-error-program c) | |
48 | (invoke-error-arguments c) | |
49 | (or (invoke-error-exit-status c) ;XXX: not quite accurate | |
50 | (invoke-error-stop-signal c) | |
51 | (invoke-error-term-signal c))) | |
52 | (delete-file-recursively directory) | |
53 | #f)) | |
54 | (with-directory-excursion directory | |
55 | (invoke git-command "init") | |
56 | (invoke git-command "remote" "add" "origin" url) | |
57 | (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) | |
58 | (invoke git-command "checkout" "FETCH_HEAD") | |
59 | (begin | |
60 | (setvbuf (current-output-port) 'line) | |
61 | (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") | |
62 | (invoke git-command "fetch" "origin") | |
63 | (invoke git-command "checkout" commit))) | |
64 | (when recursive? | |
65 | ;; Now is the time to fetch sub-modules. | |
c070d142 | 66 | (invoke git-command "submodule" "update" "--init" "--recursive") |
35a6dabc | 67 | |
18524466 LC |
68 | ;; In sub-modules, '.git' is a flat file, not a directory, |
69 | ;; so we can use 'find-files' here. | |
70 | (for-each delete-file-recursively | |
71 | (find-files directory "^\\.git$"))) | |
35a6dabc | 72 | |
329dabe1 DM |
73 | ;; The contents of '.git' vary as a function of the current |
74 | ;; status of the Git repo. Since we want a fixed output, this | |
75 | ;; directory needs to be taken out. | |
76 | (delete-file-recursively ".git") | |
18524466 | 77 | #t))) |
9b5b5c17 LC |
78 | |
79 | ;;; git.scm ends here |