(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)))))
(destructuring-bind ((_ . cur) (__ . next))
(fwoar.bin-parser:extract '((cur 4 fwoar.bin-parser:be->int)
(next 4 fwoar.bin-parser:be->int))
s)
(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)
(with-open-file (s (index-file pack-file)
:element-type '(unsigned-byte 8))
(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))))))
(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))))
(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)))
(declare (ignore 8-byte-offsets-idx))
(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))
result)))))