git-download: Support recursive clones.

* guix/git-download.scm (<git-reference>)[recursive?]: New field.
  (git-fetch): Add 'inputs' variable.  Add it to the #:inputs argument
  of 'build-expression->derivation'.  Augment builder with call to
  'set-path-environment-variable', and pass #:recursive? to
  'git-fetch'.
* guix/build/git.scm (git-fetch): Add #:recursive? parameter.  Pass
  --recursive when RECURSIVE? is true, and delete all the '.git' files.
This commit is contained in:
Ludovic Courtès 2014-06-27 23:04:48 +02:00
parent 20b1d19e10
commit 6750877f46
2 changed files with 48 additions and 16 deletions

View file

@ -28,23 +28,32 @@ (define-module (guix build git)
;;; Code: ;;; Code:
(define* (git-fetch url commit directory (define* (git-fetch url commit directory
#:key (git-command "git")) #:key (git-command "git") recursive?)
"Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit
identifier. Return #t on success, #f otherwise." identifier. When RECURSIVE? is true, all the sub-modules of URL are fetched,
recursively. Return #t on success, #f otherwise."
;; Disable TLS certificate verification. The hash of the checkout is known ;; Disable TLS certificate verification. The hash of the checkout is known
;; in advance anyway. ;; in advance anyway.
(setenv "GIT_SSL_NO_VERIFY" "true") (setenv "GIT_SSL_NO_VERIFY" "true")
(and (zero? (system* git-command "clone" url directory)) (let ((args `("clone" ,@(if recursive? '("--recursive") '())
(with-directory-excursion directory ,url ,directory)))
(system* git-command "tag" "-l") (and (zero? (apply system* git-command args))
(and (zero? (system* git-command "checkout" commit)) (with-directory-excursion directory
(begin (system* git-command "tag" "-l")
;; The contents of '.git' vary as a function of the current (and (zero? (system* git-command "checkout" commit))
;; status of the Git repo. Since we want a fixed output, this (begin
;; directory needs to be taken out. ;; The contents of '.git' vary as a function of the current
(delete-file-recursively ".git") ;; status of the Git repo. Since we want a fixed output, this
#t))))) ;; directory needs to be taken out.
(delete-file-recursively ".git")
(when 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$")))
#t))))))
;;; git.scm ends here ;;; git.scm ends here

View file

@ -20,11 +20,13 @@ (define-module (guix git-download)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-inputs)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (git-reference #:export (git-reference
git-reference? git-reference?
git-reference-url git-reference-url
git-reference-commit git-reference-commit
git-reference-recursive?
git-fetch)) git-fetch))
@ -39,8 +41,10 @@ (define-module (guix git-download)
(define-record-type* <git-reference> (define-record-type* <git-reference>
git-reference make-git-reference git-reference make-git-reference
git-reference? git-reference?
(url git-reference-url) (url git-reference-url)
(commit git-reference-commit)) (commit git-reference-commit)
(recursive? git-reference-recursive? ; whether to recurse into sub-modules
(default #f)))
(define* (git-fetch store ref hash-algo hash (define* (git-fetch store ref hash-algo hash
#:optional name #:optional name
@ -67,18 +71,37 @@ (define git-for-build
(git (module-ref distro 'git))) (git (module-ref distro 'git)))
(package-derivation store git system))))) (package-derivation store git system)))))
(define inputs
;; When doing 'git clone --recursive', we need sed, grep, etc. to be
;; available so that 'git submodule' works.
(if (git-reference-recursive? ref)
(standard-inputs (%current-system))
'()))
(let* ((command (string-append (derivation->output-path git-for-build) (let* ((command (string-append (derivation->output-path git-for-build)
"/bin/git")) "/bin/git"))
(builder `(begin (builder `(begin
(use-modules (guix build git)) (use-modules (guix build git)
(guix build utils)
(ice-9 match))
;; The 'git submodule' commands expects Coreutils, sed,
;; grep, etc. to be in $PATH.
(set-path-environment-variable "PATH" '("bin")
(match %build-inputs
(((names . dirs) ...)
dirs)))
(git-fetch ',(git-reference-url ref) (git-fetch ',(git-reference-url ref)
',(git-reference-commit ref) ',(git-reference-commit ref)
%output %output
#:recursive? ',(git-reference-recursive? ref)
#:git-command ',command)))) #:git-command ',command))))
(build-expression->derivation store (or name "git-checkout") builder (build-expression->derivation store (or name "git-checkout") builder
#:system system #:system system
#:local-build? #t #:local-build? #t
#:inputs `(("git" ,git-for-build)) #:inputs `(("git" ,git-for-build)
,@inputs)
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:recursive? #t #:recursive? #t