git.fiddlerwoaroof.com
git.lisp
488cc861
 (in-package :fwoar.cl-git)
 
 (defun find-object-in-pack-files (repo id)
   (dolist (pack-file (pack-files repo))
     (multiple-value-bind (pack mid) (find-pack-containing pack-file id)
       (when pack
         (return-from find-object-in-pack-files
           (values pack mid))))))
 
 (defun edges-in-fanout (toc s sha)
   (let* ((fanout-offset (getf toc :fanout)))
     (file-position s (+ fanout-offset (* 4 (1- (elt sha 0)))))
991d0162
     (destructuring-bind ((_ . cur) (__ . next))
         (fwoar.bin-parser:extract '((cur 4 fwoar.bin-parser:be->int)
                                     (next 4 fwoar.bin-parser:be->int))
                                   s)
488cc861
       (declare (ignore _ __))
       (values cur next))))
 
 (defun find-sha-between-terms (toc s start end sha)
   (unless (>= start end)
     (let* ((sha-offset (getf toc :shas))
            (mid (floor (+ start end)
                        2)))
       (file-position s (+ sha-offset (* 20 mid)))
       (let ((sha-at-mid (read-bytes 20 'fwoar.bin-parser:byte-array-to-hex-string s)))
         (cond ((string< sha sha-at-mid)
                (find-sha-between-terms toc s start mid sha))
               ((string> sha sha-at-mid)
                (find-sha-between-terms toc s (1+ mid) end sha))
               (t mid))))))
 
 (defun find-pack-containing (pack-file id)
991d0162
   (with-open-file (s (index-file pack-file)
                      :element-type '(unsigned-byte 8))
488cc861
     (let ((binary-sha (ironclad:hex-string-to-byte-array id))
           (toc (idx-toc s)))
       (multiple-value-bind (_ end) (edges-in-fanout toc s binary-sha)
         (declare (ignore _))
         (let ((midpoint (find-sha-between-terms toc s 0 end id)))
           (and midpoint
                (values pack-file
                        midpoint)))))))
 
 (defun extract-object-from-pack (pack obj-number)
   (with-open-file (s (index-file pack) :element-type '(unsigned-byte 8))
     (with-open-file (p (pack-file pack) :element-type '(unsigned-byte 8))
       (let* ((toc (idx-toc s))
              (offset-offset (getf toc :4-byte-offsets)))
         (file-position s (+ offset-offset (* 4 obj-number)))
         (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int s)))
           (file-position p object-offset-in-pack)
           (read-object-from-pack p))))))
 
991d0162
 (defun seek-to-object-in-pack (idx-stream pack-stream obj-number)
   (let* ((toc (idx-toc idx-stream))
          (offset-offset (getf toc :4-byte-offsets)))
     (file-position idx-stream (+ offset-offset (* 4 obj-number)))
     (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int idx-stream)))
       (file-position pack-stream object-offset-in-pack))))
 
 (defun extract-object-metadata-from-pack (pack obj-number)
   (with-open-file (s (index-file pack) :element-type '(unsigned-byte 8))
     (with-open-file (p (pack-file pack) :element-type '(unsigned-byte 8))
       (seek-to-object-in-pack s p obj-number)
       (read-object-metadata-from-pack p))))
 
488cc861
 (defun extract-loose-object (repo id)
   (with-open-file (s (object repo id)
                      :element-type '(unsigned-byte 8))
     (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)
                       s)))
 
 (defun extract-object (repo id)
   (if (object repo id)
       (extract-loose-object repo id)
       (data-lens.lenses:view *object-data-lens*
                              (multiple-value-call 'extract-object-from-pack 
                                (find-object-in-pack-files (root repo) id)))))
 
 
 (defun turn-read-object-to-string (object)
   (data-lens.lenses:over *object-data-lens* 'babel:octets-to-string object))
 
 (defgeneric branches (repository)
   (:method ((repository repository))
     (get-local-branches (root repository))))
 
 (defgeneric branch (repository name)
   (:method ((repository repository) name)
     (second
      (find name (get-local-branches (root repository))
            :test 'equal
            :key 'car))))
 
 (defgeneric object (repository id)
   (:method ((repository repository) id)
     (car
      (uiop:directory*
       (merge-pathnames (loose-object-path (serapeum:concat id "*"))
                        (root repository))))))
 
 (defun fanout-table (s)
   (coerce (alexandria:assoc-value
            (fwoar.bin-parser:extract '((head 4)
                                        (version 4)
                                        (fanout-table #.(* 4 256) batch-4))
                                      s)
            'fanout-table)
           'vector))
 
 (defun get-object-size (bytes)
   (let ((first (elt bytes 0))
         (rest (subseq bytes 1)))
     (logior (ash (fwoar.bin-parser:be->int rest) 4)
             (logand first 15))))
 
 (defun get-object-type (bytes)
   (let ((first (elt bytes 0)))
     (ldb (byte 3 4)
          first)))
 
 (defun get-shas-before (fanout-table first-sha-byte s)
   (let ((num-before (elt fanout-table first-sha-byte))
         (num-total (alexandria:last-elt fanout-table)))
     (values (fwoar.bin-parser:extract (list (list 'shas (* 20 num-before) '->sha-string))
                                       s)
             (- num-total num-before))))
 
 (defun advance-past-crcs (obj-count s)
   (file-position s
                  (+ (file-position s)
                      (* 4 obj-count))))
 
 (defun object-offset (object-number s)
   (file-position s
                  (+ (file-position s)
                      (* (1- object-number)
                         4)))
   (fwoar.bin-parser:extract '((offset 4 fwoar.bin-parser:be->int))
                             s))
 
 (defun idx-toc (idx-stream)
   (let* ((object-count (progn (file-position idx-stream 1028)
                               (let ((buf (make-array 4)))
                                 (read-sequence buf idx-stream)
                                 (fwoar.bin-parser:be->int buf))))
          (signature 0)
          (version 4)
          (fanout 8)
          (shas (+ fanout
                    (* 4 256)))
          (packed-crcs (+ shas
                           (* 20 object-count)))
          (4-byte-offsets (+ packed-crcs
                              (* 4 object-count)))
          (8-byte-offsets-pro (+ 4-byte-offsets
                                  (* object-count 4)))  
          (pack-sha (- (file-length idx-stream)
                        40))
          (8-byte-offsets (when (/= 8-byte-offsets-pro pack-sha)
                            8-byte-offsets-pro))
          (idx-sha (- (file-length idx-stream)
                       20)))
     (values (sym->plist signature
                         version
                         fanout
                         shas
                         packed-crcs
                         4-byte-offsets
                         8-byte-offsets
                         pack-sha
                         idx-sha)
             object-count)))
 
 (defun collect-data (idx-toc s num)
   (let ((sha-idx (getf idx-toc :shas))
         (crc-idx (getf idx-toc :packed-crcs))
         (4-byte-offsets-idx (getf idx-toc :4-byte-offsets))
         (8-byte-offsets-idx (getf idx-toc :8-byte-offsets)))
991d0162
     (declare (ignore 8-byte-offsets-idx))
488cc861
     (values num
             (progn
               (file-position s (+ sha-idx (* num 20)))
               (read-bytes 20 'fwoar.bin-parser:byte-array-to-hex-string s))
             (progn
               (file-position s (+ crc-idx (* num 4)))
               (read-bytes 4 'identity s))
             (progn
               (file-position s (+ 4-byte-offsets-idx (* num 4)))
               (read-bytes 4 'fwoar.bin-parser:be->int s)))))
 
 (defun read-object-metadata-from-pack (s)
   (let* ((metadata (fwoar.bin-parser:extract-high s))
          (type (get-object-type metadata))
          (size (get-object-size metadata)))
     (values (cons :type (object-type->sym type))
             (cons :decompressed-size size))))
 
 (defun read-object-from-pack (s)
   (let* ((metadata (fwoar.bin-parser:extract-high s))
          (type (get-object-type metadata))
          (size (get-object-size metadata))
          (object-data (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s)))
     (list (cons :type (object-type->sym type))
           (cons :decompressed-size size)
           (cons :object-data object-data)
           (cons :raw-data object-data))))
 
 (defun get-first-commits-from-pack (idx pack n)
   (let ((toc (idx-toc idx))
         (result ()))
     (dotimes (i n (reverse result))
       (multiple-value-bind (_ sha __ offset) (collect-data toc idx i)
         (declare (ignore _ __))
         (file-position pack offset)
         (push `((:sha . ,sha)
                 ,@(multiple-value-list
                    (read-object-metadata-from-pack pack))
                 (:offset . ,offset))
2fb0a2fc
               result)))))
488cc861