guix/build/git.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
   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)
  21   #:use-module (srfi srfi-34)
  22   #:use-module (ice-9 format)
  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
  33                     #:key (git-command "git") recursive?)
  34   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
  35 identifier.  When RECURSIVE? is true, all the sub-modules of URL are fetched,
  36 recursively.  Return #t on success, #f otherwise."
  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
  42   (mkdir-p directory)
  43
  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.
  66         (invoke git-command "submodule" "update" "--init" "--recursive")
  67
  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$")))
  72
  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")
  77       #t)))
  78
  79 ;;; git.scm ends here