nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

git-download: Rewrite 'git-predicate' using Guile-Git. 

Fixes <https://bugs.gnu.org/27925>.

* guix/git-download.scm (files->directory-tree)
(directory-in-tree?): Remove.
(git-file-list): New procedures.
(git-predicate): Use it instead of opening a pipe to 'git'.  Remove
directory tree hack and rely exclusively on inode/device numbers.
master
Ludovic Courtès 2018-09-12 23:56:34 +02:00
parent 3763e7716c
commit aed0a59405
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 42 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
guix/git-download.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; ;;;
@ -19,7 +19,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix git-download) (define-module (guix git-download)
#:use-module (guix build utils)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
@ -27,9 +26,8 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix modules) #:use-module (guix modules)
#:autoload (guix build-system gnu) (standard-packages) #:autoload (guix build-system gnu) (standard-packages)
#:use-module (git)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (git-reference #:export (git-reference
@ -153,41 +151,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;;; 'git-predicate'. ;;; 'git-predicate'.
;;; ;;;
(define (files->directory-tree files) (define (git-file-list directory)
"Return a tree of vhashes representing the directory listed in FILES, a list "Return the list of files checked in in the Git repository at DIRECTORY.
like '(\"a/b\" \"b/c/d\")." The result is similar to that of the 'git ls-files' command, except that it
(fold (lambda (file result) also includes directories, not just regular files. The returned file names
(let loop ((file (string-split file #\/)) are relative to DIRECTORY, which is not necessarily the root of the checkout."
(result result)) (let* ((directory (canonicalize-path directory))
(match file (dot-git (repository-discover directory))
((_) (top (dirname dot-git))
result) (repository (repository-open dot-git))
((directory children ...) (head (repository-head repository))
(match (vhash-assoc directory result) (oid (reference-target head))
(#f (commit (commit-lookup repository oid))
(vhash-cons directory (loop children vlist-null) (tree (commit-tree commit))
result)) (files (tree-list tree)))
((_ . previous) (repository-close! repository)
;; XXX: 'vhash-delete' is O(n). (if (string=? top directory)
(vhash-cons directory (loop children previous) files
(vhash-delete directory result))))) (let ((relative (string-append
(() (string-drop directory
result)))) (+ 1 (string-length top)))
vlist-null "/")))
files)) (filter-map (lambda (file)
(and (string-prefix? relative file)
(define (directory-in-tree? tree directory) (string-drop file (string-length relative))))
"Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed files)))))
in TREE."
(let loop ((directory (string-split directory #\/))
(tree tree))
(match directory
(()
#t)
((head . tail)
(match (vhash-assoc head tree)
((_ . sub-tree) (loop tail sub-tree))
(#f #f))))))
(define (git-predicate directory) (define (git-predicate directory)
"Return a predicate that returns true if a file is part of the Git checkout "Return a predicate that returns true if a file is part of the Git checkout
@ -195,43 +183,20 @@ living at DIRECTORY. Upon Git failure, return #f instead of a predicate.
The returned predicate takes two arguments FILE and STAT where FILE is an The returned predicate takes two arguments FILE and STAT where FILE is an
absolute file name and STAT is the result of 'lstat'." absolute file name and STAT is the result of 'lstat'."
(let* ((pipe (with-directory-excursion directory (let* ((files (git-file-list directory))
(open-pipe* OPEN_READ "git" "ls-files"))) (inodes (fold (lambda (file result)
(files (let loop ((lines '())) (let ((stat
(match (read-line pipe) (lstat (string-append directory "/"
((? eof-object?) file))))
(reverse lines)) (vhash-consv (stat:ino stat) (stat:dev stat)
(line result)))
(loop (cons line lines)))))) vlist-null
(directory-tree (files->directory-tree files)) files)))
(inodes (fold (lambda (file result) (lambda (file stat)
(let ((stat ;; Comparing file names is always tricky business so we rely on inode
(lstat (string-append directory "/" ;; numbers instead.
file)))) (match (vhash-assv (stat:ino stat) inodes)
(vhash-consv (stat:ino stat) (stat:dev stat) ((_ . dev) (= dev (stat:dev stat)))
result))) (#f #f)))))
vlist-null
files))
;; Note: For this to work we must *not* call 'canonicalize-path' on
;; DIRECTORY or we would get discrepancies of the returned lambda is
;; called with a non-canonical file name.
(prefix-length (+ 1 (string-length directory)))
(status (close-pipe pipe)))
(and (zero? status)
(lambda (file stat)
(match (stat:type stat)
('directory
(directory-in-tree? directory-tree
(string-drop file prefix-length)))
((or 'regular 'symlink)
;; Comparing file names is always tricky business so we rely on
;; inode numbers instead
(match (vhash-assv (stat:ino stat) inodes)
((_ . dev) (= dev (stat:dev stat)))
(#f #f)))
(_
#f))))))
;;; git-download.scm ends here ;;; git-download.scm ends here