02/10: guix hash: Add --git option to hash a git checkout.

[Andy Wingo]

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

commit e75636e1a4e8eeec16e0b471cad7dcd4c721b158
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 3 21:57:24 2017 +0200

    guix hash: Add --git option to hash a git checkout.
    
    * guix/scripts/hash.scm (show-help, %options): Add -g option.
    (vcs-file?): Pull out to top.
    (guix-hash-git-checkout): New function.
    (guix-hash): Support hashing of Git URLs.
    * doc/guix.texi (Invoking guix hash): Document guix hash --git.
---
 doc/guix.texi         | 17 +++++++++++++
 guix/scripts/hash.scm | 67 ++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 65 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8523584..c0ffdfd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5386,6 +5386,23 @@ $ git clone http://example.org/foo.git
 $ cd foo
 $ guix hash -rx .
 @end example
+
+Hashing a git checkout is so common that it has its own alias:
+
address@hidden --git
address@hidden -g
+Clones the git repository at @var{file} into a temporary directory and
+recursively hashes it, excluding the @file{.git} subdirectory.  This is
+mainly useful if you want to get the Guix hash of the current Git
+checkout:
+
address@hidden
+$ git clone http://example.org/foo.git
+$ cd foo
+# Hack a bunch of things, make some commits
+$ guix hash -g .
address@hidden example
+
 @end table
 
 @node Invoking guix import
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index a048b53..f1ac3c3 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -25,6 +25,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix base16)
+  #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs files)
   #:use-module (ice-9 match)
@@ -32,7 +33,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
-  #:export (guix-hash))
+  #:export (guix-hash-git-checkout
+            guix-hash))
 
 
 ;;;
@@ -52,6 +54,9 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (_ "
+  -g, --git              clone the git repository at FILE and hash it
+                         (implies -r)"))
+  (format #t (_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +73,10 @@ and 'hexadecimal' can be used as well).\n"))
   (list (option '(#\x "exclude-vcs") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'exclude-vcs? #t result)))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git? #t
+                              (alist-cons 'exclude-vcs? #t result))))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -98,6 +107,35 @@ and 'hexadecimal' can be used as well).\n"))
 
 
 ;;;
+;;; Helpers.
+;;;
+
+(define (vcs-file? file stat)
+  (case (stat:type stat)
+    ((directory)
+     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+    ((regular)
+     ;; Git sub-modules have a '.git' file that is a regular text file.
+     (string=? (basename file) ".git"))
+    (else
+     #f)))
+
+(define* (recursive-hash file #:key (select? (const #t)))
+  (let-values (((port get-hash) (open-sha256-port)))
+    (write-file file port #:select? select?)
+    (force-output port)
+    (get-hash)))
+
+(define (guix-hash-git-checkout directory)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (let ((checkout (in-vicinity dir "git-checkout")))
+       (unless (zero? (system* "git" "clone" "--" directory checkout))
+         (leave (_ "git clone failed~%")))
+       (recursive-hash checkout #:select? (negate vcs-file?))))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -112,16 +150,6 @@ and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
-  (define (vcs-file? file stat)
-    (case (stat:type stat)
-      ((directory)
-       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-      ((regular)
-       ;; Git sub-modules have a '.git' file that is a regular text file.
-       (string=? (basename file) ".git"))
-      (else
-       #f)))
-
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -137,14 +165,15 @@ and 'hexadecimal' can be used as well).\n"))
       ;; Compute the hash of FILE.
       ;; Catch and gracefully report possible '&nar-error' conditions.
       (with-error-handling
-        (if (assoc-ref opts 'recursive?)
-            (let-values (((port get-hash) (open-sha256-port)))
-              (write-file file port #:select? select?)
-              (force-output port)
-              (get-hash))
-            (match file
-              ("-" (port-sha256 (current-input-port)))
-              (_   (call-with-input-file file port-sha256))))))
+        (cond
+         ((assoc-ref opts 'git?)
+          (guix-hash-git-checkout file))
+         ((assoc-ref opts 'recursive?)
+          (recursive-hash file #:select? select))
+         (else
+          (match file
+            ("-" (port-sha256 (current-input-port)))
+            (_   (call-with-input-file file port-sha256)))))))
 
     (match args
       ((file)