feat: continue implementing delta expansion

delta.lisp

@@ -5,13 +5,16 @@
    (%base :initarg :base :reader base)
    (%commands :initarg :commands :reader commands)
    (%src-size :initarg :src-size :reader src-size)
-   (%delta-size :initarg :delta-size :reader delta-size)))
+   (%delta-size :initarg :delta-size :reader delta-size))
+  (:documentation
+   "The base type for deltified git objects"))
 
 (defclass+ ofs-delta (delta)
   ())
 
 (defclass+ ref-delta (delta)
-  ())
+  ()
+  (:documentation "TODO: mostly unimplemented/untested"))
 
 (defun make-ofs-delta (base commands repository src-size delta-size)
   (fw.lu:new 'ofs-delta base commands repository src-size delta-size))
@@ -36,19 +39,22 @@
           :unless (zerop (aref bv ix))
             :sum (expt 2 n))))
 
-(defun expand-copy (copy)
-  (destructuring-bind (command layout numbers) copy
-    (let* ((next-idx 0)
-           (parts (map '(vector (unsigned-byte 8))
-                       (lambda (layout-bit)
-                         (if (= layout-bit 1)
-                             (prog1 (elt numbers next-idx)
-                               (incf next-idx))
-                             0))
-                       (reverse layout))))
-      (list command
-            (fwoar.bin-parser:le->int (subseq parts 0 4))
-            (fwoar.bin-parser:le->int (subseq parts 4))))))
+(defun trace-bases (pack delta)
+  (if (typep delta 'delta)
+      (let* ((offset (second (base delta)))
+             (o (extract-object-at-pos pack
+                                       offset
+                                       (make-instance 'git-ref
+                                                      :hash "00000000"
+                                                      :repo nil)))
+             (obj (serapeum:assocdr :object-data o))
+             (raw (serapeum:assocdr :raw-data o)))
+        (if (typep obj 'delta)
+            (apply-commands (trace-bases pack obj)
+                            (commands delta))
+            (apply-commands (trace-bases pack raw)
+                            (commands delta))))
+      delta))
 
 (defun partition-commands (data)
   (let ((idx 0))
@@ -72,10 +78,35 @@
                      (list :add
                            (coerce (loop repeat (bit-vector->int insts)
                                          collect (advance))
-                                   '(vector (unsigned-byte 8))))))))
+                                   '(vector (unsigned-byte 8)))))))
+             (expand-copy (copy)
+               (destructuring-bind (command layout numbers) copy
+                 (let* ((next-idx 0)
+                        (parts (map '(vector (unsigned-byte 8))
+                                    (lambda (layout-bit)
+                                      (if (= layout-bit 1)
+                                          (prog1 (elt numbers next-idx)
+                                            (incf next-idx))
+                                          0))
+                                    (reverse layout))))
+                   (list command
+                         (fwoar.bin-parser:le->int (subseq parts 0 4))
+                         (fwoar.bin-parser:le->int (subseq parts 4)))))))
       (loop while (< idx (length data))
             collect (get-command)))))
 
+(defun apply-commands (base commands)
+  (flexi-streams:with-output-to-sequence (s)
+    (flet ((do-copy (offset cnt)
+             (write-sequence (subseq base offset (+ offset cnt))
+                             s))
+           (do-add (data)
+             (write-sequence data s)))
+      (loop for (command . args) in commands
+            when (eql command :copy) do
+              (apply #'do-copy args)
+            when (eql command :add) do
+              (apply #'do-add args)))))
 
 (defun get-ofs-delta-offset (buf)
   (let* ((idx 0))

tests/git-objects.lisp

@@ -174,7 +174,6 @@
                     :pack pack-file))))
 
 (fiveam:def-test pack-files-offsets ()
-
   (let* ((expectations-file
            (asdf:system-relative-pathname
             :co.fwoar.cl-git/tests
@@ -187,3 +186,37 @@
                               (fwoar.cl-git::extract-object
                                (fwoar.cl-git::packed-ref *fake-repo-2* ref)))))))
     ))
+
+(fiveam:def-test pack-file-apply-delta-commands ()
+  (flet ((test-ref (ref)
+           (let* ((extracted-ref
+                    (fwoar.cl-git::extract-object
+                     (fwoar.cl-git::packed-ref :fwoar.cl-git.git-objects.pack-2 ref)))
+                  (base-desc (fwoar.cl-git::base extracted-ref))
+                  (pack (car (fwoar.cl-git::pack-files *fake-repo-2*)))
+                  (expectations-file
+                    (asdf:system-relative-pathname
+                     :co.fwoar.cl-git/tests
+                     (format nil "tests/sample-git-objects/blob-~a-fixture"
+                             (subseq ref 0 7))))
+                  (expectations
+                    (alexandria:read-file-into-byte-vector expectations-file)))
+             (5am:is
+              (serapeum:vector=
+               expectations
+               (fwoar.cl-git::trace-bases pack extracted-ref))))))
+    (test-ref "87c2b9b2dfaa1fbf66b3fe88d3a925593886b159")
+
+    (test-ref "9776df71b5ddf298c56e99b7291f9e68906cf049")
+
+    #+(or) ;; broken
+    (test-ref "31576396aff0fff28f69e0ef84571c0dc8cc43ec")
+
+    #+(or) ;; broken
+    (test-ref "c516dfc248544509c3ae58e3a8c2ab81c225aa9c")
+
+    #+(or) ;; broken
+    (test-ref "53d13ed284f8b57297d1b216e2bab7fb43f8db60")
+
+    #+(or) ;; broken
+    (test-ref "912d31a169ddf1fca122d4c6fe1b1e6be7cd1176")))

tests/sample-git-objects/blob-3157639-fixture

@@ -0,0 +1,65 @@
+(in-package :fwoar.cl-git)
+
+(defclass git-graph ()
+  ((%repo :initarg :repo :reader repo)
+   (%depth :initarg :depth :reader depth)
+   (%branches :reader branches)
+   (%node-cache :reader node-cache :initform (make-hash-table :test 'equal))
+   (%edge-cache :reader edge-cache :initform (make-hash-table :test 'equal))))
+
+(defmethod initialize-instance :after ((object git-graph) &key)
+  (setf (slot-value object '%branches)
+        (fw.lu:alist-string-hash-table
+         (funcall (data-lens:over
+                   (<>1 (data-lens:applying #'cons)
+                        (data-lens:transform-head
+                         (serapeum:op (subseq _1 0 (min (length _1) 7))))
+                        #'reverse))
+                  (branches (repo object))))))
+
+(defun git-graph (repo)
+  (fw.lu:new 'git-graph repo))
+
+(defun get-commit-parents (repository commit)
+  #+lispworks
+  (declare (notinline mismatch serapeum:string-prefix-p))
+  (map 'list 
+       (serapeum:op (second (partition #\space _)))
+       (remove-if-not (lambda (it)
+                        (serapeum:string-prefix-p "parent" it))
+                      (nth-value 1 (parse-commit
+                                    (split-object
+                                     (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)
+                                                       (loose-object repository
+                                                                     commit))))))))
+
+(defmethod cl-dot:graph-object-node ((graph git-graph) (commit string))
+  (alexandria:ensure-gethash commit
+                             (node-cache graph)
+                             (make-instance 'cl-dot:node
+                                            :attributes `(:label ,(gethash #1=(subseq commit 0 7)
+                                                                           (branches graph)
+                                                                           #1#)))))
+
+(defmethod cl-dot:graph-object-points-to ((graph git-graph) (commit string))
+  #+nil
+  (loop
+    for cur = (list commit) then parents
+    for parents = (let ((f (get-commit-parents (repo graph) (car cur))))
+                    f)
+    until (or (not parents)
+              (cdr parents))
+    finally (return (or parents
+                        (when (not (equal commit (car cur)))
+                          cur))))
+
+  (funcall (data-lens:<>1 (data-lens:over (serapeum:op
+                                            (setf (gethash (list commit _1)
+                                                           (edge-cache graph))
+                                                  t)
+                                            _1))
+                          (data-lens:exclude (serapeum:op
+                                               (gethash (list commit _1)
+                                                        (edge-cache graph))))
+                          (data-lens:over (serapeum:op (subseq _ 0 7))))
+           (get-commit-parents (repo graph) commit)))

tests/sample-git-objects/blob-53d13ed-fixture

@@ -0,0 +1,34 @@
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*-
+(in-package :asdf-user)
+
+(defsystem :cl-git
+    :description "A pure-Lisp git implementation"
+    :author "Ed L <[email protected]>"
+    :license "MIT"
+    :pathname #-fw.dev nil #+fw.dev #p"PROJECTS:cl-git;"
+    :depends-on (:alexandria
+                 :chipz
+                 :cl-dot
+                 :data-lens
+                 :fwoar-lisputils
+                 :fwoar-lisputils/bin-parser
+                 :ironclad
+                 :serapeum
+                 :split-sequence
+                 :uiop)
+    :components ((:file "package")
+                 (:file "util" :depends-on ("package"))
+
+                 ;; data model
+                 (:file "model" :depends-on ("package"))
+                 (:file "protocol" :depends-on ("package" "model"))
+                 (:file "repository" :depends-on ("package" "model"))
+                 (:file "tree" :depends-on ("package" "model"))
+                 (:file "commit" :depends-on ("package" "model"))
+
+               (:file "extract" :depends-on ("package" "commit" "tree"))
+                 (:file "branch" :depends-on ("package" "extract"))
+                 (:file "git" :depends-on ("package" "util" "model" "branch"))
+
+                 ;; stable programmer interface
+                 (:file "porcelain" :depends-on ("package" "git" "commit"))))

tests/sample-git-objects/blob-87c2b9b-fixture

@@ -0,0 +1,81 @@
+(in-package :fwoar.cl-git)
+
+(fw.lu:defun-ct batch-4 (bytes)
+  (mapcar 'fwoar.bin-parser:be->int
+          (serapeum:batches bytes 4)))
+
+(fw.lu:defun-ct batch-20 (bytes)
+  (serapeum:batches bytes 20))
+
+(defmacro sym->plist (&rest syms)
+  `(list ,@(loop for sym in syms
+                 append (list (alexandria:make-keyword sym)
+                              sym))))
+
+(defmacro inspect- (s form)
+  `(let ((result ,form))
+     (format ,s "~&~s (~{~s~^ ~})~%~4t~s~%"
+             ',form
+             ,(typecase form
+                (list `(list ',(car form) ,@(cdr form)))
+                (t `(list ,form)))
+             result)
+     result))
+
+(defun inspect-* (fn)
+  (lambda (&rest args)
+    (declare (dynamic-extent args))
+    (inspect- *trace-output*
+              (apply fn args))))
+
+(defun partition (char string &key from-end (with-offset nil wo-p))
+  (let ((pos (position char string :from-end from-end)))
+    (if pos
+        (if wo-p 
+            (list (subseq string 0 (+ pos with-offset 1))
+                  (subseq string (+ pos 1 with-offset)))
+            (list (subseq string 0 pos)
+                  (subseq string (1+ pos))))
+      (list string
+            nil))))
+
+(defun partition-subseq (subseq string &key from-end)
+  (let ((pos (search subseq string :from-end from-end)))
+    (if pos
+        (list (subseq string 0 pos)
+              (subseq string (+ (length subseq) pos)))
+      (list string
+            nil))))
+
+(serapeum:defalias ->sha-string
+  (data-lens:<>1 (data-lens:over 'fwoar.bin-parser:byte-array-to-hex-string)
+                 'batch-20))
+
+(defun read-bytes (count format stream)
+  (let ((seq (make-array count :element-type 'serapeum:octet)))
+    (read-sequence seq stream)
+    (funcall format
+             seq)))
+
+(defun sp-ob (ob-string)
+  (partition #\null
+             ob-string))
+
+(defun split-object (object-data)
+  (destructuring-bind (head tail)
+      (partition 0
+                 object-data)
+    (destructuring-bind (type length)
+        (partition #\space
+                   (babel:octets-to-string head :encoding :latin1))
+      (values tail
+              (list type
+                    (parse-integer length))))))
+
+(defun parse-commit (commit)
+  (destructuring-bind (metadata message)
+      (partition-subseq #(#\newline #\newline)
+                        commit #+(or)(babel:octets-to-string commit :encoding :latin1))
+    (values message
+            (map 'vector (serapeum:op (partition #\space _))
+                 (fwoar.string-utils:split #\newline metadata)))))

tests/sample-git-objects/blob-912d31a-fixture

@@ -0,0 +1,49 @@
+(in-package :fwoar.cl-git)
+
+(fw.lu:defun-ct batch-4 (bytes)
+  (mapcar 'fwoar.bin-parser:be->int
+          (serapeum:batches bytes 4)))
+
+(fw.lu:defun-ct batch-20 (bytes)
+  (serapeum:batches bytes 20))
+
+(defmacro sym->plist (&rest syms)
+  `(list ,@(loop for sym in syms
+                 append (list (alexandria:make-keyword sym)
+                              sym))))
+
+(defmacro inspect- (s form)
+  `(let ((result ,form))
+     (format ,s "~&~s (~{~s~^ ~})~%~4t~s~%"
+             ',form
+             ,(typecase form
+                (list `(list ',(car form) ,@(cdr form)))
+                (t `(list ,form)))
+             result)
+     result))
+
+(defun inspect-* (fn)
+  (lambda (&rest args)
+    (declare (dynamic-extent args))
+    (inspect- *trace-output*
+              (apply fn args))))
+
+(defun partition (char string &key from-end)
+  (let ((pos (position char string :from-end from-end)))
+    (if pos
+	      (list (subseq string 0 pos)
+	            (subseq string (1+ pos)))
+	      (list string
+	            nil))))
+
+(defun partition-subseq (subseq string &key from-end)
+  (let ((pos (search subseq string :from-end from-end)))
+    (if pos
+	      (list (subseq string 0 pos)
+	            (subseq string (+ (length subseq) pos)))
+	      (list string
+	            nil))))
+
+(serapeum:defalias ->sha-string
+  (data-lens:<>1 (data-lens:over 'fwoar.bin-parser:byte-array-to-hex-string)
+                 'batch-20))