01/09: scripts: hash: Add --git option. WIP

[Jan Nieuwenhuizen]

janneke pushed a commit to branch wip-bootstrap
in repository guix.

commit db43d71c8f3875dd961aebabcc4cb0bee091c4f4
Author: Jan Nieuwenhuizen <address@hidden>
Date:   Thu Nov 23 04:30:13 2017 +0100

    scripts: hash: Add --git option.  WIP
    
    Using
    
        guix hash -gr .
    
    procudes the same hash as doing something like
    
        git clone . tmp && guix hash -rx tmp && rm -r tmp
    
    * guix/git.scm (git-ls-files): New function.
    * guix/scripts/hash.scm (%options, show-help): Add `--git'.
    (guix-hash)[git-file?]: New function.
---
 guix/git.scm          | 12 +++++++++++-
 guix/scripts/hash.scm | 33 +++++++++++++++++++++++++++++----
 2 files changed, 40 insertions(+), 5 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 7a83b56..cb74565 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2017 Jan Nieuwenhuizen <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,7 +29,8 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (%repository-cache-directory
-            latest-repository-commit))
+            latest-repository-commit
+            git-ls-files))
 
 (define %repository-cache-directory
   (make-parameter "/var/cache/guix/checkouts"))
@@ -126,3 +128,11 @@ Git repositories are kept in the cache directory specified 
by
      (copy-to-store store cache-dir
                     #:url url
                     #:repository repository))))
+
+(define (git-ls-files directory)
+  (with-libgit2
+   (let* ((repository (repository-open directory))
+          (oid (reference-target (repository-head repository)))
+          (commit (commit-lookup repository oid))
+          (tree (commit-tree commit)))
+     (tree-list tree))))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index cae5d6b..f255820 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
-;;; Copyright © 2016 Jan Nieuwenhuizen <address@hidden>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts hash)
   #:use-module (guix base32)
+  #:use-module (guix git)
   #:use-module (guix hash)
   #:use-module (guix serialization)
   #:use-module (guix ui)
@@ -52,6 +53,8 @@ and 'hexadecimal' can be used as well).\n"))
   (format #t (G_ "
   -x, --exclude-vcs      exclude version control directories"))
   (format #t (G_ "
+  -g, --git              consider git files only"))
+  (format #t (G_ "
   -f, --format=FMT       write the hash in the given format"))
   (format #t (G_ "
   -r, --recursive        compute the hash on FILE recursively"))
@@ -68,6 +71,9 @@ 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 result)))
         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (define fmt-proc
@@ -117,6 +123,21 @@ and 'hexadecimal' can be used as well).\n"))
       (else
        #f)))
 
+  (define (git-file? directory)
+    (let* ((files (git-ls-files directory))
+           (directories (delete-duplicates (map dirname files)))
+           (prefix (if (string-suffix? "/" directory) directory
+                       (string-append directory "/")))
+           (prefix-length (string-length prefix)))
+      (lambda (file stat)
+        (case (stat:type stat)
+          ((directory)
+           (member (string-drop file prefix-length) directories))
+          ((regular)
+           (member (string-drop file prefix-length) files))
+          (else
+           #f)))))
+
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -124,9 +145,13 @@ and 'hexadecimal' can be used as well).\n"))
                             (_ #f))
                            (reverse opts)))
          (fmt  (assq-ref opts 'format))
-         (select? (if (assq-ref opts 'exclude-vcs?)
-                      (negate vcs-file?)
-                      (const #t))))
+         (select? (cond
+                   ((assq-ref opts 'exclude-vcs?)
+                    (negate vcs-file?))
+                   ((assq-ref opts 'git?)
+                    (git-file? (car args)))
+                   (else
+                    (const #t)))))
 
     (define (file-hash file)
       ;; Compute the hash of FILE.