git: Implement git-tracked-files using guile-git.

* tissue/git.scm: Import (rnrs arithmetic bitwise), (srfi
srfi-9), (git), (git types), and selected symbols from (system
foreign) and (bytestructures guile).
(pointer->bytestructure, bytestructure->pointer, pointer->index-time,
pointer->index-entry, repository-index, index-version,
index-entry-count, index-entry, index-entries):
New functions.
(%oid, %index-time, %index-entry): New variables
(<index-time>, <index-entry>): New types.
(git-tracked-files): Implement using guile-git.

1 files changed, 140 insertions, 4 deletions

diff --git a/tissue/git.scm b/tissue/git.scm
index 8be3970..5cc8a52 100644
--- a/tissue/git.scm
+++ b/tissue/git.scm
@@ -17,13 +17,147 @@
 ;;; along with tissue.  If not, see <https://www.gnu.org/licenses/>.
 
 (define-module (tissue git)
+  #:use-module (rnrs arithmetic bitwise)
   #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-171)
+  #:use-module (git)
+  #:use-module (git types)
+  ;; There are many name conflicts between (system foreign). So, we
+  ;; carefully select a few and prefix the rest.
+  #:use-module ((system foreign) #:select (null-pointer?
+                                           pointer->string
+                                           make-pointer
+                                           dereference-pointer))
+  #:use-module ((system foreign) #:prefix foreign:)
+  #:use-module ((bytestructures guile) #:select (bs:pointer
+                                                 bs:struct
+                                                 bs:vector
+                                                 bytestructure-ref))
+  #:use-module ((bytestructures guile) #:prefix bs:)
   #:use-module (tissue utils)
   #:export (git-top-level
             git-tracked-files))
 
+;; We bind additional functions from libgit2 that are not already
+;; bound in guile-git. TODO: Contribute them to guile-git.
+
+(define pointer->bytestructure
+  (@@ (git structs) pointer->bytestructure))
+
+(define bytestructure->pointer
+  (@@ (git structs) bytestructure->pointer))
+
+(define %oid
+  (bs:vector 20 bs:uint8))
+
+(define %index-time
+  (bs:struct `((seconds ,bs:int32)
+               (nanoseconds ,bs:uint32))))
+
+(define %index-entry
+  (bs:struct `((ctime ,%index-time)
+               (mtime ,%index-time)
+               (dev ,bs:uint32)
+               (ino ,bs:uint32)
+               (mode ,bs:uint32)
+               (uid ,bs:uint32)
+               (gid ,bs:uint32)
+               (file-size ,bs:uint32)
+               (id ,%oid)
+               (flags ,bs:uint16)
+               (flags-extended ,bs:uint16)
+               (path ,(bs:pointer bs:uint8)))))
+
+(define-record-type <index-time>
+  (%make-index-time seconds nanoseconds)
+  index-time?
+  (seconds index-time-seconds)
+  (nanoseconds index-time-nanoseconds))
+
+(define (pointer->index-time pointer)
+  (if (null-pointer? pointer)
+      #f
+      (let ((bs (pointer->bytestructure pointer %index-time)))
+        (%make-index-time
+         (bytestructure-ref bs 'seconds)
+         (bytestructure-ref bs 'nanoseconds)))))
+
+(define-record-type <index-entry>
+  (%make-index-entry ctime mtime dev ino mode uid gid file-size id flags path)
+  index-entry?
+  (ctime index-entry-ctime)
+  (mtime index-entry-mtime)
+  (dev index-entry-dev)
+  (ino index-entry-ino)
+  (mode index-entry-mode)
+  (uid index-entry-uid)
+  (gid index-entry-gid)
+  (file-size index-entry-file-size)
+  (id index-entry-id)
+  (flags index-entry-flags)
+  (path index-entry-path))
+
+(define (pointer->index-entry pointer)
+  (if (null-pointer? pointer)
+      #f
+      (let* ((bs (pointer->bytestructure pointer %index-entry))
+             (flags (bytestructure-ref bs 'flags)))
+        (%make-index-entry
+         (pointer->index-time
+          (bytestructure->pointer (bytestructure-ref bs 'ctime)))
+         (pointer->index-time
+          (bytestructure->pointer (bytestructure-ref bs 'mtime)))
+         (bytestructure-ref bs 'dev)
+         (bytestructure-ref bs 'ino)
+         (bytestructure-ref bs 'mode)
+         (bytestructure-ref bs 'uid)
+         (bytestructure-ref bs 'gid)
+         (bytestructure-ref bs 'file-size)
+         (pointer->oid
+          (bytestructure->pointer (bytestructure-ref bs 'id)))
+         (if (zero? (logand flags
+                            (bitwise-arithmetic-shift 1 15)))
+             (list)
+             (list 'assume-valid))
+         (pointer->string
+          (make-pointer (bytestructure-ref bs 'path))
+          (bitwise-and flags (bitwise-not (bitwise-arithmetic-shift 1 13))))))))
+
+;; The repository-index function in guile-git has a bug. See
+;; https://gitlab.com/guile-git/guile-git/-/merge_requests/34 . To
+;; work around this, we redefine it here.
+(define repository-index
+  (let ((proc (libgit2->procedure* "git_repository_index" (list '* '*))))
+    (lambda (repository)
+      (let ((out (make-double-pointer)))
+        (proc out (repository->pointer repository))
+        (pointer->index (dereference-pointer out))))))
+
+(define index-version
+  (let ((proc (libgit2->procedure foreign:unsigned-int "git_index_version" (list '*))))
+    (lambda (index)
+      (proc (index->pointer index)))))
+
+(define index-entry-count
+  (compose (libgit2->procedure foreign:size_t "git_index_entrycount" (list '*))
+           index->pointer))
+
+(define index-entry
+  (let ((proc (libgit2->procedure '* "git_index_get_byindex" (list '* foreign:size_t))))
+    (lambda (index n)
+      (unless (= (index-version index) 2)
+        (error "Unsupported git index version:" (index-version index)))
+      (pointer->index-entry (proc (index->pointer index) n)))))
+
+(define (index-entries index)
+  "Return the list of all entries in INDEX, a <git-index> object. The
+return value is a list of <index-entry> objects."
+  (map (lambda (i)
+         (index-entry index i))
+       (iota (index-entry-count index))))
+
 (define (git-top-level)
   "Return the top-level directory of the current git
 repository."
@@ -37,7 +171,9 @@ repository."
       (loop (dirname curdir))))))
 
 (define (git-tracked-files)
-  "Return a list of all files tracked in the current git repository."
-  (call-with-input-pipe
-      (cut port-transduce (tmap identity) rcons get-line <>)
-    "git" "ls-files"))
+  "Return a list of all files tracked in the current git repository. The
+returned filenames are relative to the top-level directory of the
+current git repository and do not have a leading slash."
+  (map index-entry-path
+       (index-entries (repository-index
+                       (repository-open (git-top-level))))))