janneke pushed a commit to branch wip-bootstrap in repository guix. commit db43d71c8f3875dd961aebabcc4cb0bee091c4f4 Author: Jan Nieuwenhuizen <jann...@gnu.org> 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 <m.othac...@gmail.com> +;;; Copyright © 2017 Jan Nieuwenhuizen <jann...@gnu.org> ;;; ;;; 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 <l...@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nik...@karetnikov.org> -;;; Copyright © 2016 Jan Nieuwenhuizen <jann...@gnu.org> +;;; Copyright © 2016,2017 Jan Nieuwenhuizen <jann...@gnu.org> ;;; ;;; 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.