05/06: guix: git: Support shallow git clones if a tag is available

[Andy Wingo]

wingo pushed a commit to branch wip-pam-elogind
in repository guix.

commit 57044324ed6ad47985919748d35d084db550652c
Author: Andy Wingo <address@hidden>
Date:   Tue Aug 18 10:03:06 2015 +0200

    guix: git: Support shallow git clones if a tag is available
    
    * guix/build/git.scm (git-fetch): Instead of cloning the remote repo, use 
the
      lower-level "init" / "fetch" / "checkout" operations.  This lets us make a
      shallow checkout if we are checking out a tag.
    
    * guix/git-download.scm (<git-reference>): Add tag field.
      (git-fetch): Support git references with tags but no commits.
---
 guix/build/git.scm    |   58 +++++++++++++++++++++++++++++++++----------------
 guix/git-download.scm |   10 ++++++-
 2 files changed, 47 insertions(+), 21 deletions(-)

diff --git a/guix/build/git.scm b/guix/build/git.scm
index 121f07a..1af547f 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -28,32 +28,52 @@
 ;;; Code:
 
 (define* (git-fetch url commit directory
-                    #:key (git-command "git") recursive?)
+                    #:key tag (git-command "git") recursive?)
   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
 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
   ;; in advance anyway.
   (setenv "GIT_SSL_NO_VERIFY" "true")
 
-  (let ((args `("clone" ,@(if recursive? '("--recursive") '())
-                ,url ,directory)))
-    (and (zero? (apply system* git-command args))
-         (with-directory-excursion directory
-           (system* git-command "tag" "-l")
-           (and (zero? (system* git-command "checkout" commit))
-                (begin
-                  ;; 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")
+  (mkdir directory)
+  (with-directory-excursion directory
+    (and (zero? (system* git-command "init"))
+         (zero? (system* git-command "remote" "add" "origin" url))
+         (cond
+          ;; If there's a tag, do a shallow fetch.  Otherwise we do a full
+          ;; fetch.
+          (tag
+           (and (zero? (system* git-command "fetch" "--depth=1" "origin" tag))
+                ;; Either there is no commit specified, in which case we are
+                ;; good, or there is a commit and it is the same as the tag,
+                ;; in which case we're still good, or there's a commit and
+                ;; it's under the tag so we have to unshallow the checkout and
+                ;; try again.
+                (if commit
+                    (or (zero? (system* git-command "checkout" commit))
+                        (and (zero? (system* git-command "fetch" 
"--unshallow"))
+                             (zero? (system* git-command "checkout" commit))))
+                    (zero? (system* git-command "checkout" "FETCH_HEAD")))))
+          (else
+           ;; Fall back to a full fetch.  In that case print available tags.
+           (and (zero? (system* git-command "fetch" "origin"))
+                (zero? (system* git-command "tag" "-l"))
+                (zero? (system* git-command "checkout" commit)))))
+         (or (not recursive?)
+             (zero? (system* git-command
+                             "submodule" "update" "--init" "--recursive")))
+         (begin
+           ;; 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")
 
-                  (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))))))
+           (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
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 0f2218c..43bc466 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -28,6 +28,7 @@
             git-reference?
             git-reference-url
             git-reference-commit
+            git-reference-tag
             git-reference-recursive?
 
             git-fetch))
@@ -44,7 +45,8 @@
   git-reference make-git-reference
   git-reference?
   (url        git-reference-url)
-  (commit     git-reference-commit)
+  (commit     git-reference-commit (default #f))
+  (tag        git-reference-tag (default #f))
   (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
               (default #f)))
 
@@ -81,8 +83,12 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
                                           dirs)))
 
         (git-fetch '#$(git-reference-url ref)
-                   '#$(git-reference-commit ref)
+                   (or '#$(git-reference-commit ref)
+                       '#$(git-reference-tag ref))
                    #$output
+                   ;; FIXME: Pass #:tag when fixed daemons are widely
+                   ;; deployed.
+                   ;; #:tag '#$(git-reference-tag ref)
                    #:recursive? '#$(git-reference-recursive? ref)
                    #:git-command (string-append #+git "/bin/git"))))