├── .projectile
├── docs
    ├── CNAME
    ├── index.org
    ├── static
    │   └── style.css
    └── index.html
├── .gitignore
├── types.lisp
├── tests
    ├── sample-git-objects
    │   ├── hello-world-pack.idx
    │   ├── hello-world-pack.pack
    │   ├── hello-world-tree.git-obj
    │   ├── hello-world-commit.git-obj
    │   ├── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx
    │   ├── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack
    │   ├── hello-world-pack.txt
    │   ├── blob-53d13ed-fixture
    │   ├── blob-912d31a-fixture
    │   ├── blob-87c2b9b-fixture
    │   ├── blob-3157639-fixture
    │   ├── blob-c516dfc-fixture
    │   ├── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.delta-bases
    │   └── blob-9776df7-fixture
    ├── tests.lisp
    ├── branch-resolution.lisp
    └── git-objects.lisp
├── blob.lisp
├── .github
    └── workflows
    │   └── test.yaml
├── undelta.lisp
├── ref.lisp
├── docker-run
    └── main.lisp
├── LICENSE
├── repository.lisp
├── protocol.lisp
├── extract.lisp
├── branch.lisp
├── package.lisp
├── commit.lisp
├── co.fwoar.cl-git.asd
├── tree.lisp
├── util.lisp
├── graph.lisp
├── git.lisp
├── model.lisp
├── porcelain.lisp
├── delta.lisp
├── README.org
└── pack.lisp


/.projectile:
--------------------------------------------------------------------------------
1 | 


--------------------------------------------------------------------------------
/docs/CNAME:
--------------------------------------------------------------------------------
1 | cl-git.fiddlerwoaroof.com


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.fasl
3 | *.64xfasl
4 | 


--------------------------------------------------------------------------------
/types.lisp:
--------------------------------------------------------------------------------
1 | (in-package :fwoar.cl-git.types)
2 | 
3 | (deftype octet ()
4 |   '(unsigned-byte 8))
5 | 


--------------------------------------------------------------------------------
/docs/index.org:
--------------------------------------------------------------------------------
1 | #+HTML_HEAD: <link rel="stylesheet" href="/static/style.css" type="text/css" />
2 | 
3 | * CL Git!
4 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/hello-world-pack.idx:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/hello-world-pack.idx


--------------------------------------------------------------------------------
/tests/sample-git-objects/hello-world-pack.pack:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/hello-world-pack.pack


--------------------------------------------------------------------------------
/tests/sample-git-objects/hello-world-tree.git-obj:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/hello-world-tree.git-obj


--------------------------------------------------------------------------------
/tests/sample-git-objects/hello-world-commit.git-obj:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/hello-world-commit.git-obj


--------------------------------------------------------------------------------
/tests/tests.lisp:
--------------------------------------------------------------------------------
1 | (defpackage :fwoar.cl-git.tests
2 |   (:use :cl )
3 |   (:export ))
4 | (in-package :fwoar.cl-git.tests)
5 | 
6 | (5am:def-suite :fwoar.cl-git
7 |   :description "tests of cl-git")
8 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx


--------------------------------------------------------------------------------
/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/HEAD/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack


--------------------------------------------------------------------------------
/tests/sample-git-objects/hello-world-pack.txt:
--------------------------------------------------------------------------------
1 | 7d7b56a6a64e090041f55293511f48aba6699f1a commit 163 137 12
2 | 4b5fa63702dd96796042e92787f464e28f09f17d blob   13 22 149
3 | 1da546ab4697b719efb62f11fd785d6ad3b226d2 tree   29 40 171
4 | non delta: 3 objects
5 | .git/objects/pack/pack-9560f994ee4405c39b0eb9857c81c764aa96323a.pack: ok
6 | 


--------------------------------------------------------------------------------
/blob.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git.blob)
 2 | 
 3 | (fwoar.cl-git.utils:defclass+ blob (fwoar.cl-git::git-object)
 4 |   ((%data :reader data :initarg :data)))
 5 | 
 6 | (defmethod -extract-object-of-type ((type (eql :blob)) s repository &key)
 7 |   (blob s))
 8 | 
 9 | (defcomponents blob (object _)
10 |   ((eql :data) (data object)))
11 | 


--------------------------------------------------------------------------------
/.github/workflows/test.yaml:
--------------------------------------------------------------------------------
 1 | name: Lisp CI
 2 | 
 3 | on:
 4 |   push:
 5 |     branches: [ main ]
 6 |   pull_request:
 7 |     branches: [ main ]
 8 | 
 9 | jobs:
10 |   test:
11 |     runs-on: ubuntu-latest
12 | 
13 |     steps:
14 |     - uses: actions/checkout@v4
15 |     - name: Log into registry
16 |       run: echo "${{ secrets.GITHUB_TOKEN }}" | docker login docker.pkg.github.com -u ${{ github.actor }} --password-stdin
17 |     - name: Run tests
18 |       run: docker run -v $PWD/docker-run:/code  docker.pkg.github.com/fiddlerwoaroof/sbcl-workspace/sbcl-static:latest --load /code/main.lisp --quit
19 | 


--------------------------------------------------------------------------------
/undelta.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defun offset-distance (vec)
 4 |   (+ (loop for v across vec
 5 |            for sum = (logand 127 v)
 6 |              then (+ (ash sum 7)
 7 |                      (logand 127 v))
 8 |            finally (return sum))
 9 |      (loop for x from 1 below 2
10 |            sum (expt 2 (* 7 x)))))
11 | 
12 | (defun extract-offset-to-base (s)
13 |   (offset-distance
14 |    (fwoar.bin-parser:extract-high s)))
15 | 
16 | (defun object-metadata-at-offset (base-position offset s)
17 |   (file-position s (- base-position offset))
18 |   (read-object-metadata-from-pack s))
19 | 


--------------------------------------------------------------------------------
/ref.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git.ref)
 2 | 
 3 | (defclass ref ()
 4 |   ((%repo :initarg :repo :reader ref-repo)
 5 |    (%hash :initarg :hash :reader ref-hash)))
 6 | (defclass loose-ref (ref)
 7 |   ((%file :initarg :file :reader loose-ref-file)))
 8 | 
 9 | (defmethod print-object ((obj ref) s)
10 |   (print-unreadable-object (obj s :type t :identity t)
11 |     (format s "~a of ~a"
12 |             (subseq (ref-hash obj) 0 6)
13 |             (ref-repo obj)
14 |             #+(or)
15 |             (serapeum:string-replace (namestring (user-homedir-pathname))
16 |                                      (root-of (ref-repo obj))
17 |                                      "~/"))))
18 | 
19 | (defmethod fwoar.cl-git:component ((component (eql :hash)) (object ref))
20 |   (ref-hash object))
21 | 


--------------------------------------------------------------------------------
/docker-run/main.lisp:
--------------------------------------------------------------------------------
 1 | #.(handler-case (progn
 2 |                   (fwoar.repl-utils:clone "https://github.com/fiddlerwoaroof/fwoar.lisputils.git" "fwoar-lisputils")
 3 |                   (fwoar.repl-utils:github "fiddlerwoaroof" "cl-git")
 4 |                   (ql:update-client :prompt nil)
 5 |                   (ql:update-all-dists :prompt nil)
 6 |                   (ql:quickload :co.fwoar.cl-git)
 7 |                   (ql:quickload :co.fwoar.cl-git/tests)
 8 |                   nil)
 9 |     (serious-condition (c)
10 |       (format t "~&Exiting on condition: ~s~%" c)
11 |       (sb-ext:exit :code 40)))
12 | 
13 | (handler-case (alexandria:if-let ((results (5am:run :fwoar.cl-git)))
14 |                 (sb-ext:exit
15 |                  :code (if (5am:explain! results)
16 |                            0
17 |                            42))
18 |                 (sb-ext:exit :code 41))
19 |   (serious-condition (c)
20 |     (format t "~&Exiting on condition: ~s~%" c)
21 |     (sb-ext:exit :code 43)))
22 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | MIT License
 2 | 
 3 | Copyright (c) 2019 Edward Langley
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/repository.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defun root-of (repo)
 4 |   (typecase repo
 5 |     (repository (root repo))
 6 |     ((or pathname string) (namestring
 7 |                            (truename repo)))))
 8 | 
 9 | (defgeneric ref (repo id)
10 |   (:documentation "Given a REPOsitory and a ref ID return the ref-id object.")
11 |   (:method ((repo git-repository) (id string))
12 |     (or (alexandria:when-let ((object-file (loose-object repo id)))
13 |           (make-instance 'loose-ref
14 |                          :repo repo
15 |                          :hash (concatenate 'string
16 |                                             (subseq id 0 2)
17 |                                             (pathname-name object-file))
18 |                          :file object-file))
19 |         (packed-ref repo id))))
20 | 
21 | (defvar *ref-intern-table*
22 |   (make-hash-table :test 'equal #+sbcl :weakness #+sbcl :key-and-value))
23 | 
24 | (defun ensure-ref (thing &optional (repo *git-repository*))
25 |   (typecase thing
26 |     (fwoar.cl-git.ref:ref thing)
27 |     (t (alexandria:when-let ((maybe-result (ref repo thing)))
28 |          (alexandria:ensure-gethash (component :hash maybe-result)
29 |                                     *ref-intern-table*
30 |                                     maybe-result)))))
31 | 
32 | (defun ensure-repository (thing)
33 |   (repository thing))
34 | 


--------------------------------------------------------------------------------
/protocol.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git.protocol)
 2 | 
 3 | (defgeneric -extract-object-of-type (type s repository &key  &allow-other-keys)
 4 |   (:method :around (type s repository &key hash)
 5 |     (let ((result (call-next-method)))
 6 |       (prog1 result
 7 |         (when (typep result 'fwoar.cl-git:git-object)
 8 |           (setf (fwoar.cl-git:hash result) hash)))))
 9 | 
10 | 
11 |   (:method ((type (eql :tag)) s repository &key)
12 |     s))
13 | 
14 | (defgeneric component (component object)
15 |   (:argument-precedence-order object component)
16 |   (:method (component (object fwoar.cl-git.ref:ref))
17 |     (component component (fwoar.cl-git:extract-object object)))
18 |   (:method ((component sequence) object)
19 |     (reduce (lambda (cur next)
20 |               (component next cur))
21 |             component
22 |             :initial-value object)))
23 | 
24 | 
25 | (defmacro defcomponent (component &body body)
26 |   (declare (ignore component body))
27 |   (error "defcomponent not available on its own"))
28 | (defmacro defcomponents (class (object-sym component-sym) &body clauses)
29 |   `(macrolet ((defcomponent (component &body component-body)
30 |                 `(defmethod component ((,',component-sym ,component)
31 |                                        (,',object-sym ,',class))
32 |                    ,@component-body)))
33 |      ,@(loop for (component . component-body) in clauses
34 |              collect `(defcomponent ,component
35 |                         ,@component-body))))
36 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-53d13ed-fixture:
--------------------------------------------------------------------------------
 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*-
 2 | (in-package :asdf-user)
 3 | 
 4 | (defsystem :cl-git
 5 |     :description "A pure-Lisp git implementation"
 6 |     :author "Ed L <edward@elangley.org>"
 7 |     :license "MIT"
 8 |     :pathname #-fw.dev nil #+fw.dev #p"PROJECTS:cl-git;"
 9 |     :depends-on (:alexandria
10 |                  :chipz
11 |                  :cl-dot
12 |                  :data-lens
13 |                  :fwoar-lisputils
14 |                  :fwoar-lisputils/bin-parser
15 |                  :ironclad
16 |                  :serapeum
17 |                  :split-sequence
18 |                  :uiop)
19 |     :components ((:file "package")
20 |                  (:file "util" :depends-on ("package"))
21 | 
22 |                  ;; data model
23 |                  (:file "model" :depends-on ("package"))
24 |                  (:file "protocol" :depends-on ("package" "model"))
25 |                  (:file "repository" :depends-on ("package" "model"))
26 |                  (:file "tree" :depends-on ("package" "model"))
27 |                  (:file "commit" :depends-on ("package" "model"))
28 | 
29 |                (:file "extract" :depends-on ("package" "commit" "tree"))
30 |                  (:file "branch" :depends-on ("package" "extract"))
31 |                  (:file "git" :depends-on ("package" "util" "model" "branch"))
32 | 
33 |                  ;; stable programmer interface
34 |                  (:file "porcelain" :depends-on ("package" "git" "commit"))))
35 | 


--------------------------------------------------------------------------------
/tests/branch-resolution.lisp:
--------------------------------------------------------------------------------
 1 | (defpackage :fwoar.cl-git.branch-resolution
 2 |   (:use :cl )
 3 |   (:export ))
 4 | (in-package :fwoar.cl-git.branch-resolution)
 5 | 
 6 | (defclass fake-repository (fwoar.cl-git::repository)
 7 |   ())
 8 | (defclass fake-ref ()
 9 |   ((%repository :initarg :repository :reader repository)
10 |    (%id :initarg :id :reader id)
11 |    (%parents :initarg :parents :reader parents :initform ())))
12 | 
13 | (defparameter *expected-branches*
14 |   '(("master" "ref1")
15 |     ("other" "ref2")))
16 | 
17 | (defmethod fwoar.cl-git::repository ((object symbol))
18 |   (fwoar.cl-git::resolve-repository object))
19 | (defmethod fwoar.cl-git::resolve-repository fwoar.cl-git::alts :branch-resolution
20 |     ((o (eql :branch-resolution)))
21 |   (make-instance 'fake-repository :root "the-root"))
22 | (defmethod fwoar.cl-git::branches ((repository fake-repository))
23 |   *expected-branches*)
24 | (defmethod fwoar.cl-git::ref ((repository fake-repository) id)
25 |   (fw.lu:new 'fake-ref repository id))
26 | 
27 | (fiveam:def-suite :fwoar.cl-git.branch-resolution
28 |   :description "testing branch resolution"
29 |   :in :fwoar.cl-git)
30 | (fiveam:in-suite :fwoar.cl-git.branch-resolution)
31 | 
32 | (fiveam:def-test simple ()
33 |   (5am:is (typep (co.fwoar.git:with-repository (:branch-resolution)
34 |                    (co.fwoar.git:repository))
35 |                  'fake-repository))
36 |   (5am:is (equal *expected-branches*
37 |                  (co.fwoar.git:with-repository (:branch-resolution)
38 |                    (co.fwoar.git:git (branches))))))
39 | 


--------------------------------------------------------------------------------
/extract.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defun extract-object-of-type (type s repository pos packfile ref delta-base)
 4 |   (with-simple-restart (continue "Skip object of type ~s at position ~d"
 5 |                                  type
 6 |                                  pos)
 7 |     (-extract-object-of-type (object-type->sym type)
 8 |                              s
 9 |                              repository
10 |                              :offset-from pos
11 |                              :packfile packfile
12 |                              :hash (ref-hash ref)
13 |                              :base delta-base)))
14 | 
15 | (defun extract-loose-object (repo file ref)
16 |   (with-open-file (s file :element-type '(unsigned-byte 8))
17 |     (alexandria:when-let ((result (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)
18 |                                                     s)))
19 |       (destructuring-bind (type rest)
20 |           (partition (char-code #\space) result)
21 |         (extract-object-of-type (object-type->sym (babel:octets-to-string type))
22 |                                 (elt (partition 0 rest)
23 |                                      1)
24 |                                 repo
25 |                                 0
26 |                                 nil
27 |                                 ref
28 |                                 nil)))))
29 | 
30 | (defgeneric extract-object (object)
31 |   (:method ((object loose-ref))
32 |     (extract-loose-object (ref-repo object)
33 |                           (fwoar.cl-git.ref:loose-ref-file object)
34 |                           object)))
35 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-912d31a-fixture:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (fw.lu:defun-ct batch-4 (bytes)
 4 |   (mapcar 'fwoar.bin-parser:be->int
 5 |           (serapeum:batches bytes 4)))
 6 | 
 7 | (fw.lu:defun-ct batch-20 (bytes)
 8 |   (serapeum:batches bytes 20))
 9 | 
10 | (defmacro sym->plist (&rest syms)
11 |   `(list ,@(loop for sym in syms
12 |                  append (list (alexandria:make-keyword sym)
13 |                               sym))))
14 | 
15 | (defmacro inspect- (s form)
16 |   `(let ((result ,form))
17 |      (format ,s "~&~s (~{~s~^ ~})~%~4t~s~%"
18 |              ',form
19 |              ,(typecase form
20 |                 (list `(list ',(car form) ,@(cdr form)))
21 |                 (t `(list ,form)))
22 |              result)
23 |      result))
24 | 
25 | (defun inspect-* (fn)
26 |   (lambda (&rest args)
27 |     (declare (dynamic-extent args))
28 |     (inspect- *trace-output*
29 |               (apply fn args))))
30 | 
31 | (defun partition (char string &key from-end)
32 |   (let ((pos (position char string :from-end from-end)))
33 |     (if pos
34 | 	      (list (subseq string 0 pos)
35 | 	            (subseq string (1+ pos)))
36 | 	      (list string
37 | 	            nil))))
38 | 
39 | (defun partition-subseq (subseq string &key from-end)
40 |   (let ((pos (search subseq string :from-end from-end)))
41 |     (if pos
42 | 	      (list (subseq string 0 pos)
43 | 	            (subseq string (+ (length subseq) pos)))
44 | 	      (list string
45 | 	            nil))))
46 | 
47 | (serapeum:defalias ->sha-string
48 |   (data-lens:<>1 (data-lens:over 'fwoar.bin-parser:byte-array-to-hex-string)
49 |                  'batch-20))
50 | 


--------------------------------------------------------------------------------
/branch.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defun get-local-unpacked-branches (repository)
 4 |   (mapcar (data-lens:juxt #'pathname-name
 5 |                           (alexandria:compose #'serapeum:trim-whitespace
 6 |                                               #'alexandria:read-file-into-string))
 7 |           (uiop:directory*
 8 |            (merge-pathnames "refs/heads/*"
 9 |                             (root repository)))))
10 | 
11 | (defun get-local-packed-branches (repository)
12 |   (let* ((packed-ref-file-name (merge-pathnames "packed-refs"
13 |                                                 (root repository))))
14 |     (when (probe-file packed-ref-file-name)
15 |       (with-open-file (s packed-ref-file-name)
16 |         (loop for line = (read-line s nil)
17 |               for parts = (partition #\space line)
18 |               for branch-name = (second parts)
19 |               while line
20 |               unless (alexandria:starts-with-subseq "#" line)
21 |                 when (alexandria:starts-with-subseq "refs/heads" branch-name)
22 |                   collect (list (subseq branch-name
23 |                                         (1+ (position #\/ branch-name
24 |                                                       :from-end t)))
25 |                                 (first parts)))))))
26 | 
27 | (defun get-local-branches (repository)
28 |   (append (get-local-unpacked-branches repository)
29 |           (get-local-packed-branches repository)))
30 | 
31 | (defgeneric branches (repository)
32 |   (:method ((repository git-repository))
33 |     (get-local-branches repository)))
34 | 
35 | (defgeneric branch (repository name)
36 |   (:method ((repository git-repository) name)
37 |     (second
38 |      (find name (get-local-branches repository)
39 |            :test 'equal
40 |            :key 'car))))
41 | 


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | (defpackage :fwoar.cl-git.package
 2 |   (:use :cl)
 3 |   (:export))
 4 | (in-package :fwoar.cl-git.package)
 5 | 
 6 | (defpackage :fwoar.cl-git.protocol
 7 |   (:use :cl)
 8 |   (:export #:-extract-object-of-type #:component #:defcomponents))
 9 | 
10 | (defpackage :fwoar.cl-git.blob
11 |   (:use :cl :fwoar.cl-git.protocol)
12 |   (:export #:blob #:data))
13 | 
14 | (defpackage :fwoar.cl-git.commit
15 |   (:use :cl :fwoar.cl-git.protocol)
16 |   (:export #:git-commit #:metadata #:data))
17 | 
18 | (defpackage :fwoar.cl-git.delta
19 |   (:use :cl :fwoar.cl-git.protocol)
20 |   (:export #:delta #:repository #:base #:commands #:src-size
21 |            #:delta-size #:resolve-delta))
22 | 
23 | (defpackage :fwoar.cl-git.pack
24 |   (:use :cl)
25 |   (:export #:pack #:pack-file #:index-file #:idx-toc
26 |            #:with-pack-streams #:seek-to-object-in-pack #:packed-ref
27 |            #:packed-ref-pack #:packed-ref-offset #:extract-object #:ref
28 |            #:loose-ref #:extract-object-at-pos #:raw-object-for-ref))
29 | 
30 | (defpackage :fwoar.cl-git.ref
31 |   (:use :cl :fwoar.cl-git.protocol)
32 |   (:export #:ref #:loose-ref #:ref-repo #:ref-hash #:loose-ref-file))
33 | 
34 | (defpackage :fwoar.cl-git
35 |   (:use :cl :fwoar.cl-git.protocol)
36 |   (:import-from :fwoar.cl-git.commit #:git-commit)
37 |   (:import-from :fwoar.cl-git.pack #:packed-ref)
38 |   (:import-from :fwoar.cl-git.ref #:loose-ref #:ref-hash #:ref-repo)
39 |   (:export #:ensure-ref #:repository #:*want-delta* #:git-object #:hash
40 |            #:*git-encoding* #:git-commit #:ref #:component #:*git-repository*
41 |            #:extract-object #:git-tree #:blob))
42 | 
43 | (defpackage :fwoar.cl-git.types
44 |   (:use :cl )
45 |   (:export #:octet))
46 | 
47 | (defpackage :cl-git-user
48 |   (:use :cl :fwoar.cl-git))
49 | 
50 | (defpackage :co.fwoar.git
51 |   (:use)
52 |   (:export #:show #:branch #:branches #:commit-parents #:in-repository
53 |            #:with-repository #:current-repository #:show-repository #:git
54 |            #:tree #:contents #:component #:rev-list #:repository #:parents
55 |            #:filter-tree))
56 | 


--------------------------------------------------------------------------------
/commit.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git.commit)
 2 | 
 3 | (defclass git-commit (fwoar.cl-git:git-object)
 4 |   ((%metadata :initarg :metadata :reader metadata)
 5 |    (%data :initarg :data :reader data)))
 6 | 
 7 | (defun git-commit (hash metadata data)
 8 |   (fw.lu:new 'git-commit hash metadata data))
 9 | 
10 | (defun clamp-string (s len)
11 |   (subseq s 0 (min len (length s))))
12 | 
13 | (defmethod print-object ((o git-commit) s)
14 |   (if *print-readably*
15 |       (format s "#.(git-commit ~<~s~_~s~_~s~:>)"
16 |               (list (fwoar.cl-git:hash o)
17 |                     (metadata o)
18 |                     (data o)))
19 |       (print-unreadable-object (o s :type t :identity t)
20 |         (format s "~a" (format nil "~7,1,1,'x@a" (clamp-string (fwoar.cl-git:hash o) 7))))))
21 | 
22 | (defun parse-commit (commit)
23 |   (destructuring-bind (metadata message)
24 |       (fwoar.cl-git.utils:partition-subseq
25 |        #(#\newline #\newline)
26 |        commit
27 |        #+(or)(babel:octets-to-string commit :encoding :latin1))
28 |     (values message
29 |             (map 'vector
30 |                  (serapeum:op (fwoar.string-utils:partition #\space _))
31 |                  (fwoar.string-utils:split #\newline metadata)))))
32 | 
33 | (defun make-commit (data hash)
34 |   (multiple-value-bind (message metadata)
35 |       (parse-commit data)
36 |     (git-commit hash metadata message)))
37 | 
38 | (defmethod -extract-object-of-type
39 |     ((type (eql :commit)) s repository &key hash)
40 |   (make-commit (babel:octets-to-string s :encoding fwoar.cl-git:*git-encoding*)
41 |                hash))
42 | 
43 | (defcomponents git-commit (object _)
44 |   ((eql :tree) (fwoar.cl-git:ensure-ref
45 |                 (cadr
46 |                  (fw.lu:v-assoc :tree (metadata object)
47 |                                 :test 'string-equal))))
48 | 
49 |   ((eql :author) (second
50 |                   (fw.lu:v-assoc :author (metadata object)
51 |                                  :test 'string-equal)))
52 | 
53 |   ((eql :committer) (second
54 |                      (fw.lu:v-assoc :committer (metadata object)
55 |                                     :test 'string-equal)))
56 | 
57 |   ((eql :parents) (data-lens.transducers:into
58 |                    '()
59 |                    (data-lens:•
60 |                     (data-lens.transducers:filtering
61 |                      (data-lens:on (data-lens:== "parent" :test 'equal)
62 |                                    #'car))
63 |                     (data-lens.transducers:mapping #'cadr))
64 |                    (metadata object)))
65 | 
66 |   ((eql :message) (data object)))
67 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-87c2b9b-fixture:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (fw.lu:defun-ct batch-4 (bytes)
 4 |   (mapcar 'fwoar.bin-parser:be->int
 5 |           (serapeum:batches bytes 4)))
 6 | 
 7 | (fw.lu:defun-ct batch-20 (bytes)
 8 |   (serapeum:batches bytes 20))
 9 | 
10 | (defmacro sym->plist (&rest syms)
11 |   `(list ,@(loop for sym in syms
12 |                  append (list (alexandria:make-keyword sym)
13 |                               sym))))
14 | 
15 | (defmacro inspect- (s form)
16 |   `(let ((result ,form))
17 |      (format ,s "~&~s (~{~s~^ ~})~%~4t~s~%"
18 |              ',form
19 |              ,(typecase form
20 |                 (list `(list ',(car form) ,@(cdr form)))
21 |                 (t `(list ,form)))
22 |              result)
23 |      result))
24 | 
25 | (defun inspect-* (fn)
26 |   (lambda (&rest args)
27 |     (declare (dynamic-extent args))
28 |     (inspect- *trace-output*
29 |               (apply fn args))))
30 | 
31 | (defun partition (char string &key from-end (with-offset nil wo-p))
32 |   (let ((pos (position char string :from-end from-end)))
33 |     (if pos
34 |         (if wo-p 
35 |             (list (subseq string 0 (+ pos with-offset 1))
36 |                   (subseq string (+ pos 1 with-offset)))
37 |             (list (subseq string 0 pos)
38 |                   (subseq string (1+ pos))))
39 |       (list string
40 |             nil))))
41 | 
42 | (defun partition-subseq (subseq string &key from-end)
43 |   (let ((pos (search subseq string :from-end from-end)))
44 |     (if pos
45 |         (list (subseq string 0 pos)
46 |               (subseq string (+ (length subseq) pos)))
47 |       (list string
48 |             nil))))
49 | 
50 | (serapeum:defalias ->sha-string
51 |   (data-lens:<>1 (data-lens:over 'fwoar.bin-parser:byte-array-to-hex-string)
52 |                  'batch-20))
53 | 
54 | (defun read-bytes (count format stream)
55 |   (let ((seq (make-array count :element-type 'serapeum:octet)))
56 |     (read-sequence seq stream)
57 |     (funcall format
58 |              seq)))
59 | 
60 | (defun sp-ob (ob-string)
61 |   (partition #\null
62 |              ob-string))
63 | 
64 | (defun split-object (object-data)
65 |   (destructuring-bind (head tail)
66 |       (partition 0
67 |                  object-data)
68 |     (destructuring-bind (type length)
69 |         (partition #\space
70 |                    (babel:octets-to-string head :encoding :latin1))
71 |       (values tail
72 |               (list type
73 |                     (parse-integer length))))))
74 | 
75 | (defun parse-commit (commit)
76 |   (destructuring-bind (metadata message)
77 |       (partition-subseq #(#\newline #\newline)
78 |                         commit #+(or)(babel:octets-to-string commit :encoding :latin1))
79 |     (values message
80 |             (map 'vector (serapeum:op (partition #\space _))
81 |                  (fwoar.string-utils:split #\newline metadata)))))
82 | 


--------------------------------------------------------------------------------
/co.fwoar.cl-git.asd:
--------------------------------------------------------------------------------
 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*-
 2 | (in-package :asdf-user)
 3 | 
 4 | (defsystem :co.fwoar.cl-git
 5 |   :description "A pure-Lisp git implementation"
 6 |   :author "Ed L <edward@elangley.org>"
 7 |   :license "MIT"
 8 |   :pathname #-fw.dev nil #+fw.dev #p"PROJECTS:cl-git;"
 9 |   :depends-on (:alexandria
10 |                :babel
11 |                :chipz
12 |                :cl-dot
13 |                :cl-ppcre
14 |                :data-lens
15 |                :data-lens/beta/transducers
16 |                :flexi-streams
17 |                :fwoar-lisputils
18 |                :fwoar-lisputils/bin-parser
19 |                :ironclad
20 |                :serapeum
21 |                :split-sequence
22 |                :uiop)
23 |   :in-order-to ((test-op (test-op :co.fwoar.cl-git/tests)))
24 |   :components ((:file "package")
25 |                (:file "types" :depends-on ("package"))
26 |                (:file "util" :depends-on ("types" "package"))
27 |                (:file "ref" :depends-on ("types" "package" "util"))
28 |                (:file "pack" :depends-on ("types" "package" "util" "ref" "delta"))
29 | 
30 |                ;; data model
31 |                (:file "model" :depends-on ("package"))
32 |                (:file "protocol" :depends-on ("package" "model" "util"))
33 |                (:file "repository" :depends-on ("package" "model"))
34 |                (:file "tree" :depends-on ("package" "model" "protocol"))
35 |                (:file "commit" :depends-on ("package" "model" "protocol"))
36 |                (:file "blob" :depends-on ("package" "model" "protocol"))
37 |                (:file "delta" :depends-on ("package" "model" "protocol"))
38 | 
39 |                (:file "extract" :depends-on ("package" "protocol" "commit" "tree" "delta"))
40 |                (:file "branch" :depends-on ("package" "extract"))
41 |                (:file "git" :depends-on ("package" "types" "util" "model" "branch"))
42 | 
43 |                ;; stable programmer interface
44 |                (:file "porcelain" :depends-on ("package" "git" "commit"))))
45 | 
46 | (defsystem :co.fwoar.cl-git/tests
47 |   :description ""
48 |   :author "Ed L <edward@elangley.org>"
49 |   :license "MIT"
50 |   :depends-on (#:alexandria
51 |                #:uiop
52 |                #:serapeum
53 |                #:fiveam
54 |                #:co.fwoar.cl-git)
55 |   :serial t
56 |   :perform (test-op (o c)
57 |                     (handler-case
58 |                         (unless (symbol-call :fiveam '#:run! :fwoar.cl-git)
59 |                           (error "some tests failed"))
60 |                       (error (c)
61 |                         (format t ">>> ~s~%" c))))
62 |   :components ((:module "tests"
63 |                 :components ((:file "tests")
64 |                              (:file "branch-resolution" :depends-on ("tests"))
65 |                              (:file "git-objects" :depends-on ("tests"))))))
66 | 


--------------------------------------------------------------------------------
/tree.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defclass git-tree (git-object)
 4 |   ((%entries :initarg :entries :reader entries)))
 5 | 
 6 | (defun git-tree (entries)
 7 |   (fw.lu:new 'git-tree entries))
 8 | 
 9 | (defclass tree-entry (git-object)
10 |   ((%repo :initarg :repo :reader repository)
11 |    (%mode :initarg :mode :reader te-mode)
12 |    (%name :initarg :name :reader te-name)))
13 | 
14 | (defun tree-entry (repo name mode hash)
15 |   (fw.lu:new 'tree-entry repo name mode hash))
16 | 
17 | (defmethod print-object ((o tree-entry) s)
18 |   (if *print-readably*
19 |       (format s "#.(~s ~s ~s ~s)"
20 |               'tree-entry
21 |               (te-name o)
22 |               (te-mode o)
23 |               (hash o))
24 |       (print-unreadable-object (o s :type t :identity t)
25 |         (format s "(~a: ~a)"
26 |                 (te-name o)
27 |                 (subseq (hash o) 0 8)))))
28 | 
29 | (defun parse-tree-entry (data)
30 |   (values-list (partition 0 data :with-offset 20)))
31 | 
32 | (defun format-tree-entry (repo entry)
33 |   (destructuring-bind (info sha) (partition 0 entry)
34 |     (destructuring-bind (mode name)
35 |         (partition #\space
36 |                    (babel:octets-to-string info :encoding *git-encoding*))
37 |       (tree-entry repo name mode (elt (->sha-string sha) 0)))))
38 | 
39 | (defun tree-entries (repo data &optional accum)
40 |   (if (<= (length data) 0)
41 |       (nreverse accum)
42 |       (multiple-value-bind (next rest) (parse-tree-entry data)
43 |         (tree-entries repo
44 |                       rest
45 |                       (list* (format-tree-entry repo next)
46 |                              accum)))))
47 | 
48 | (defmethod -extract-object-of-type ((type (eql :tree)) s repository &key)
49 |   (git-tree (tree-entries repository s)))
50 | 
51 | (defmethod component ((component (eql :entries)) (object git-tree))
52 |   (entries object))
53 | 
54 | (defmethod component ((component string) (object git-tree))
55 |   (car (remove component (entries object)
56 |                :test-not #'equal
57 |                :key 'te-name)))
58 | 
59 | (defmethod component ((component pathname) (object git-tree))
60 |   (remove-if-not (lambda (it)
61 |                    (pathname-match-p it component))
62 |                  (entries object)
63 |                  :key 'te-name))
64 | 
65 | (defmethod component ((component (eql :name)) (object tree-entry))
66 |   (te-name object))
67 | (defmethod component ((component (eql :mode)) (object tree-entry))
68 |   (te-mode object))
69 | (defmethod component ((component (eql :ref)) (object tree-entry))
70 |   (ref (repository object)
71 |        (hash object)))
72 | (defmethod component ((component (eql :data)) (object tree-entry))
73 |   (component component
74 |              (ref (repository object)
75 |                   (hash object))))
76 | (defmethod component ((component string) (object tree-entry))
77 |   (component component
78 |              (ref (repository object)
79 |                   (hash object))))
80 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-3157639-fixture:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defclass git-graph ()
 4 |   ((%repo :initarg :repo :reader repo)
 5 |    (%depth :initarg :depth :reader depth)
 6 |    (%branches :reader branches)
 7 |    (%node-cache :reader node-cache :initform (make-hash-table :test 'equal))
 8 |    (%edge-cache :reader edge-cache :initform (make-hash-table :test 'equal))))
 9 | 
10 | (defmethod initialize-instance :after ((object git-graph) &key)
11 |   (setf (slot-value object '%branches)
12 |         (fw.lu:alist-string-hash-table
13 |          (funcall (data-lens:over
14 |                    (<>1 (data-lens:applying #'cons)
15 |                         (data-lens:transform-head
16 |                          (serapeum:op (subseq _1 0 (min (length _1) 7))))
17 |                         #'reverse))
18 |                   (branches (repo object))))))
19 | 
20 | (defun git-graph (repo)
21 |   (fw.lu:new 'git-graph repo))
22 | 
23 | (defun get-commit-parents (repository commit)
24 |   #+lispworks
25 |   (declare (notinline mismatch serapeum:string-prefix-p))
26 |   (map 'list 
27 |        (serapeum:op (second (partition #\space _)))
28 |        (remove-if-not (lambda (it)
29 |                         (serapeum:string-prefix-p "parent" it))
30 |                       (nth-value 1 (parse-commit
31 |                                     (split-object
32 |                                      (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)
33 |                                                        (loose-object repository
34 |                                                                      commit))))))))
35 | 
36 | (defmethod cl-dot:graph-object-node ((graph git-graph) (commit string))
37 |   (alexandria:ensure-gethash commit
38 |                              (node-cache graph)
39 |                              (make-instance 'cl-dot:node
40 |                                             :attributes `(:label ,(gethash #1=(subseq commit 0 7)
41 |                                                                            (branches graph)
42 |                                                                            #1#)))))
43 | 
44 | (defmethod cl-dot:graph-object-points-to ((graph git-graph) (commit string))
45 |   #+nil
46 |   (loop
47 |     for cur = (list commit) then parents
48 |     for parents = (let ((f (get-commit-parents (repo graph) (car cur))))
49 |                     f)
50 |     until (or (not parents)
51 |               (cdr parents))
52 |     finally (return (or parents
53 |                         (when (not (equal commit (car cur)))
54 |                           cur))))
55 | 
56 |   (funcall (data-lens:<>1 (data-lens:over (serapeum:op
57 |                                             (setf (gethash (list commit _1)
58 |                                                            (edge-cache graph))
59 |                                                   t)
60 |                                             _1))
61 |                           (data-lens:exclude (serapeum:op
62 |                                                (gethash (list commit _1)
63 |                                                         (edge-cache graph))))
64 |                           (data-lens:over (serapeum:op (subseq _ 0 7))))
65 |            (get-commit-parents (repo graph) commit)))
66 | 


--------------------------------------------------------------------------------
/util.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git)
  2 | 
  3 | (defmacro defclass+ (name (&rest super) &body (direct-slots &rest options))
  4 |   (let ((initargs (mapcan (lambda (slot)
  5 |                             (serapeum:unsplice
  6 |                              (make-symbol
  7 |                               (symbol-name
  8 |                                (getf (cdr slot)
  9 |                                      :initarg)))))
 10 |                           direct-slots)))
 11 |     `(progn (defclass ,name ,super
 12 |               ,direct-slots
 13 |               ,@options)
 14 |             (defun ,name (,@initargs)
 15 |               (fw.lu:new ',name ,@initargs)))))
 16 | 
 17 | (fw.lu:defun-ct batch-4 (bytes)
 18 |   (mapcar 'fwoar.bin-parser:be->int
 19 |           (serapeum:batches bytes 4)))
 20 | 
 21 | (fw.lu:defun-ct batch-20 (bytes)
 22 |   (serapeum:batches bytes 20))
 23 | 
 24 | (defmacro sym->plist (&rest syms)
 25 |   `(list ,@(loop for sym in syms
 26 |                  append (list (alexandria:make-keyword sym)
 27 |                               sym))))
 28 | 
 29 | (defmacro inspect- (s form)
 30 |   `(let ((result ,form))
 31 |      (format ,s "~&~s (~{~s~^ ~})~%~4t~s~%"
 32 |              ',form
 33 |              ,(typecase form
 34 |                 (list `(list ',(car form) ,@(cdr form)))
 35 |                 (t `(list ,form)))
 36 |              result)
 37 |      result))
 38 | 
 39 | (defun inspect-* (fn)
 40 |   (lambda (&rest args)
 41 |     (declare (dynamic-extent args))
 42 |     (inspect- *trace-output*
 43 |               (apply fn args))))
 44 | 
 45 | (defun partition (char string &key from-end (with-offset nil wo-p))
 46 |   (let ((pos (position char string :from-end from-end)))
 47 |     (if pos
 48 |         (if wo-p
 49 |             (list (subseq string 0 (+ pos with-offset 1))
 50 |                   (subseq string (+ pos 1 with-offset)))
 51 |             (list (subseq string 0 pos)
 52 |                   (subseq string (1+ pos))))
 53 |       (list string
 54 |             nil))))
 55 | 
 56 | (defun partition-subseq (subseq string &key from-end)
 57 |   (let ((pos (search subseq string :from-end from-end)))
 58 |     (if pos
 59 |         (list (subseq string 0 pos)
 60 |               (subseq string (+ (length subseq) pos)))
 61 |       (list string
 62 |             nil))))
 63 | 
 64 | (serapeum:defalias ->sha-string
 65 |   (data-lens:<>1 (data-lens:over 'fwoar.bin-parser:byte-array-to-hex-string)
 66 |                  'batch-20))
 67 | 
 68 | (defun read-bytes (count format stream)
 69 |   (let ((seq (make-array count :element-type 'fwoar.cl-git.types:octet)))
 70 |     (read-sequence seq stream)
 71 |     (funcall format
 72 |              seq)))
 73 | 
 74 | (defun sp-ob (ob-string)
 75 |   (partition #\null
 76 |              ob-string))
 77 | 
 78 | (defun split-object (object-data)
 79 |   (destructuring-bind (head tail)
 80 |       (partition 0
 81 |                  object-data)
 82 |     (destructuring-bind (type length)
 83 |         (partition #\space
 84 |                    (babel:octets-to-string head :encoding :latin1))
 85 |       (values tail
 86 |               (list type
 87 |                     (parse-integer length))))))
 88 | 
 89 | (defmacro with-open-files* ((&rest bindings) &body body)
 90 |   `(uiop:nest ,@(mapcar (serapeum:op
 91 |                           `(with-open-file ,_1))
 92 |                         bindings)
 93 |               (progn
 94 |                 ,@body)))
 95 | 
 96 | 
 97 | (defpackage :fwoar.cl-git.utils
 98 |   (:use :cl)
 99 |   (:import-from :fwoar.cl-git #:partition-subseq #:sym->plist #:read-bytes
100 |                 #:defclass+)
101 |   (:export #:partition-subseq #:sym->plist #:read-bytes #:defclass+))
102 | 


--------------------------------------------------------------------------------
/graph.lisp:
--------------------------------------------------------------------------------
 1 | (defpackage :co.fwoar.cl-git.graph
 2 |   (:use :cl :fwoar.cl-git)
 3 |   (:export ))
 4 | (in-package :co.fwoar.cl-git.graph)
 5 | 
 6 | (defclass git-graph ()
 7 |   ((%repo :initarg :repo :reader repo)
 8 |    (%depth :initarg :depth :reader depth)
 9 |    (%stops :initarg :stops :reader stops :initform ())
10 |    (%branches :reader branches)
11 |    (%node-cache :reader node-cache :initform (make-hash-table :test 'equal))
12 |    (%edge-cache :reader edge-cache :initform (make-hash-table :test 'equal))))
13 | 
14 | (defmethod initialize-instance :after ((object git-graph) &key)
15 |   (setf
16 |    (slot-value object '%branches)
17 |    (fw.lu:alist-string-hash-table
18 |     (funcall (data-lens:over
19 |               (data-lens:<>1 (data-lens:applying #'cons)
20 |                              (data-lens:transform-head
21 |                               (serapeum:op (subseq _1 0
22 |                                                    (min (length _1)
23 |                                                         8))))
24 |                              #'reverse))
25 |              (fwoar.cl-git::branches (repo object))))))
26 | 
27 | (defun git-graph (repo)
28 |   (fw.lu:new 'git-graph repo))
29 | 
30 | (defun get-commit-parents (repository commit)
31 |   #+lispworks
32 |   (declare (notinline mismatch serapeum:string-prefix-p))
33 |   (when commit
34 |     (co.fwoar.git:with-repository (repository)
35 |       (alexandria:when-let*
36 |           ((ref (fwoar.cl-git:ensure-ref commit))
37 |            (direct-obj (fwoar.cl-git::extract-object
38 |                         ref))
39 |            (obj direct-obj)
40 |            (parents (fwoar.cl-git:component
41 |                      :parents
42 |                      obj)))
43 |         (cond ((null parents) parents)
44 |               ((null (cdr parents))
45 |                (let ((maybe-branch (get-commit-parents repository
46 |                                                        (car parents))))
47 |                  (if maybe-branch
48 |                      maybe-branch
49 |                      parents)))
50 |               (t parents))))))
51 | 
52 | (defmethod cl-dot:graph-object-node ((graph git-graph) (commit string))
53 |   (alexandria:ensure-gethash
54 |    commit
55 |    (node-cache graph)
56 |    (make-instance 'cl-dot:node
57 |                   :attributes `(:label ,(gethash #1=(subseq commit 0 8)
58 |                                                  (branches graph)
59 |                                                  #1#)))))
60 | 
61 | (defmethod cl-dot:graph-object-points-to
62 |     ((graph git-graph) (commit string))
63 |   (unless (member commit (stops graph)
64 |                   :test 'serapeum:string-prefix-p)
65 |     (funcall (data-lens:<>1
66 |               (data-lens:over (serapeum:op
67 |                                 (setf (gethash (list commit _1)
68 |                                                (edge-cache graph))
69 |                                       t)
70 |                                 _1))
71 |               (data-lens:exclude (serapeum:op
72 |                                    (gethash (list commit _1)
73 |                                             (edge-cache graph))))
74 |               (data-lens:over (serapeum:op (subseq _ 0 8))))
75 |              (get-commit-parents (repo graph) commit))))
76 | 
77 | 
78 | (defun graph-repository (path roots)
79 |   (co.fwoar.git:with-repository (path)
80 |     (cl-dot:generate-graph-from-roots
81 |      (make-instance 'git-graph
82 |                     :repo fwoar.cl-git::*git-repository*
83 |                     :stops ())
84 |      (mapcar (data-lens:∘ 'fwoar.cl-git::ref-hash
85 |                           'co.fwoar.git::resolve-refish)
86 |              roots))))
87 | 


--------------------------------------------------------------------------------
/git.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :fwoar.cl-git)
 2 | 
 3 | (defun extract-object-metadata-from-pack (pack obj-number)
 4 |   (with-pack-streams (s p) pack
 5 |     (seek-to-object-in-pack pack s p obj-number)
 6 |     (read-object-metadata-from-pack p)))
 7 | 
 8 | (defun turn-read-object-to-string (object)
 9 |   (data-lens.lenses:over *object-data-lens*
10 |                          'babel:octets-to-string object))
11 | 
12 | (defun fanout-table (s)
13 |   (coerce (alexandria:assoc-value
14 |            (fwoar.bin-parser:extract '((head 4)
15 |                                        (version 4)
16 |                                        (fanout-table #.(* 4 256) batch-4))
17 |                                      s)
18 |            'fanout-table)
19 |           'vector))
20 | 
21 | (defun get-object-size (bytes)
22 |   (loop for c across bytes
23 |         for next = (logand c 15) then (logand c #x7f)
24 |         for shift = 0 then (if (= shift 0) 4 (+ shift 7))
25 |         for size = next then (+ size (ash next shift))
26 |         while (> (logand c #x80) 0)
27 |         finally (return size)))
28 | 
29 | (defun get-object-type (bytes)
30 |   (let ((first (elt bytes 0)))
31 |     (ldb (byte 3 4)
32 |          first)))
33 | 
34 | (defun get-shas-before (fanout-table first-sha-byte s)
35 |   (let ((num-before (elt fanout-table first-sha-byte))
36 |         (num-total (alexandria:last-elt fanout-table)))
37 |     (values (fwoar.bin-parser:extract (list (list 'shas (* 20 num-before) '->sha-string))
38 |                                       s)
39 |             (- num-total num-before))))
40 | 
41 | (defun advance-past-crcs (obj-count s)
42 |   (file-position s
43 |                  (+ (file-position s)
44 |                      (* 4 obj-count))))
45 | 
46 | (defun object-offset (object-number s)
47 |   (file-position s
48 |                  (+ (file-position s)
49 |                     (* (1- object-number)
50 |                        4)))
51 |   (fwoar.bin-parser:extract '((offset 4 fwoar.bin-parser:be->int))
52 |                             s))
53 | 
54 | (defun collect-data (idx-toc s num)
55 |   (let ((sha-idx (getf idx-toc :shas))
56 |         (crc-idx (getf idx-toc :packed-crcs))
57 |         (4-byte-offsets-idx (getf idx-toc :4-byte-offsets))
58 |         (8-byte-offsets-idx (getf idx-toc :8-byte-offsets)))
59 |     (declare (ignore 8-byte-offsets-idx))
60 |     (values num
61 |             (progn
62 |               (file-position s (+ sha-idx (* num 20)))
63 |               (read-bytes 20 'fwoar.bin-parser:byte-array-to-hex-string s))
64 |             (progn
65 |               (file-position s (+ crc-idx (* num 4)))
66 |               (read-bytes 4 'identity s))
67 |             (progn
68 |               (file-position s (+ 4-byte-offsets-idx (* num 4)))
69 |               (read-bytes 4 'fwoar.bin-parser:be->int s)))))
70 | 
71 | (defun read-object-metadata-from-pack (s)
72 |   (let* ((metadata (fwoar.bin-parser:extract-high s))
73 |          (type-raw (get-object-type metadata))
74 |          (size (get-object-size metadata))
75 |          (type (object-type->sym type-raw)))
76 |     (values (cons :type type)
77 |             (cons :decompressed-size size))))
78 | 
79 | (defun get-first-commits-from-pack (pack n)
80 |   (let ((toc (idx-toc pack))
81 |         (result ()))
82 |     (with-pack-streams (idx pack-s) pack
83 |       (dotimes (i n (reverse result))
84 |         (multiple-value-bind (_ sha __ offset) (collect-data toc idx i)
85 |           (declare (ignore _ __))
86 |           (file-position pack-s offset)
87 |           (push `((:sha . ,sha)
88 |                   ,@(multiple-value-list
89 |                      (read-object-metadata-from-pack pack-s))
90 |                   (:offset . ,offset))
91 |                 result))))))
92 | 


--------------------------------------------------------------------------------
/docs/static/style.css:
--------------------------------------------------------------------------------
  1 | :root {
  2 |     --zenburn-fg-plus-2: #FFFFEF;
  3 |     --zenburn-fg-plus-1: #F5F5D6;
  4 |     --zenburn-fg: #DCDCCC;
  5 |     --zenburn-fg-1: #A6A689;
  6 |     --zenburn-fg-2: #656555;
  7 |     --zenburn-black: #000000;
  8 |     --zenburn-bg-2: #000000;
  9 |     --zenburn-bg-1: #111112;
 10 |     --zenburn-bg-05: #383838;
 11 |     --zenburn-bg: #2A2B2E;
 12 |     --zenburn-bg-plus-05: #494949;
 13 |     --zenburn-bg-plus-1: #4F4F4F;
 14 |     --zenburn-bg-plus-2: #5F5F5F;
 15 |     --zenburn-bg-plus-3: #6F6F6F;
 16 |     --zenburn-red-plus-2: #ECB3B3;
 17 |     --zenburn-red-plus-1: #DCA3A3;
 18 |     --zenburn-red: #CC9393;
 19 |     --zenburn-red-1: #BC8383;
 20 |     --zenburn-red-2: #AC7373;
 21 |     --zenburn-red-3: #9C6363;
 22 |     --zenburn-red-4: #8C5353;
 23 |     --zenburn-red-5: #7C4343;
 24 |     --zenburn-red-6: #6C3333;
 25 |     --zenburn-orange: #DFAF8F;
 26 |     --zenburn-yellow: #F0DFAF;
 27 |     --zenburn-yellow-1: #E0CF9F;
 28 |     --zenburn-yellow-2: #D0BF8F;
 29 |     --zenburn-green-5: #2F4F2F;
 30 |     --zenburn-green-4: #3F5F3F;
 31 |     --zenburn-green-3: #4F6F4F;
 32 |     --zenburn-green-2: #5F7F5F;
 33 |     --zenburn-green-1: #6F8F6F;
 34 |     --zenburn-green: #7F9F7F;
 35 |     --zenburn-green-plus-1: #8FB28F;
 36 |     --zenburn-green-plus-2: #9FC59F;
 37 |     --zenburn-green-plus-3: #AFD8AF;
 38 |     --zenburn-green-plus-4: #BFEBBF;
 39 |     --zenburn-cyan: #93E0E3;
 40 |     --zenburn-blue-plus-3: #BDE0F3;
 41 |     --zenburn-blue-plus-2: #ACE0E3;
 42 |     --zenburn-blue-plus-1: #94BFF3;
 43 |     --zenburn-blue: #8CD0D3;
 44 |     --zenburn-blue-1: #7CB8BB;
 45 |     --zenburn-blue-2: #6CA0A3;
 46 |     --zenburn-blue-3: #5C888B;
 47 |     --zenburn-blue-4: #4C7073;
 48 |     --zenburn-blue-5: #366060;
 49 |     --zenburn-magenta: #DC8CC3;
 50 | }
 51 | 
 52 | * {
 53 |     box-sizing: border-box;
 54 | }
 55 | body, html {
 56 |     margin: 0;
 57 |     padding: 0;
 58 | }
 59 | 
 60 | body {
 61 |     --background: var(--zenburn-bg);
 62 |     --heading-background: var(--zenburn-bg-1);
 63 |     --foreground: var(--zenburn-fg);
 64 |     --accent: var(--zenburn-green);
 65 |     --accent-1: var(--zenburn-green-1);
 66 |     --accent-2: var(--zenburn-green-2);
 67 |     --accent-3: var(--zenburn-green-3);
 68 |     --accent-4: var(--zenburn-green-4);
 69 |     --accent-5: var(--zenburn-green-5);
 70 |     --link: var(--zenburn-blue);
 71 |     --visited: var(--zenburn-blue-3);
 72 | }
 73 | 
 74 | body {
 75 |     background: var(--background);
 76 |     color: var(--foreground);
 77 | }
 78 | h1,h2,h3,h4,h5,h6 {
 79 |     background: var(--heading-background);
 80 |     border-bottom: currentcolor;
 81 | }
 82 | h1 {color: var(--accent);}
 83 | h2 {color: var(--accent-1);}
 84 | h3 {color: var(--accent-2);}
 85 | h4 {color: var(--accent-3);}
 86 | h5 {color: var(--accent-4);}
 87 | h6 {color: var(--accent-5);}
 88 | a {color: var(--link);}
 89 | a:visited {color: var(--visited);}
 90 | 
 91 | h1,h2,h3,h4,h5,h6 {
 92 |     padding: 0.5rem 1rem;
 93 |     font-family: sans-serif;
 94 |     font-size: 16px;
 95 |     margin: 0;
 96 |     margin-bottom: 0.5em;
 97 |     border: 0.1em;
 98 |     border-bottom: solid;
 99 | }
100 | 
101 | body {
102 |     display: grid;
103 |     grid-template-areas: 'header header header header header'
104 |                          'header header header header header'
105 |                          'toc    main   main   main   main  '
106 |                          'toc    main   main   main   main  '
107 |                          'toc    main   main   main   main  '
108 |                          'footer footer footer footer footer';
109 |     grid-gap: 0.1rem;
110 |     min-height: 100vh;
111 |     width: 100vw;
112 | }
113 | 
114 | body > #content {
115 |     display: contents;
116 | }
117 | #content > .title {
118 |     grid-area: header;
119 |     border: none;
120 |     background: transparent;
121 |     display: flex;
122 |     justify-content: center;
123 |     align-items: center;
124 |     font-size: 2rem;
125 |     padding: 0;
126 | }
127 | #content > #table-of-contents {
128 |     grid-area: toc;
129 | }
130 | #content > .outline-2 {
131 |     grid-area:  span 4;
132 | }
133 | body > #postamble {
134 |     grid-area: footer;
135 |     display: flex;
136 |     justify-content: space-between;
137 |     padding: 0.25em 0.5em;
138 | }
139 | 


--------------------------------------------------------------------------------
/model.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git)
  2 | 
  3 | (defparameter *object-data-lens*
  4 |   (data-lens.lenses:make-alist-lens :object-data))
  5 | 
  6 | (defclass repository ()
  7 |   ((%root :initarg :root :reader root)))
  8 | (defclass git-repository (repository)
  9 |   ())
 10 | (defclass bare-git-repository (git-repository)
 11 |   ())
 12 | 
 13 | (defclass git-object ()
 14 |   ((%hash :initarg :hash :accessor hash)))
 15 | 
 16 | (defgeneric object-type->sym (object-type)
 17 |   (:documentation "Canonicalizes different representations of an
 18 |   object type to their symbol representation."))
 19 | 
 20 | (defmethod object-type->sym ((o-t symbol))
 21 |     o-t)
 22 | 
 23 | (defmethod object-type->sym ((object-type number))
 24 |   (ecase object-type
 25 |     (1 :commit)
 26 |     (2 :tree)
 27 |     (3 :blob)
 28 |     (4 :tag)
 29 |     (6 :ofs-delta)
 30 |     (7 :ref-delta)))
 31 | 
 32 | (defmethod object-type->sym ((object-type string))
 33 |   (string-case:string-case ((string-downcase object-type))
 34 |     ("commit" :commit)
 35 |     ("tree" :tree)
 36 |     ("blob" :blob)
 37 |     ("tag" :tag)
 38 |     ("ofs-delta" :ofs-delta)
 39 |     ("ref-delta" :ref-delta)))
 40 | 
 41 | (define-condition alts-fallthrough (error)
 42 |   ((%fallthrough-message :initarg :fallthrough-message :reader fallthrough-message)
 43 |    (%args :initarg :args :reader args))
 44 |   (:report (lambda (c s)
 45 |              (format s "~a ~s"
 46 |                      (fallthrough-message c)
 47 |                      (args c)))))
 48 | 
 49 | ;; TODO: figure out how to handle ambiguity? restarts?
 50 | (define-method-combination alts (&key fallthrough-message) ((methods *))
 51 |   (:arguments arg)
 52 |   (progn
 53 |     (mapc (serapeum:op
 54 |             (let ((qualifiers (method-qualifiers _1)))
 55 |               (unless (and (eql 'alts (car qualifiers))
 56 |                            (if (null (cdr qualifiers))
 57 |                                t
 58 |                                (and (symbolp (cadr qualifiers))
 59 |                                     (null (cddr qualifiers)))))
 60 |                 (invalid-method-error _1 "invalid qualifiers: ~s" qualifiers))))
 61 |           methods)
 62 |     `(or ,@(mapcar (serapeum:op `(call-method ,_1))
 63 |                    methods)
 64 |          (error 'alts-fallthrough
 65 |                 :fallthrough-message ,fallthrough-message
 66 |                 :args ,arg))))
 67 | 
 68 | (defgeneric resolve-repository (object)
 69 |   (:documentation "resolve an OBJECT to a repository implementation")
 70 |   (:method-combination alts :fallthrough-message "failed to resolve repository"))
 71 | 
 72 | (defmethod resolve-repository alts :git ((root pathname))
 73 |   (alexandria:when-let ((root (probe-file root)))
 74 |     (let* ((root (merge-pathnames (make-pathname :directory '(:relative ".git"))
 75 |                                   root)))
 76 |       (when (probe-file root)
 77 |         (fw.lu:new 'git-repository root)))))
 78 | (defmethod resolve-repository alts :bare ((root pathname))
 79 |   (alexandria:when-let ((root (probe-file root)))
 80 |     (let* ((root (merge-pathnames (make-pathname :name "info")
 81 |                                   root)))
 82 |       (when (probe-file root)
 83 |         (fw.lu:new 'bare-git-repository root)))))
 84 | 
 85 | (defgeneric repository (object)
 86 |   (:documentation "get the repository for an object")
 87 |   (:method ((root repository))
 88 |     root)
 89 |   (:method ((root pathname))
 90 |     (resolve-repository root))
 91 |   (:method ((root string))
 92 |     (let ((root (parse-namestring root)))
 93 |       (repository root))))
 94 | 
 95 | (defun loose-object-path (sha)
 96 |   (let ((obj-path (fwoar.string-utils:insert-at 2 #\/ sha)))
 97 |     (merge-pathnames obj-path "objects/")))
 98 | 
 99 | (defgeneric pack-files (repo)
100 |   (:method ((repo git-repository))
101 |     (mapcar (serapeum:op
102 |               (fwoar.cl-git.pack:pack _1
103 |                                       (merge-pathnames
104 |                                        (make-pathname :type "pack") _1)
105 |                                       repo))
106 |             (uiop:directory*
107 |              (merge-pathnames "objects/pack/*.idx"
108 |                               (root-of repo))))))
109 | 
110 | (defgeneric loose-object (repository id)
111 |   (:method ((repository string) id)
112 |     (handler-case (loose-object (repository repository) id)
113 |       (alts-fallthrough ())))
114 |   (:method ((repository pathname) id)
115 |     (handler-case (loose-object (repository repository) id)
116 |       (alts-fallthrough ())))
117 |   (:method ((repository repository) id)
118 |     (car
119 |      (uiop:directory*
120 |       (merge-pathnames (loose-object-path (serapeum:concat id "*"))
121 |                        (root repository))))))
122 | 
123 | (defun loose-object-p (repository id)
124 |   "Is ID an ID of a loose object?"
125 |   (loose-object repository id))
126 | 
127 | (defmethod component ((component (eql :hash)) (object git-object))
128 |   (hash object))
129 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-c516dfc-fixture:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git)
  2 | 
  3 | (defun seek-to-object-in-pack (idx-stream pack-stream obj-number)
  4 |   (let* ((toc (idx-toc idx-stream))
  5 |          (offset-offset (getf toc :4-byte-offsets)))
  6 |     (file-position idx-stream (+ offset-offset (* 4 obj-number)))
  7 |     (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int idx-stream)))
  8 |       (file-position pack-stream object-offset-in-pack))))
  9 | 
 10 | (deftype octet ()
 11 |   '(unsigned-byte 8))
 12 | 
 13 | (defmacro with-open-files* ((&rest bindings) &body body)
 14 |   `(uiop:nest ,@(mapcar (serapeum:op
 15 |                           `(with-open-file ,_1))
 16 |                         bindings)
 17 |               (progn
 18 |                 ,@body)))
 19 | 
 20 | (defun extract-object-metadata-from-pack (pack obj-number)
 21 |   (with-open-files* ((s (index-file pack) :element-type 'octet)
 22 |                      (p (pack-file pack) :element-type 'octet))
 23 |     (seek-to-object-in-pack s p obj-number)
 24 |     (read-object-metadata-from-pack p)))
 25 | 
 26 | (defun turn-read-object-to-string (object)
 27 |   (data-lens.lenses:over *object-data-lens*
 28 |                          'babel:octets-to-string object))
 29 | 
 30 | (defun fanout-table (s)
 31 |   (coerce (alexandria:assoc-value
 32 |            (fwoar.bin-parser:extract '((head 4)
 33 |                                        (version 4)
 34 |                                        (fanout-table #.(* 4 256) batch-4))
 35 |                                      s)
 36 |            'fanout-table)
 37 |           'vector))
 38 | 
 39 | (defun get-object-size (bytes)
 40 |   (let ((first (elt bytes 0))
 41 |         (rest (subseq bytes 1)))
 42 |     (logior (ash (fwoar.bin-parser:be->int rest) 4)
 43 |             (logand first 15))))
 44 | 
 45 | (defun get-object-type (bytes)
 46 |   (let ((first (elt bytes 0)))
 47 |     (ldb (byte 3 4)
 48 |          first)))
 49 | 
 50 | (defun get-shas-before (fanout-table first-sha-byte s)
 51 |   (let ((num-before (elt fanout-table first-sha-byte))
 52 |         (num-total (alexandria:last-elt fanout-table)))
 53 |     (values (fwoar.bin-parser:extract (list (list 'shas (* 20 num-before) '->sha-string))
 54 |                                       s)
 55 |             (- num-total num-before))))
 56 | 
 57 | (defun advance-past-crcs (obj-count s)
 58 |   (file-position s
 59 |                  (+ (file-position s)
 60 |                      (* 4 obj-count))))
 61 | 
 62 | (defun object-offset (object-number s)
 63 |   (file-position s
 64 |                  (+ (file-position s)
 65 |                      (* (1- object-number)
 66 |                         4)))
 67 |   (fwoar.bin-parser:extract '((offset 4 fwoar.bin-parser:be->int))
 68 |                             s))
 69 | 
 70 | (defun idx-toc (idx-stream)
 71 |   (let* ((object-count (progn (file-position idx-stream 1028)
 72 |                               (let ((buf (make-array 4)))
 73 |                                 (read-sequence buf idx-stream)
 74 |                                 (fwoar.bin-parser:be->int buf))))
 75 |          (signature 0)
 76 |          (version 4)
 77 |          (fanout 8)
 78 |          (shas (+ fanout
 79 |                    (* 4 256)))
 80 |          (packed-crcs (+ shas
 81 |                           (* 20 object-count)))
 82 |          (4-byte-offsets (+ packed-crcs
 83 |                              (* 4 object-count)))
 84 |          (8-byte-offsets-pro (+ 4-byte-offsets
 85 |                                  (* object-count 4)))  
 86 |          (pack-sha (- (file-length idx-stream)
 87 |                        40))
 88 |          (8-byte-offsets (when (/= 8-byte-offsets-pro pack-sha)
 89 |                            8-byte-offsets-pro))
 90 |          (idx-sha (- (file-length idx-stream)
 91 |                       20)))
 92 |     (values (sym->plist signature
 93 |                         version
 94 |                         fanout
 95 |                         shas
 96 |                         packed-crcs
 97 |                         4-byte-offsets
 98 |                         8-byte-offsets
 99 |                         pack-sha
100 |                         idx-sha)
101 |             object-count)))
102 | 
103 | (defun collect-data (idx-toc s num)
104 |   (let ((sha-idx (getf idx-toc :shas))
105 |         (crc-idx (getf idx-toc :packed-crcs))
106 |         (4-byte-offsets-idx (getf idx-toc :4-byte-offsets))
107 |         (8-byte-offsets-idx (getf idx-toc :8-byte-offsets)))
108 |     (declare (ignore 8-byte-offsets-idx))
109 |     (values num
110 |             (progn
111 |               (file-position s (+ sha-idx (* num 20)))
112 |               (read-bytes 20 'fwoar.bin-parser:byte-array-to-hex-string s))
113 |             (progn
114 |               (file-position s (+ crc-idx (* num 4)))
115 |               (read-bytes 4 'identity s))
116 |             (progn
117 |               (file-position s (+ 4-byte-offsets-idx (* num 4)))
118 |               (read-bytes 4 'fwoar.bin-parser:be->int s)))))
119 | 
120 | (defun read-object-metadata-from-pack (s)
121 |   (let* ((metadata (fwoar.bin-parser:extract-high s))
122 |          (type-raw (get-object-type metadata))
123 |          (size (get-object-size metadata))
124 |          (type (object-type->sym type-raw)))
125 |     (values (cons :type type)
126 |             (cons :decompressed-size size))))
127 | 
128 | (defun get-first-commits-from-pack (idx pack n)
129 |   (let ((toc (idx-toc idx))
130 |         (result ()))
131 |     (dotimes (i n (reverse result))
132 |       (multiple-value-bind (_ sha __ offset) (collect-data toc idx i)
133 |         (declare (ignore _ __))
134 |         (file-position pack offset)
135 |         (push `((:sha . ,sha)
136 |                 ,@(multiple-value-list
137 |                    (read-object-metadata-from-pack pack))
138 |                 (:offset . ,offset))
139 |               result)))))
140 | 
141 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.delta-bases:
--------------------------------------------------------------------------------
  1 | ( ("5cb25684234f0bc9ddc42434805754b224f92f2c" . 3648)
  2 |  ("62af1bf37cb1d91a426251ee5b09029833efe18c" . 8634)
  3 |  ("f334556fc4f5675bb805ada20dadb8571924c713" . 11240)
  4 |  ("e06b66967fa4fa005ccf00dcbc7d839b22259593" . 12273)
  5 |  ("265a98fb79595e0067e53d8cf222dec4283f8525" . 12969)
  6 |  ("9776df71b5ddf298c56e99b7291f9e68906cf049" . 15023)
  7 |  ("cf8e6e10786a26ffcd6a3e0fdb97abdf1c9f0345" . 18539)
  8 |  ("4707eca4ee0c70520ccdc57c0e831187b21271e7" . 19758)
  9 |  ("f89fbdc08797f554113ead7fd92409e84b51b713" . 15023)
 10 |  ("c516dfc248544509c3ae58e3a8c2ab81c225aa9c" . 20163)
 11 |  ("224d09513abc65298c55d52e34e7dd6a97f8ecd8" . 15023)
 12 |  ("31576396aff0fff28f69e0ef84571c0dc8cc43ec" . 20733)
 13 |  ("a339f9dfc57b461e09d94c176fe90d90c13daf42" . 11240)
 14 |  ("406b7f64a9ea8ac59da2a61036a389c9f0325f06" . 21182)
 15 |  ("0673dcbe10b945d561a9c3c485fe28aab12b257c" . 21406)
 16 |  ("d8c5107920aa70475ef806cba031e07b7ffc62c1" . 22416)
 17 |  ("ae0a070133d1a14d6e940a0f790f40b37e885b22" . 24437)
 18 |  ("87c2b9b2dfaa1fbf66b3fe88d3a925593886b159" . 15023)
 19 |  ("66279b2fa08c9d0872e888b85fe14d9950e27326" . 24726)
 20 |  ("e30a688cfd75bfb27d78264faccaaa80cb68dc37" . 7355)
 21 |  ("91fca3db49d59fc2e560961fd3a75b3c6b44dadf" . 25132)
 22 |  ("53d13ed284f8b57297d1b216e2bab7fb43f8db60" . 13350)
 23 |  ("ac7221d134310fced0fc2d20a662e7659e98960e" . 7355)
 24 |  ("956583ccfd66b86874ab390862b9e21bf0125195" . 25290)
 25 |  ("5d91012a15f8893f7cdbfc15686926414d044e65" . 8634)
 26 |  ("3aed167fd86a4ddc94fa064edbe6d1c6ea8a2c44" . 25290)
 27 |  ("936ac49ab3ae312b0cc9467aab8a8534d452f0d2" . 25567)
 28 |  ("c60d7303d8ccdd58e50249160b80d6fc9b57c387" . 25567)
 29 |  ("36875efd06662d89803c72a69ff31a6ed0aea0c3" . 18539)
 30 |  ("dbfe85d03296435b4a33ef3dc26456080e3f0263" . 11240)
 31 |  ("ee379ef30e0cd080a3ef9333e2a8b01cbb04000f" . 22416)
 32 |  ("e0e2c160ce8ee1114274c98cc6dbf3e5fd4197a8" . 25567)
 33 |  ("cd59e0f2e993a77000d77b7f386c603892de356a" . 25567)
 34 |  ("58adcd3ecfd494847646dc90b8214cb575ce7683" . 26079)
 35 |  ("e69272bd90575f4dc99801a06287531bf2d09017" . 18539)
 36 |  ("18d56071caf51761e073eb1d2eb49c185b674789" . 26300)
 37 |  ("6e4821d169fc505dd2b598d4bf4bdfc512ea6ebd" . 20163)
 38 |  ("d14096a450a8d5392698a2d959a17e696dd62af6" . 26451)
 39 |  ("a4220a28d4800e38b8b8f85db0d97afc8b889293" . 20733)
 40 |  ("89291277beacc08c2a982fc7bf1b15da8315ec6e" . 26079)
 41 |  ("a7cbe10af08aed7b24b633649db6dc4cec011a3f" . 26079)
 42 |  ("da3e1b59cf4e32ba8d843f7529f009e82c3a609b" . 26747)
 43 |  ("663fd18f870932925511a32c7e0d2356d8fe26ba" . 25543)
 44 |  ("028027ae078ed4bf26c6aeb083ee2187f7de73a7" . 26861)
 45 |  ("e70a61be268cbaa6a7825295fbe54beaa3c59c71" . 26079)
 46 |  ("1e000f7fc230cdebaf2d285766a6b8df2f038b06" . 21406)
 47 |  ("9c8827bc556311dd4a71ec6ccc08860b1b415676" . 27750)
 48 |  ("e1c10e80cdc707c337e2095cae8200c722c259f8" . 26300)
 49 |  ("c99dcb3b970e5f9ff6e38216a823cec09d4b5068" . 26451)
 50 |  ("62eadd630528aa78bcd0855c0e3ce8e72164c817" . 25980)
 51 |  ("e7d2a96c2d218956d503f17c619cb69f26d8745d" . 27798)
 52 |  ("2eb6f4572b4c917babf2d6a4c9751a8b77feb16a" . 27984)
 53 |  ("966ad7406532a0cd95c77c42393f4127e199e047" . 12969)
 54 |  ("d6859afc633d06b2c841a74d60987d4bc9ee1099" . 28500)
 55 |  ("7052fbed9f3c10bc2727fd0db20550629293f07e" . 28150)
 56 |  ("d67c0db9d755c7492e904a83b18c94c133bc20a7" . 28500)
 57 |  ("10044b063ea5aa11a0ec0b77f601a2e15598b154" . 28401)
 58 |  ("58b3d3041816618a70e0de4511c61fcdacb895c3" . 28647)
 59 |  ("a701a1bec9d7514b9b56ad01fcd3ca9ff92ce906" . 25980)
 60 |  ("20ab821930a16350f8c20966ade05f467fefa744" . 28749)
 61 |  ("16b760a9d3478e4543b8bf3b4282c0e1c23cde62" . 21182)
 62 |  ("4271cbd4035b61aefdf893a697669cafc673e7f1" . 28717)
 63 |  ("164f3c875fb9eb728f354c448876e8ad500b6f1e" . 28150)
 64 |  ("e8f144e2761cbea8310324c07f31c1d3a8fdf911" . 26672)
 65 |  ("310a307fc54f40bfba1d475c92024ba6542b0315" . 12273)
 66 |  ("3e6a9a272f26f34bcacc0a9992ade1ad612ed0c9" . 21182)
 67 |  ("c6cc546b864cd9c8997ba1ef035b39167d4ddfff" . 28717)
 68 |  ("220725554cbed54358f385d766fd713120d543cb" . 24726)
 69 |  ("6851ec85107be5726b1369eb576c4c8ae9e153a3" . 29023)
 70 |  ("a48dd93d1c5e70421f0fb2da57105b6b155f0fe4" . 28150)
 71 |  ("26876ecf0d711a959a037b8bad65434bdf5387f0" . 15023)
 72 |  ("7ba87f92cb3e26234543c36ebc32fe285a66c038" . 29744)
 73 |  ("06ee9b09e87e21645743b800c152f652b8748ca0" . 30069)
 74 |  ("ac605d74cc98676527d4d18d426176cd55f2ae75" . 30193)
 75 |  ("0c0de8ab35998093c16386b9f3546dba3672f392" . 29612)
 76 |  ("e3daca1c81cb31138e9f173de1ef6ed142ef72ef" . 21182)
 77 |  ("9f115bb65d115525b781be14faa7230dc737dafd" . 30248)
 78 |  ("c06a5cdde544c7345da76887071986cb9336d509" . 30317)
 79 |  ("06a4ad0d26c5aa00b912e2c40d59038b620faa26" . 29693)
 80 |  ("e16577ff964315b9215273946069c2a47f734907" . 30069)
 81 |  ("b37b43e4044e725eea6d6cd87055dad3b2c54e75" . 30317)
 82 |  ("97bd59ec403740c06ff368847c8937209b3ba8e9" . 30521)
 83 |  ("c83b68c6597baed5bf78a5f734cf43c7a1aceb1b" . 21182)
 84 |  ("e30c5c9580f7c8b3ab54ffedef1ea0eb710cc4c7" . 29523)
 85 |  ("b768fc9ffe867185eda8fd72e4cad806a8a133dd" . 30573)
 86 |  ("24d5250e48eceb1574fbf6e7c49d11f6c9aa6c96" . 30069)
 87 |  ("dd0bbea71b4390f3265211084476925f1ec517cf" . 30573)
 88 |  ("0f6ac7e2e9ca89bb1f4a19a3bf1f026a5c3da2c8" . 21182)
 89 |  ("dca156cce70f9d6a4c6cddebda6c5a21eb04e35b" . 28717)
 90 |  ("2a1a18be82d5b164276865620861d7186f5cd7da" . 30806)
 91 |  ("9a68815c624b91fa400f06da3c8911d3943baf53" . 30069)
 92 |  ("7569881ce48d6073dce64a1b9e92a0c012d63a98" . 24726)
 93 |  ("23265ddc885b55bcc44f7da49c5c2e9d6800d8c5" . 31015)
 94 |  ("15160d98378f5bca96cfd2450b58697a2e4315c4" . 12969)
 95 |  ("5e1e0673f45cceca14e3efb499eb5dafcb563db2" . 21182)
 96 |  ("912d31a169ddf1fca122d4c6fe1b1e6be7cd1176" . 31118)
 97 |  ("48ba2aede24e9b48a17d31372c8fc01d86799209" . 31281)
 98 |  ("7f353e0e418f6f098f59a74aefdfed5654985c6d" . 29744)
 99 |  ("3c41df4946f91eca01c6ce7267834943bd3f69bf" . 28717)
100 |  ("eb9344e7aeacb7665af1c2db2f86e5792515de5b" . 12969)
101 |  ("0bffcb03469a159b29fed1d6be2809d0b69e2647" . 31757)
102 | )
103 | 


--------------------------------------------------------------------------------
/porcelain.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git)
  2 | 
  3 | (defvar *git-repository*)
  4 | (setf (documentation '*git-repository* 'variable)
  5 |       "The git repository path for porcelain commands to operate on.")
  6 | 
  7 | (defvar *git-encoding* :utf-8
  8 |   "The encoding to use when parsing git objects")
  9 | 
 10 | (defun co.fwoar.git:repository ()
 11 |   *git-repository*)
 12 | 
 13 | (defun co.fwoar.git:in-repository (root)
 14 |   (setf *git-repository*
 15 |         (ensure-repository
 16 |          (truename root))))
 17 | 
 18 | (defmacro co.fwoar.git:with-repository ((root) &body body)
 19 |   `(let ((*git-repository* (ensure-repository ,root)))
 20 |      ,@body))
 21 | 
 22 | (defun co.fwoar.git:show-repository ()
 23 |   *git-repository*)
 24 | 
 25 | (defun in-git-package (symbol)
 26 |   (intern (symbol-name symbol)
 27 |           :co.fwoar.git))
 28 | 
 29 | (defun handle-list (_1)
 30 |   (case (in-git-package (car _1))
 31 |     (co.fwoar.git::unwrap `(uiop:nest (car)
 32 |                                       (mapcar ,@(cdr _1))))
 33 |     (t (cons (in-git-package (car _1))
 34 |              (cdr _1)))))
 35 | 
 36 | (defun co.fwoar.git::resolve-refish (it)
 37 |   (flet ((hash-p (it)
 38 |            (and (> (length it) 32)
 39 |                 (every (serapeum:op
 40 |                          (digit-char-p _1 16))
 41 |                        it))))
 42 |     (cond
 43 |       ((block is-branch
 44 |          (mapc (fw.lu:destructuring-lambda ((name hash))
 45 |                  (when (equal it name)
 46 |                    (return-from is-branch
 47 |                      (ensure-ref hash))))
 48 |                (branches *git-repository*))
 49 |          nil))
 50 |       ((hash-p it) (ensure-ref it)))))
 51 | 
 52 | (defmacro co.fwoar.git:git (&rest commands)
 53 |   `(uiop:nest ,@(reverse
 54 |                  (funcall (data-lens:<>1
 55 |                            (data-lens:over (serapeum:op
 56 |                                              (typecase _1
 57 |                                                (string `(identity ,_1))
 58 |                                                (list (handle-list _1)))))
 59 |                            (data-lens:transform-head (serapeum:op
 60 |                                                        (etypecase _1
 61 |                                                          (string `(co.fwoar.git::resolve-refish ,_1))
 62 |                                                          (t _1)))))
 63 |                           commands))))
 64 | 
 65 | (defun co.fwoar.git::ensure-ref (it)
 66 |   (ensure-ref it))
 67 | 
 68 | (defun co.fwoar.git::decode (it)
 69 |   (babel:octets-to-string it :encoding *git-encoding*))
 70 | 
 71 | (defun co.fwoar.git::<<= (fun &rest args)
 72 |   (apply #'mapcan fun args))
 73 | 
 74 | (defmacro co.fwoar.git::map (fun list)
 75 |   (alexandria:once-only (list)
 76 |     (alexandria:with-gensyms (it)
 77 |       `(mapcar ,(if (consp fun)
 78 |                     `(lambda (,it)
 79 |                        (,(in-git-package (car fun))
 80 |                         ,@(cdr fun)
 81 |                         ,it))
 82 |                     `',(in-git-package fun))
 83 |                ,list))))
 84 | 
 85 | (defmacro co.fwoar.git::juxt (&rest args)
 86 |   (let ((funs (butlast args))
 87 |         (arg (car (last args))))
 88 |     (alexandria:once-only (arg)
 89 |       `(list ,@(mapcar (lambda (f)
 90 |                          `(,@(alexandria:ensure-list f) ,arg))
 91 |                        funs)))))
 92 | 
 93 | (defmacro co.fwoar.git::pipe (&rest funs)
 94 |   (let ((funs (reverse (butlast funs)))
 95 |         (var (car (last funs))))
 96 |     `(uiop:nest ,@(mapcar (lambda (it)
 97 |                             (if (consp it)
 98 |                                 `(,(in-git-package (car it)) ,@(cdr it))
 99 |                                 `(,(in-git-package it))))
100 |                           funs)
101 |                 ,var)))
102 | 
103 | (defun co.fwoar.git::filter (fun &rest args)
104 |   (apply #'remove-if-not fun args))
105 | 
106 | (defun co.fwoar.git::object (thing)
107 |   (extract-object thing))
108 | 
109 | (defun co.fwoar.git:show (object)
110 |   (extract-object object))
111 | 
112 | (defun co.fwoar.git:contents (object)
113 |   (co.fwoar.git:show object))
114 | 
115 | (defun co.fwoar.git:component (&rest args)
116 |   (let ((component-list (butlast args))
117 |         (target (car (last args))))
118 |     (fwoar.cl-git::component component-list target)))
119 | 
120 | (defun co.fwoar.git:tree (commit-object)
121 |   (component :tree
122 |              commit-object))
123 | 
124 | (defun co.fwoar.git::filter-tree (name-pattern tree)
125 |   #+lispworks
126 |   (declare (notinline serapeum:string-prefix-p))
127 |   (let* ((tree-entries (component :entries tree))
128 |          (scanner (cl-ppcre:create-scanner name-pattern)))
129 |     (remove-if-not (serapeum:op
130 |                      (cl-ppcre:scan scanner _))
131 |                    tree-entries
132 |                    :key #'te-name)))
133 | 
134 | (defun co.fwoar.git:branch (&optional (branch nil branch-p))
135 |   #+lispworks
136 |   (declare (notinline serapeum:assocadr))
137 |   (let* ((branches (branches *git-repository*))
138 |          (branch-hash (if branch-p
139 |                           (serapeum:assocadr (etypecase branch
140 |                                                (string branch)
141 |                                                (keyword (string-downcase branch)))
142 |                                              branches
143 |                                              :test 'equal)
144 |                           (or (serapeum:assocadr "master" branches :test 'equal)
145 |                               (serapeum:assocadr "main" branches :test 'equal)))))
146 |     (if branch-hash
147 |         (ref *git-repository*
148 |              branch-hash)
149 |         (error "branch ~s not found" branch))))
150 | 
151 | (defun co.fwoar.git:branches ()
152 |   (branches *git-repository*))
153 | 
154 | (defun co.fwoar.git::parents (commit)
155 |   (mapcar 'ensure-ref
156 |           (component :parents commit)))
157 | (defun co.fwoar.git:commit-parents (commit)
158 |   (co.fwoar.git::parents commit))
159 | 
160 | (defun co.fwoar.git:rev-list (ref-id &optional (limit nil limit-p))
161 |   "Return the commits reachable from the ref."
162 |   (when limit-p
163 |     (rotatef ref-id limit))
164 |   (let ((seen (make-hash-table)))
165 |     (labels ((iterate (queue accum &optional (count 0))
166 |                (if (or (when limit-p
167 |                          (= limit count))
168 |                        (null queue))
169 |                    accum
170 |                    (destructuring-bind (next . rest) queue
171 |                      (let ((parents (co.fwoar.git::parents next)))
172 |                        (iterate (append rest parents)
173 |                          (if (gethash next seen)
174 |                              accum
175 |                              (progn
176 |                                (setf (gethash next seen) t)
177 |                                (cons next accum)))
178 |                          (1+ count)))))))
179 |       (iterate (list (ensure-ref ref-id))
180 |         ()))))
181 | 


--------------------------------------------------------------------------------
/tests/sample-git-objects/blob-9776df7-fixture:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git)
  2 | 
  3 | (defun edges-in-fanout (toc s sha)
  4 |   (let* ((fanout-offset (getf toc :fanout)))
  5 |     (file-position s (+ fanout-offset (* 4 (1- (elt sha 0)))))
  6 |     (destructuring-bind ((_ . cur) (__ . next))
  7 |         (fwoar.bin-parser:extract '((cur 4 fwoar.bin-parser:be->int)
  8 |                                     (next 4 fwoar.bin-parser:be->int))
  9 |                                   s)
 10 |       (declare (ignore _ __))
 11 |       (values cur next))))
 12 | 
 13 | (defun find-sha-between-terms (toc s start end sha)
 14 |   (unless (>= start end)
 15 |     (let* ((sha-offset (getf toc :shas))
 16 |            (mid (floor (+ start end)
 17 |                        2)))
 18 |       (file-position s (+ sha-offset (* 20 mid)))
 19 |       (let ((sha-at-mid (read-bytes 20 'fwoar.bin-parser:byte-array-to-hex-string s)))
 20 |         (cond ((string< sha sha-at-mid)
 21 |                (find-sha-between-terms toc s start mid sha))
 22 |               ((string> sha sha-at-mid)
 23 |                (find-sha-between-terms toc s (1+ mid) end sha))
 24 |               (t mid))))))
 25 | 
 26 | (defun find-pack-containing (pack-file id)
 27 |   (with-open-file (s (index-file pack-file)
 28 |                      :element-type '(unsigned-byte 8))
 29 |     (let ((binary-sha (ironclad:hex-string-to-byte-array id))
 30 |           (toc (idx-toc s)))
 31 |       (multiple-value-bind (_ end) (edges-in-fanout toc s binary-sha)
 32 |         (declare (ignore _))
 33 |         (let ((midpoint (find-sha-between-terms toc s 0 end id)))
 34 |           (and midpoint
 35 |                (values pack-file
 36 |                        midpoint)))))))
 37 | 
 38 | (defun find-object-in-pack-files (repo id)
 39 |   (dolist (pack-file (pack-files repo))
 40 |     (multiple-value-bind (pack mid) (find-pack-containing pack-file id)
 41 |       (when pack
 42 |         (return-from find-object-in-pack-files
 43 |           (values pack mid))))))
 44 | 
 45 | (defun behead (data)
 46 |   (elt (partition 0 data)
 47 |        1))
 48 | 
 49 | (defun tree-entry (data)
 50 |   (values-list (partition 0 data :with-offset 20)))
 51 | 
 52 | (defun format-tree-entry (entry)
 53 |   (destructuring-bind (info sha) (partition 0 entry)
 54 |     (concatenate 'vector
 55 |                  (apply #'concatenate 'vector
 56 |                         (serapeum:intersperse (vector (char-code #\tab))
 57 |                                               (reverse
 58 |                                                (partition (char-code #\space)
 59 |                                                           info))))
 60 |                  (list (char-code #\tab))
 61 |                  (babel:string-to-octets (elt (->sha-string sha) 0) :encoding *git-encoding*))))
 62 | 
 63 | (defun tree-entries (data &optional accum)
 64 |   (if (<= (length data) 0)
 65 |       (apply #'concatenate 'vector
 66 |              (serapeum:intersperse (vector (char-code #\newline))
 67 |                                    (nreverse accum)))
 68 |       (multiple-value-bind (next rest) (tree-entry data) 
 69 |         (tree-entries rest
 70 |                       (list* (format-tree-entry next)
 71 |                              accum)))))
 72 | 
 73 | (defun extract-object-of-type (type s repository)
 74 |   (with-simple-restart (continue "Skip object of type ~s" type)
 75 |     (%extract-object-of-type type s repository)))
 76 | 
 77 | (defgeneric %extract-object-of-type (type s repository)
 78 |   (:method ((type integer) s repository)
 79 |     (extract-object-of-type (object-type->sym type)
 80 |                             s
 81 |                             repository))
 82 | 
 83 |   (:method ((type (eql :commit)) s repository)
 84 |     s)
 85 | 
 86 |   (:method ((type (eql :blob)) s repository)
 87 |     s)
 88 | 
 89 |   (:method ((type (eql :tag)) s repository)
 90 |     s)
 91 | 
 92 |   (:method ((type (eql :tree)) s repository)
 93 |     (tree-entries s)))
 94 | 
 95 | (defun read-object-from-pack (s repository)
 96 |   (let* ((metadata (fwoar.bin-parser:extract-high s))
 97 |          (type (object-type->sym (get-object-type metadata)))
 98 |          (size (get-object-size metadata))
 99 |          (decompressed (if (member type '(:ofs-delta :ref-delta))
100 |                            s
101 |                            (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s)))
102 |          (object-data (extract-object-of-type type decompressed repository)))
103 |     (list (cons :type (object-type->sym type))
104 |           (cons :decompressed-size size)
105 |           (cons :object-data object-data)
106 |           (cons :raw-data object-data))))
107 | 
108 | (defun extract-object-from-pack (pack obj-number)
109 |   (with-open-file (s (index-file pack) :element-type '(unsigned-byte 8))
110 |     (with-open-file (p (pack-file pack) :element-type '(unsigned-byte 8))
111 |       (let* ((toc (idx-toc s))
112 |              (offset-offset (getf toc :4-byte-offsets)))
113 |         (file-position s (+ offset-offset (* 4 obj-number)))
114 |         (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int s)))
115 |           (file-position p object-offset-in-pack)
116 |           (read-object-from-pack p (repository pack)))))))
117 | 
118 | (defclass git-object ()
119 |   ((%repo :initarg :repo :reader object-repo)
120 |    (%hash :initarg :hash :reader object-hash)))
121 | (defclass loose-object (git-object)
122 |   ((%file :initarg :file :reader loose-object-file)))
123 | (defclass packed-object (git-object)
124 |   ((%pack :initarg :pack :reader packed-object-pack)
125 |    (%offset :initarg :offset :reader packed-object-offset)))
126 | 
127 | (defun object (repo id)
128 |   (let ((repo-root (typecase repo
129 |                      (repository (root repo))
130 |                      (string (namestring
131 |                               (truename repo))))))
132 |     (or (alexandria:when-let ((object-file (loose-object repo id)))
133 |           (make-instance 'loose-object :repo repo-root :hash id :file object-file))
134 |         (multiple-value-bind (pack offset) (find-object-in-pack-files repo id)
135 |           (when pack
136 |             (make-instance 'packed-object :repo repo-root :offset offset :pack pack))))))
137 | 
138 | (defun extract-loose-object (repo file)
139 |   (with-open-file (s file :element-type '(unsigned-byte 8))
140 |     (alexandria:when-let ((result (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)
141 |                                                     s)))
142 |       (destructuring-bind (type rest)
143 |           (partition (char-code #\space) result)
144 |         (extract-object-of-type (object-type->sym (babel:octets-to-string type))
145 |                                 (elt (partition 0 rest)
146 |                                      1)
147 |                                 repo)))))
148 | 
149 | (defgeneric extract-object-next (object)
150 |   (:method ((object loose-object))
151 |     (extract-loose-object (object-repo object)
152 |                           (loose-object-file object)))
153 |   (:method ((object packed-object))
154 |     (data-lens.lenses:view *object-data-lens*
155 |                            (extract-object-from-pack (packed-object-pack object)
156 |                                                      (packed-object-offset object)))))
157 | 
158 | (defun extract-object (repo id)
159 |   (if (loose-object-p repo id)
160 |       (extract-loose-object repo (loose-object repo id))
161 |       (data-lens.lenses:view *object-data-lens*
162 |                              (multiple-value-call 'extract-object-from-pack 
163 |                                (find-object-in-pack-files (root repo) id)))))
164 | 


--------------------------------------------------------------------------------
/delta.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git.delta)
  2 | 
  3 | (defclass delta (fwoar.cl-git:git-object)
  4 |   ((%repository :initarg :repository :reader repository)
  5 |    (%base :initarg :base :reader base)
  6 |    (%commands :initarg :commands :reader commands)
  7 |    (%src-size :initarg :src-size :reader src-size)
  8 |    (%delta-size :initarg :delta-size :reader delta-size))
  9 |   (:documentation
 10 |    "The base type for deltified git objects"))
 11 | 
 12 | (fwoar.cl-git.utils:defclass+ ofs-delta (delta)
 13 |   ())
 14 | 
 15 | (fwoar.cl-git.utils:defclass+ ref-delta (delta)
 16 |   ()
 17 |   (:documentation "TODO: mostly unimplemented/untested"))
 18 | 
 19 | (defun make-ofs-delta (base commands repository src-size delta-size)
 20 |   (fw.lu:new 'ofs-delta base commands repository src-size delta-size))
 21 | (defun make-ref-delta (base commands repository)
 22 |   (fw.lu:new 'ofs-delta base commands repository))
 23 | 
 24 | (defun int->bit-vector (n)
 25 |   (let* ((integer-length (integer-length n))
 26 |          (bv-size (* 8 (ceiling integer-length 8)))
 27 |          (bv (make-array bv-size :element-type 'bit)))
 28 |     (loop :for ix :below integer-length
 29 |           :do (setf (aref bv (- bv-size 1 ix))
 30 |                     (if (logbitp ix n)
 31 |                         1
 32 |                         0)))
 33 |     bv))
 34 | 
 35 | (defun bit-vector->int (bv)
 36 |   (let ((bv-size (array-total-size bv)))
 37 |     (loop :for ix :from (1- bv-size) :downto 0
 38 |           :for n :from 0
 39 |           :unless (zerop (aref bv ix))
 40 |             :sum (expt 2 n))))
 41 | 
 42 | (defun obj-to-type (obj)
 43 |   (etypecase obj
 44 |     (fwoar.cl-git:git-commit :commit)
 45 |     (fwoar.cl-git:git-tree :tree)
 46 |     (fwoar.cl-git.blob:blob :blob)))
 47 | 
 48 | (defun trace-bases (pack delta)
 49 |   (assert (typep delta 'delta))
 50 |   (let* ((offset (second (base delta)))
 51 |          (o (fwoar.cl-git.pack::extract-object-at-pos
 52 |              pack
 53 |              offset
 54 |              (make-instance 'fwoar.cl-git.ref:ref
 55 |                             :hash "00000000"
 56 |                             :repo nil)))
 57 |          (obj (serapeum:assocdr :object-data o))
 58 |          (raw (serapeum:assocdr :raw-data o)))
 59 |     (if (typep obj 'delta)
 60 |         (multiple-value-bind (next base-type) (trace-bases pack obj)
 61 |           (values (apply-commands next
 62 |                                   (commands delta))
 63 |                   base-type))
 64 |         (let ((base (apply-commands raw
 65 |                                     (commands delta))))
 66 |           (length base)
 67 |           (values base
 68 |                   (obj-to-type obj))))))
 69 | 
 70 | (defun resolve-delta (ref maybe-delta)
 71 |   (typecase maybe-delta
 72 |     (delta (multiple-value-bind (raw-data type) (trace-bases
 73 |                                                  (fwoar.cl-git.pack:packed-ref-pack ref)
 74 |                                                  maybe-delta)
 75 |              (-extract-object-of-type type
 76 |                                       raw-data
 77 |                                       (fwoar.cl-git.ref:ref-repo ref)
 78 |                                       :hash (fwoar.cl-git.ref:ref-hash ref))))
 79 |     (t maybe-delta)))
 80 | 
 81 | (defun get-bases (pack delta)
 82 |   (if (typep delta 'delta)
 83 |       (let* ((offset (second (base delta)))
 84 |              (o (fwoar.cl-git.pack:extract-object-at-pos
 85 |                  pack
 86 |                  offset
 87 |                  (make-instance 'fwoar.cl-git.ref:ref
 88 |                                 :hash "00000000"
 89 |                                 :repo nil)))
 90 |              (obj (serapeum:assocdr :object-data o)))
 91 |         (cons delta (get-bases pack obj)))
 92 |       (list delta)))
 93 | 
 94 | (defun partition-commands (data)
 95 |   (let ((idx 0))
 96 |     (labels ((advance ()
 97 |                (if (>= idx (length data))
 98 |                    (progn (incf idx)
 99 |                           0)
100 |                    (prog1 (elt data idx)
101 |                      (incf idx))))
102 |              (get-command ()
103 |                (let* ((bv (int->bit-vector (elt data idx)))
104 |                       (discriminator (elt bv 0))
105 |                       (insts (subseq bv 1)))
106 |                  (incf idx)
107 |                  (if (= 1 discriminator)
108 |                      (expand-copy
109 |                       (list :copy
110 |                             insts
111 |                             (coerce (loop repeat (count 1 insts) collect (advance))
112 |                                     '(vector (unsigned-byte 8)))))
113 |                      (list :add
114 |                            (coerce (loop repeat (bit-vector->int insts)
115 |                                          collect (advance))
116 |                                    '(vector (unsigned-byte 8)))))))
117 |              (expand-copy (copy)
118 |                (destructuring-bind (command layout numbers) copy
119 |                  (let* ((next-idx 0)
120 |                         (parts (map '(vector (unsigned-byte 8))
121 |                                     (lambda (layout-bit)
122 |                                       (if (= layout-bit 1)
123 |                                           (prog1 (elt numbers next-idx)
124 |                                             (incf next-idx))
125 |                                           0))
126 |                                     (reverse layout))))
127 |                    (list command
128 |                          (fwoar.bin-parser:le->int (subseq parts 0 4))
129 |                          (fwoar.bin-parser:le->int (subseq parts 4)))))))
130 |       (loop while (< idx (length data))
131 |             collect (get-command)))))
132 | 
133 | (defun apply-commands (base commands)
134 |   (flexi-streams:with-output-to-sequence (s)
135 |     (flet ((do-copy (offset cnt)
136 |              #+(or)
137 |              (format t "DOING :COPY ~d ~d~%" offset cnt)
138 |              (write-sequence (subseq base offset (+ offset cnt))
139 |                              s))
140 |            (do-add (data)
141 |              #+(or)
142 |              (format t "DOING :ADD ~d~%" (length data))
143 |              (write-sequence data s)))
144 |       (loop for (command . args) in commands
145 |             when (eql command :copy) do
146 |               (apply #'do-copy args)
147 |             when (eql command :add) do
148 |               (apply #'do-add args)))))
149 | 
150 | (defun get-ofs-delta-offset-streaming (buf)
151 |   (let* ((idx 0))
152 |     (flet ((advance ()
153 |              (read-byte buf)))
154 |       (loop
155 |         for c = (advance)
156 |         for ofs = (logand c 127) then (+ (ash (1+ ofs)
157 |                                               7)
158 |                                          (logand c 127))
159 |         while (> (logand c 128) 0)
160 |         finally
161 |            (return (values (- ofs) idx))))))
162 | 
163 | (defun get-ofs-delta-offset (buf)
164 |   (let* ((idx 0))
165 |     (flet ((advance ()
166 |              (prog1 (elt buf idx)
167 |                (incf idx))))
168 |       (loop
169 |         for c = (advance)
170 |         for ofs = (logand c 127) then (+ (ash (1+ ofs)
171 |                                               7)
172 |                                          (logand c 127))
173 |         while (> (logand c 128) 0)
174 |         finally
175 |            (return (values (- ofs) idx))))))
176 | 
177 | (defun decode-size (buf)
178 |   (let ((parts ()))
179 |     (loop for raw across buf
180 |           for bits = (int->bit-vector raw)
181 |           for morep = (= (elt bits 0) 1)
182 |           do (push (subseq bits 1) parts)
183 |           while morep)
184 |     (let ((result (make-array (* 7 (length parts))
185 |                               :element-type 'bit)))
186 |       (loop for x from 0 by 7
187 |             for part in parts
188 |             do
189 |                (replace result part :start1 x))
190 |       (values (bit-vector->int result)
191 |               (length parts)))))
192 | 
193 | (defmethod -extract-object-of-type ((type (eql :ofs-delta)) s repository &key offset-from packfile base)
194 |   (multiple-value-bind (src-size consumed-1) (decode-size s)
195 |     (multiple-value-bind (delta-size consumed-2) (decode-size (subseq s
196 |                                                                       consumed-1))
197 |       (make-ofs-delta (list packfile
198 |                             (+ offset-from base))
199 |                       (partition-commands (subseq s
200 |                                                   (+ consumed-1
201 |                                                      consumed-2)))
202 |                       repository
203 |                       src-size
204 |                       delta-size))))
205 | 
206 | (defmethod -extract-object-of-type ((type (eql :ref-delta)) s repository &key offset-from)
207 |   (make-ref-delta offset-from
208 |                   (partition-commands s)
209 |                   repository))
210 | 


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
  1 | * CL-GIT: the pure lisp interface to Git objects
  2 | ** Introduction
  3 | 
  4 |    Git libraries for Common Lisp common in a couple forms. Some attempt
  5 |    to wrap the libgit2 git library
  6 |    (e.g. https://github.com/russell/cl-git).  Others wrap the git binary
  7 |    in a subprocess (e.g. http://shinmera.github.io/legit/).  Such
  8 |    libraries work well in cases where you control the environment but
  9 |    not all lisp programs run in such circumstances.  This library, on the
 10 |    contrary, attempts to implement parsers for git's file formats as well
 11 |    as a thin "porcelain" interface for manipulating git objects.
 12 | 
 13 | ** Contributing
 14 | 
 15 |   This project uses (loosely) conventional-commits: https://www.conventionalcommits.org/en/v1.0.0/
 16 | 
 17 |   Also, some use of https://github.com/fiddlerwoaroof/git-issue has been made
 18 | 
 19 |   To run the tests in a clean environment, you can do (this will eventually be a Github Action):
 20 | 
 21 |   #+BEGIN_SRC sh :noeval
 22 |     docker run \
 23 |       -v $PWD/docker-run:/code fiddlerwoaroof/sbcl-static:latest \
 24 |       --load /code/main.lisp
 25 |   #+END_SRC
 26 | 
 27 | ** Installation
 28 | 
 29 |    #+BEGIN_SRC sh :noeval
 30 |      % git clone https://github.com/fiddlerwoaroof/fwoar.lisputils.git "$HOME/quicklisp/local-projects/fwoar-lisputils"
 31 |      % git clone https://github.com/fiddlerwoaroof/cl-git.git "$HOME/quicklisp/local-projects/cl-git"
 32 |      % sbcl --load "$HOME/quicklisp/setup.lisp"
 33 |      CL-USER> (ql:quickload :cl-git)
 34 |    #+END_SRC
 35 | 
 36 | ** Example usage
 37 | 
 38 | *** Get the commit id of the default branch for a specific repository:
 39 | 
 40 |     #+BEGIN_SRC lisp :exports both :results verbatim
 41 |       (co.fwoar.git:with-repository (".")
 42 |         ;; the argument to branch defaults to "master" or "main"
 43 |         (co.fwoar.git:branch))
 44 |     #+END_SRC
 45 | 
 46 |     #+RESULTS:
 47 |     : #<LOOSE-REF ba6fdb of #<GIT-REPOSITORY {70161A1853}> {70161A2893}>
 48 | 
 49 | 
 50 | *** Show the commit message
 51 | 
 52 |     #+BEGIN_SRC lisp :exports both :results verbatim
 53 |       (co.fwoar.git:in-repository ".")
 54 |       (co.fwoar.git:component :message (co.fwoar.git:branch "main"))
 55 |     #+END_SRC
 56 | 
 57 |     #+RESULTS:
 58 |     : feat: don't assume that the default branch is \"master\"
 59 | 
 60 | *** Show the messages of the commit's parent
 61 | 
 62 |     #+BEGIN_SRC lisp :exports both :results verbatim
 63 |       (co.fwoar.git:in-repository ".")
 64 |       (let* ((branch (co.fwoar.git:branch "main"))
 65 |              (parents (co.fwoar.git:parents branch)))
 66 |         (mapcar (lambda (it)
 67 |                   (co.fwoar.git:component :message it))
 68 |                 parents))
 69 |     #+END_SRC
 70 | 
 71 |     #+RESULTS:
 72 |     : ("feat: handle bare repositories
 73 |     : ")
 74 | 
 75 | *** Show the files in a commit
 76 | 
 77 |     #+BEGIN_SRC lisp :exports both :results table :hlines yes :post proc(data=*this*)
 78 |       (co.fwoar.git:in-repository ".")
 79 |       (list* '("Name" "Mode" "Hash")
 80 |              'hline
 81 |              (co.fwoar.git:git (branch "main")
 82 |                                (component :tree :entries)
 83 |                                (map (juxt (component :name)
 84 |                                           (component :mode)
 85 |                                           (component :hash)))))
 86 |     #+END_SRC
 87 | 
 88 |     #+RESULTS:
 89 |     | Name                |   Mode | Hash                                     |
 90 |     |---------------------+--------+------------------------------------------|
 91 |     | .github             |  40000 | beabf775f686fb2608a580b4d58dd589cf160354 |
 92 |     | .gitignore          | 100644 | 8a9fe9f77149f74fed5c05388be8e5ffd4a31678 |
 93 |     | .projectile         | 100644 | e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 |
 94 |     | LICENSE             | 100644 | 0306819e780fa57dc3bf6b99a0a059670b605ae0 |
 95 |     | README.org          | 100644 | f25aa710e8c3053f4a6618728702e41c68eb52c5 |
 96 |     | branch.lisp         | 100644 | d82ad3bdbae4af13b5a703bf350dd2bb2c9dadd0 |
 97 |     | co.fwoar.cl-git.asd | 100644 | 560a0f63f48161e2ba787ed42332515de7f86f14 |
 98 |     | commit.lisp         | 100644 | 6ff88d884da171adf49ed022decd537a5964e41c |
 99 |     | delta.lisp          | 100644 | 1014147a1946752542c1ea7dd9700cb047055047 |
100 |     | docker-run          |  40000 | 4703dc01430d67c5d60f00ad412fddfa22f60764 |
101 |     | docs                |  40000 | 9fe62496fc4ab6debd3c5e1b26f844b5566c36d5 |
102 |     | extract.lisp        | 100644 | 4fc2d479ff5c37fc52a51a2cf884e5226fb3b14d |
103 |     | git.lisp            | 100644 | bccecfd98285f2ab98a277a3284bd98b3dd363bf |
104 |     | graph.lisp          | 100644 | 25596749c5bf5ee2d5a76b355821f57010beb31a |
105 |     | model.lisp          | 100644 | ade5096654ea6ff352354d381784a5d9dda0a3e7 |
106 |     | pack.lisp           | 100644 | 16b02b061756f59d615b5f1f7f473789ad86b676 |
107 |     | package.lisp        | 100644 | f8bd75abedd62bd51155ebd1727b5b9476d02c57 |
108 |     | porcelain.lisp      | 100644 | 3f044e12ae9fc5a98a5c84f2f54e6892ae42216a |
109 |     | protocol.lisp       | 100644 | 84a10444b7bce2b844128917cdfc79fa4df6377b |
110 |     | ref.lisp            | 100644 | b508a5546a0bc0b7189a8cf8cebb33a967f3ffb2 |
111 |     | repository.lisp     | 100644 | 4e64262b40bcd0e239276a73426d0d1ac9d0772c |
112 |     | tests               |  40000 | df1addf5dae76e35e84e6ded6fee14cda501f119 |
113 |     | tree.lisp           | 100644 | c798b0c4d0b5f552548bac98f44b5b5c19334e66 |
114 |     | types.lisp          | 100644 | 3f53e0f33ee260a962b97ef26de1d66b32a12a15 |
115 |     | undelta.lisp        | 100644 | ae0a070133d1a14d6e940a0f790f40b37e885b22 |
116 |     | util.lisp           | 100644 | 5374d96e5e29d836a427c40999e0f9c88fb1587a |
117 | 
118 | *** Show the files that match a pattern
119 | 
120 |     #+BEGIN_SRC lisp :exports both :results table :hlines yes :post proc(data=*this*)
121 |       (co.fwoar.git:with-repository (".")
122 |         (let* ((branch (co.fwoar.git:branch "main"))
123 |                (tree (co.fwoar.git:tree branch))
124 |                (tree-entries (co.fwoar.git:filter-tree "^.....?[.]lisp" tree)))
125 |           (flet ((component (component)
126 |                    (lambda (it)
127 |                      (co.fwoar.git:component component it))))
128 |             (list* '("Name" "Mode" "Hash")
129 |                    'hline
130 |                    (mapcar (data-lens:juxt (component :name)
131 |                                            (component :mode)
132 |                                            (component :hash))
133 |                            tree-entries)))))
134 |     #+END_SRC
135 | 
136 |     #+RESULTS:
137 |     | Name       |   Mode | Hash                                     |
138 |     |------------+--------+------------------------------------------|
139 |     | delta.lisp | 100644 | 1014147a1946752542c1ea7dd9700cb047055047 |
140 |     | graph.lisp | 100644 | 25596749c5bf5ee2d5a76b355821f57010beb31a |
141 |     | model.lisp | 100644 | ade5096654ea6ff352354d381784a5d9dda0a3e7 |
142 |     | pack.lisp  | 100644 | 16b02b061756f59d615b5f1f7f473789ad86b676 |
143 |     | tree.lisp  | 100644 | c798b0c4d0b5f552548bac98f44b5b5c19334e66 |
144 |     | types.lisp | 100644 | 3f53e0f33ee260a962b97ef26de1d66b32a12a15 |
145 |     | util.lisp  | 100644 | 5374d96e5e29d836a427c40999e0f9c88fb1587a |
146 | 
147 | ** Partially Implemented:
148 | 
149 | *** Delta refs
150 |     Git uses a [[https://git-scm.com/docs/pack-format#_deltified_representation][delta calculation]] routine to compress some of the blobs
151 |     in a pack file. This delta stores a reference to a base object and
152 |     a sequence of commands for transforming the base object into the
153 |     new object. My plan to support this is to first just extract the
154 |     commands from the pack file and store them as a [[file:delta.lisp::(defclass delta () ((%repository :initarg :repository :reader repository) (%base :initarg :base :reader base) (%commands :initarg :commands :reader commands)))][delta object]]. When
155 |     this works adequately, I'll write an interpreter to do the actual
156 |     merge.
157 | 
158 |     A workaround for the moment is to manually unpack the pack files:
159 | 
160 |     #+BEGIN_SRC sh :noeval
161 |       mkdir tmp
162 |       mv .git/objects/pack/* tmp
163 |       for pack in tmp/*.pack; do
164 |         git unpack-objects < "$pack";
165 |       done
166 |     #+END_SRC
167 | 
168 |     Or, you can undeltify the packs by, first unpacking the packfile as above and then doing:
169 | 
170 |     #+BEGIN_SRC sh :noeval
171 |       git repack --window=0
172 |     #+END_SRC
173 | 
174 | 
175 | *** git:git porcelain
176 |     I have some thoughts abound a =(git:git ...)= form that can be
177 |     used as a [[https://github.com/shinmera/lquery.git][lQuery-like]] DSL for manipulating git repositories, and
178 |     this is partially implemented in [[file+emacs:./porcelain.lisp][porcelain.lisp]], but the details
179 |     need more thought before it is ready.
180 | 
181 | 
182 | ** TODOs
183 | *** TODO start implementing Pharo-like git integration (read-only first, commits later)
184 | 
185 | #+name: proc
186 | #+begin_src emacs-lisp :var data=()
187 |   (mapcar (lambda (it)
188 |             (if (equal it 'HLINE)
189 |                 'hline
190 |               it))
191 |           data)
192 | #+end_src
193 | 
194 | #+RESULTS: proc
195 | 


--------------------------------------------------------------------------------
/docs/index.html:
--------------------------------------------------------------------------------
  1 | <?xml version="1.0" encoding="utf-8"?>
  2 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
  3 | "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  4 | <html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
  5 | <head>
  6 | <!-- 2023-10-31 Tue 03:20 -->
  7 | <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
  8 | <meta name="viewport" content="width=device-width, initial-scale=1" />
  9 | <title>&lrm;</title>
 10 | <meta name="author" content="Edward Langley" />
 11 | <meta name="generator" content="Org Mode" />
 12 | <style>
 13 |   #content { max-width: 60em; margin: auto; }
 14 |   .title  { text-align: center;
 15 |              margin-bottom: .2em; }
 16 |   .subtitle { text-align: center;
 17 |               font-size: medium;
 18 |               font-weight: bold;
 19 |               margin-top:0; }
 20 |   .todo   { font-family: monospace; color: red; }
 21 |   .done   { font-family: monospace; color: green; }
 22 |   .priority { font-family: monospace; color: orange; }
 23 |   .tag    { background-color: #eee; font-family: monospace;
 24 |             padding: 2px; font-size: 80%; font-weight: normal; }
 25 |   .timestamp { color: #bebebe; }
 26 |   .timestamp-kwd { color: #5f9ea0; }
 27 |   .org-right  { margin-left: auto; margin-right: 0px;  text-align: right; }
 28 |   .org-left   { margin-left: 0px;  margin-right: auto; text-align: left; }
 29 |   .org-center { margin-left: auto; margin-right: auto; text-align: center; }
 30 |   .underline { text-decoration: underline; }
 31 |   #postamble p, #preamble p { font-size: 90%; margin: .2em; }
 32 |   p.verse { margin-left: 3%; }
 33 |   pre {
 34 |     border: 1px solid #e6e6e6;
 35 |     border-radius: 3px;
 36 |     background-color: #f2f2f2;
 37 |     padding: 8pt;
 38 |     font-family: monospace;
 39 |     overflow: auto;
 40 |     margin: 1.2em;
 41 |   }
 42 |   pre.src {
 43 |     position: relative;
 44 |     overflow: auto;
 45 |   }
 46 |   pre.src:before {
 47 |     display: none;
 48 |     position: absolute;
 49 |     top: -8px;
 50 |     right: 12px;
 51 |     padding: 3px;
 52 |     color: #555;
 53 |     background-color: #f2f2f299;
 54 |   }
 55 |   pre.src:hover:before { display: inline; margin-top: 14px;}
 56 |   /* Languages per Org manual */
 57 |   pre.src-asymptote:before { content: 'Asymptote'; }
 58 |   pre.src-awk:before { content: 'Awk'; }
 59 |   pre.src-authinfo::before { content: 'Authinfo'; }
 60 |   pre.src-C:before { content: 'C'; }
 61 |   /* pre.src-C++ doesn't work in CSS */
 62 |   pre.src-clojure:before { content: 'Clojure'; }
 63 |   pre.src-css:before { content: 'CSS'; }
 64 |   pre.src-D:before { content: 'D'; }
 65 |   pre.src-ditaa:before { content: 'ditaa'; }
 66 |   pre.src-dot:before { content: 'Graphviz'; }
 67 |   pre.src-calc:before { content: 'Emacs Calc'; }
 68 |   pre.src-emacs-lisp:before { content: 'Emacs Lisp'; }
 69 |   pre.src-fortran:before { content: 'Fortran'; }
 70 |   pre.src-gnuplot:before { content: 'gnuplot'; }
 71 |   pre.src-haskell:before { content: 'Haskell'; }
 72 |   pre.src-hledger:before { content: 'hledger'; }
 73 |   pre.src-java:before { content: 'Java'; }
 74 |   pre.src-js:before { content: 'Javascript'; }
 75 |   pre.src-latex:before { content: 'LaTeX'; }
 76 |   pre.src-ledger:before { content: 'Ledger'; }
 77 |   pre.src-lisp:before { content: 'Lisp'; }
 78 |   pre.src-lilypond:before { content: 'Lilypond'; }
 79 |   pre.src-lua:before { content: 'Lua'; }
 80 |   pre.src-matlab:before { content: 'MATLAB'; }
 81 |   pre.src-mscgen:before { content: 'Mscgen'; }
 82 |   pre.src-ocaml:before { content: 'Objective Caml'; }
 83 |   pre.src-octave:before { content: 'Octave'; }
 84 |   pre.src-org:before { content: 'Org mode'; }
 85 |   pre.src-oz:before { content: 'OZ'; }
 86 |   pre.src-plantuml:before { content: 'Plantuml'; }
 87 |   pre.src-processing:before { content: 'Processing.js'; }
 88 |   pre.src-python:before { content: 'Python'; }
 89 |   pre.src-R:before { content: 'R'; }
 90 |   pre.src-ruby:before { content: 'Ruby'; }
 91 |   pre.src-sass:before { content: 'Sass'; }
 92 |   pre.src-scheme:before { content: 'Scheme'; }
 93 |   pre.src-screen:before { content: 'Gnu Screen'; }
 94 |   pre.src-sed:before { content: 'Sed'; }
 95 |   pre.src-sh:before { content: 'shell'; }
 96 |   pre.src-sql:before { content: 'SQL'; }
 97 |   pre.src-sqlite:before { content: 'SQLite'; }
 98 |   /* additional languages in org.el's org-babel-load-languages alist */
 99 |   pre.src-forth:before { content: 'Forth'; }
100 |   pre.src-io:before { content: 'IO'; }
101 |   pre.src-J:before { content: 'J'; }
102 |   pre.src-makefile:before { content: 'Makefile'; }
103 |   pre.src-maxima:before { content: 'Maxima'; }
104 |   pre.src-perl:before { content: 'Perl'; }
105 |   pre.src-picolisp:before { content: 'Pico Lisp'; }
106 |   pre.src-scala:before { content: 'Scala'; }
107 |   pre.src-shell:before { content: 'Shell Script'; }
108 |   pre.src-ebnf2ps:before { content: 'ebfn2ps'; }
109 |   /* additional language identifiers per "defun org-babel-execute"
110 |        in ob-*.el */
111 |   pre.src-cpp:before  { content: 'C++'; }
112 |   pre.src-abc:before  { content: 'ABC'; }
113 |   pre.src-coq:before  { content: 'Coq'; }
114 |   pre.src-groovy:before  { content: 'Groovy'; }
115 |   /* additional language identifiers from org-babel-shell-names in
116 |      ob-shell.el: ob-shell is the only babel language using a lambda to put
117 |      the execution function name together. */
118 |   pre.src-bash:before  { content: 'bash'; }
119 |   pre.src-csh:before  { content: 'csh'; }
120 |   pre.src-ash:before  { content: 'ash'; }
121 |   pre.src-dash:before  { content: 'dash'; }
122 |   pre.src-ksh:before  { content: 'ksh'; }
123 |   pre.src-mksh:before  { content: 'mksh'; }
124 |   pre.src-posh:before  { content: 'posh'; }
125 |   /* Additional Emacs modes also supported by the LaTeX listings package */
126 |   pre.src-ada:before { content: 'Ada'; }
127 |   pre.src-asm:before { content: 'Assembler'; }
128 |   pre.src-caml:before { content: 'Caml'; }
129 |   pre.src-delphi:before { content: 'Delphi'; }
130 |   pre.src-html:before { content: 'HTML'; }
131 |   pre.src-idl:before { content: 'IDL'; }
132 |   pre.src-mercury:before { content: 'Mercury'; }
133 |   pre.src-metapost:before { content: 'MetaPost'; }
134 |   pre.src-modula-2:before { content: 'Modula-2'; }
135 |   pre.src-pascal:before { content: 'Pascal'; }
136 |   pre.src-ps:before { content: 'PostScript'; }
137 |   pre.src-prolog:before { content: 'Prolog'; }
138 |   pre.src-simula:before { content: 'Simula'; }
139 |   pre.src-tcl:before { content: 'tcl'; }
140 |   pre.src-tex:before { content: 'TeX'; }
141 |   pre.src-plain-tex:before { content: 'Plain TeX'; }
142 |   pre.src-verilog:before { content: 'Verilog'; }
143 |   pre.src-vhdl:before { content: 'VHDL'; }
144 |   pre.src-xml:before { content: 'XML'; }
145 |   pre.src-nxml:before { content: 'XML'; }
146 |   /* add a generic configuration mode; LaTeX export needs an additional
147 |      (add-to-list 'org-latex-listings-langs '(conf " ")) in .emacs */
148 |   pre.src-conf:before { content: 'Configuration File'; }
149 | 
150 |   table { border-collapse:collapse; }
151 |   caption.t-above { caption-side: top; }
152 |   caption.t-bottom { caption-side: bottom; }
153 |   td, th { vertical-align:top;  }
154 |   th.org-right  { text-align: center;  }
155 |   th.org-left   { text-align: center;   }
156 |   th.org-center { text-align: center; }
157 |   td.org-right  { text-align: right;  }
158 |   td.org-left   { text-align: left;   }
159 |   td.org-center { text-align: center; }
160 |   dt { font-weight: bold; }
161 |   .footpara { display: inline; }
162 |   .footdef  { margin-bottom: 1em; }
163 |   .figure { padding: 1em; }
164 |   .figure p { text-align: center; }
165 |   .equation-container {
166 |     display: table;
167 |     text-align: center;
168 |     width: 100%;
169 |   }
170 |   .equation {
171 |     vertical-align: middle;
172 |   }
173 |   .equation-label {
174 |     display: table-cell;
175 |     text-align: right;
176 |     vertical-align: middle;
177 |   }
178 |   .inlinetask {
179 |     padding: 10px;
180 |     border: 2px solid gray;
181 |     margin: 10px;
182 |     background: #ffffcc;
183 |   }
184 |   #org-div-home-and-up
185 |    { text-align: right; font-size: 70%; white-space: nowrap; }
186 |   textarea { overflow-x: auto; }
187 |   .linenr { font-size: smaller }
188 |   .code-highlighted { background-color: #ffff00; }
189 |   .org-info-js_info-navigation { border-style: none; }
190 |   #org-info-js_console-label
191 |     { font-size: 10px; font-weight: bold; white-space: nowrap; }
192 |   .org-info-js_search-highlight
193 |     { background-color: #ffff00; color: #000000; font-weight: bold; }
194 |   .org-svg { }
195 | </style>
196 | <link rel="stylesheet" href="/static/style.css" type="text/css" />
197 | </head>
198 | <body>
199 | <div id="content" class="content">
200 | <div id="table-of-contents" role="doc-toc">
201 | <h2>Table of Contents</h2>
202 | <div id="text-table-of-contents" role="doc-toc">
203 | <ul>
204 | <li><a href="#orgef91d64">1. CL Git!</a></li>
205 | </ul>
206 | </div>
207 | </div>
208 | 
209 | <div id="outline-container-orgef91d64" class="outline-2">
210 | <h2 id="orgef91d64"><span class="section-number-2">1.</span> CL Git!</h2>
211 | </div>
212 | </div>
213 | <div id="postamble" class="status">
214 | <p class="author">Author: Edward Langley</p>
215 | <p class="date">Created: 2023-10-31 Tue 03:20</p>
216 | <p class="validation"><a href="https://validator.w3.org/check?uri=referer">Validate</a></p>
217 | </div>
218 | </body>
219 | </html>


--------------------------------------------------------------------------------
/pack.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :fwoar.cl-git.pack)
  2 | 
  3 | (defclass pack ()
  4 |   ((%pack :initarg :pack :reader pack-file)
  5 |    (%index :initarg :index :reader index-file)
  6 |    (%repository :initarg :repository :reader fwoar.cl-git:repository)))
  7 | (defun pack (index pack repository)
  8 |   (fw.lu:new 'pack index pack repository))
  9 | 
 10 | (defclass packed-ref (fwoar.cl-git.ref:ref)
 11 |   ((%pack :initarg :pack :reader packed-ref-pack)
 12 |    (%offset :initarg :offset :reader packed-ref-offset)))
 13 | 
 14 | (defmacro with-pack-streams ((idx-sym pack-sym) pack &body body)
 15 |   (alexandria:once-only (pack)
 16 |     `(with-open-file (,idx-sym (index-file ,pack) :element-type 'fwoar.cl-git.types:octet)
 17 |        (with-open-file (,pack-sym (pack-file ,pack) :element-type 'fwoar.cl-git.types:octet)
 18 |          ,@body))))
 19 | 
 20 | (defgeneric idx-toc (pack)
 21 |   (:method ((pack pack))
 22 |     (with-pack-streams (idx-stream _) pack
 23 |       (let* ((object-count (progn (file-position idx-stream 1028)
 24 |                                   (let ((buf (make-array 4)))
 25 |                                     (read-sequence buf idx-stream)
 26 |                                     (fwoar.bin-parser:be->int buf))))
 27 |              (signature 0)
 28 |              (version 4)
 29 |              (fanout 8)
 30 |              (shas (+ fanout
 31 |                       #.(* 4 256)))
 32 |              (packed-crcs (+ shas
 33 |                              (* 20 object-count)))
 34 |              (4-byte-offsets (+ packed-crcs
 35 |                                 (* 4 object-count)))
 36 |              (8-byte-offsets-pro (+ 4-byte-offsets
 37 |                                     (* object-count 4)))
 38 |              (pack-sha (- (file-length idx-stream)
 39 |                           40))
 40 |              (8-byte-offsets (when (/= 8-byte-offsets-pro pack-sha)
 41 |                                8-byte-offsets-pro))
 42 |              (idx-sha (- (file-length idx-stream)
 43 |                          20)))
 44 |         (values (fwoar.cl-git.utils:sym->plist signature
 45 |                                                version
 46 |                                                fanout
 47 |                                                shas
 48 |                                                packed-crcs
 49 |                                                4-byte-offsets
 50 |                                                8-byte-offsets
 51 |                                                pack-sha
 52 |                                                idx-sha)
 53 |                 object-count)))))
 54 | 
 55 | (defun edges-in-fanout (toc s sha)
 56 |   (let* ((fanout-offset (getf toc :fanout)))
 57 |     (file-position s (+ fanout-offset (* 4 (1- (elt sha 0)))))
 58 |     (destructuring-bind ((_ . cur) (__ . next))
 59 |         (fwoar.bin-parser:extract '((cur 4 fwoar.bin-parser:be->int)
 60 |                                     (next 4 fwoar.bin-parser:be->int))
 61 |                                   s)
 62 |       (declare (ignore _ __))
 63 |       (values cur next))))
 64 | 
 65 | (defun extract-object-at-pos (pack pos ref)
 66 |   (with-open-file (p (fwoar.cl-git.pack:pack-file pack) :element-type '(unsigned-byte 8))
 67 |     (file-position p pos)
 68 |     (read-object-from-pack p
 69 |                            (fwoar.cl-git:repository pack)
 70 |                            ref)))
 71 | 
 72 | (defun extract-object-from-pack (pack obj-number ref)
 73 |   (let ((object-offset-in-pack (read-4-byte-offset pack obj-number)))
 74 |     (extract-object-at-pos pack
 75 |                            object-offset-in-pack
 76 |                            ref)))
 77 | 
 78 | (defun find-object-in-pack-files (repo id)
 79 |   (dolist (pack-file (fwoar.cl-git::pack-files repo))
 80 |     (multiple-value-bind (pack mid sha) (find-sha-in-pack pack-file id)
 81 |       (when pack
 82 |         (return-from find-object-in-pack-files
 83 |           (values pack mid sha))))))
 84 | 
 85 | (defun find-sha-between-terms (toc s start end sha)
 86 |   (unless (>= start end)
 87 |     (let* ((sha-offset (getf toc :shas))
 88 |            (mid (floor (+ start end)
 89 |                        2)))
 90 |       (file-position s (+ sha-offset (* 20 mid)))
 91 |       (let ((sha-at-mid (fwoar.cl-git.utils:read-bytes
 92 |                          20 'fwoar.bin-parser:byte-array-to-hex-string s)))
 93 |         (cond ((serapeum:string-prefix-p sha sha-at-mid)
 94 |                (values mid sha-at-mid))
 95 |               ((string< sha sha-at-mid)
 96 |                (find-sha-between-terms toc s start mid sha))
 97 |               ((string> sha sha-at-mid)
 98 |                (find-sha-between-terms toc s (1+ mid) end sha))
 99 |               (t (values mid sha-at-mid)))))))
100 | 
101 | (defun find-sha-in-pack (pack-file id)
102 |   (with-open-file (s (fwoar.cl-git.pack:index-file pack-file)
103 |                      :element-type '(unsigned-byte 8))
104 |     (let ((binary-sha (ironclad:hex-string-to-byte-array id))
105 |           (toc (fwoar.cl-git.pack:idx-toc pack-file)))
106 |       (multiple-value-bind (_ end) (edges-in-fanout toc s binary-sha)
107 |         (declare (ignore _))
108 |         (multiple-value-bind (midpoint sha)
109 |             (find-sha-between-terms toc s 0 end id)
110 |           (and midpoint
111 |                (values pack-file
112 |                        midpoint
113 |                        sha)))))))
114 | 
115 | (defun get-object-from-pack (s)
116 |   (let* ((metadata (fwoar.bin-parser:extract-high s))
117 |          (type (fwoar.cl-git::object-type->sym (fwoar.cl-git::get-object-type metadata)))
118 |          (size (fwoar.cl-git::get-object-size metadata)))
119 |     (case type
120 |       (:ref-delta (error ":ref-delta not implemented yet"))
121 |       (:ofs-delta (get-ofs-delta-offset-streaming s)))
122 |     (let ((decompressed (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s)))
123 |       (values (concatenate
124 |                '(vector fwoar.cl-git.types:octet)
125 |                (ecase type
126 |                  (:commit #.(babel:string-to-octets "commit" :encoding :ascii))
127 |                  (:blob #.(babel:string-to-octets "blob" :encoding :ascii))
128 |                  (:tree #.(babel:string-to-octets "tree" :encoding :ascii)))
129 |                #(32)
130 |                (babel:string-to-octets (prin1-to-string size ):encoding :ascii)
131 |                #(0)
132 |                decompressed)
133 |               size
134 |               (length decompressed)))))
135 | 
136 | (defun get-ofs-delta-offset-streaming (buf)
137 |   (let* ((idx 0))
138 |     (flet ((advance ()
139 |              (read-byte buf)))
140 |       (loop
141 |         for c = (advance)
142 |         for ofs = (logand c 127) then (+ (ash (1+ ofs)
143 |                                               7)
144 |                                          (logand c 127))
145 |         while (> (logand c 128) 0)
146 |         finally
147 |            (return (values (- ofs) idx))))))
148 | 
149 | (defun pack-offset-for-object (index-file obj-number)
150 |   (let ((offset-offset (getf index-file
151 |                              :4-byte-offsets)))
152 |     (+ offset-offset
153 |        (* 4 obj-number))))
154 | 
155 | (defun packed-ref (repo id)
156 |   (multiple-value-bind (pack offset sha) (find-object-in-pack-files repo id)
157 |     (when pack
158 |       (make-instance 'packed-ref
159 |                      :hash sha
160 |                      :repo repo
161 |                      :offset offset
162 |                      :pack pack))))
163 | 
164 | (defun raw-object-for-ref (packed-ref)
165 |   (let ((pack (packed-ref-pack packed-ref)))
166 |     (fwoar.cl-git.pack:with-pack-streams (i p) pack
167 |       (file-position p (read-4-byte-offset pack
168 |                                            (packed-ref-offset packed-ref)))
169 |       (get-object-from-pack p))))
170 | 
171 | (defun read-4-byte-offset (pack obj-number)
172 |   (fwoar.cl-git.pack:with-pack-streams (s _) pack
173 |     (file-position s
174 |                    (pack-offset-for-object (fwoar.cl-git.pack:idx-toc pack)
175 |                                            obj-number))
176 |     (fwoar.cl-git.utils:read-bytes 4 'fwoar.bin-parser:be->int s)))
177 | 
178 | (defun read-object-from-pack (s repository ref)
179 |   (let* ((pos (file-position s))
180 |          (metadata (fwoar.bin-parser:extract-high s))
181 |          (type (fwoar.cl-git::object-type->sym (fwoar.cl-git::get-object-type metadata)))
182 |          (size (fwoar.cl-git::get-object-size metadata))
183 |          (delta-base (case type
184 |                        (:ref-delta (error ":ref-delta not implemented yet"))
185 |                        (:ofs-delta (fwoar.cl-git.delta::get-ofs-delta-offset-streaming s))))
186 |          (decompressed (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s))
187 |          (object-data (fwoar.cl-git::extract-object-of-type type decompressed repository pos (pathname s) ref delta-base)))
188 |     (list (cons :type (fwoar.cl-git::object-type->sym type))
189 |           (cons :decompressed-size size)
190 |           (cons :object-data object-data)
191 |           (cons :raw-data decompressed))))
192 | 
193 | (defun seek-to-object-in-pack (pack idx-stream pack-stream obj-number)
194 |   (let* ((toc (idx-toc pack))
195 |          (offset-offset (getf toc :4-byte-offsets)))
196 |     (file-position idx-stream (+ offset-offset (* 4 obj-number)))
197 |     (let ((object-offset-in-pack (fwoar.cl-git.utils:read-bytes
198 |                                   4 'fwoar.bin-parser:be->int idx-stream)))
199 |       (values (file-position pack-stream object-offset-in-pack)
200 |               object-offset-in-pack))))
201 | 
202 | (defparameter *want-delta* nil)
203 | (defmethod fwoar.cl-git::extract-object ((object packed-ref))
204 |   (let ((maybe-delta (data-lens.lenses:view fwoar.cl-git::*object-data-lens*
205 |                                             (extract-object-from-pack
206 |                                              (fwoar.cl-git.pack::packed-ref-pack object)
207 |                                              (fwoar.cl-git.pack::packed-ref-offset object)
208 |                                              object))))
209 |     (if *want-delta*
210 |         maybe-delta
211 |         (fwoar.cl-git.delta:resolve-delta object
212 |                                           maybe-delta))))
213 | 


--------------------------------------------------------------------------------
/tests/git-objects.lisp:
--------------------------------------------------------------------------------
  1 | (defpackage :fwoar.cl-git.git-objects
  2 |   (:use :cl :fwoar.cl-git.protocol)
  3 |   (:export ))
  4 | (in-package :fwoar.cl-git.git-objects)
  5 | 
  6 | (defparameter *fake-repo* :fwoar.cl-git.git-objects)
  7 | (fiveam:def-suite :fwoar.cl-git.git-objects
  8 |   :description "testing branch resolution"
  9 |   :in :fwoar.cl-git)
 10 | (fiveam:in-suite :fwoar.cl-git.git-objects)
 11 | 
 12 | (defclass fake-ref (fwoar.cl-git.ref:ref)
 13 |   ())
 14 | (defun fake-ref (repo hash)
 15 |   (fwoar.lisputils:new 'fake-ref repo hash))
 16 | 
 17 | (defmethod fwoar.cl-git:ref ((repo (eql *fake-repo*)) hash)
 18 |   (fake-ref repo hash))
 19 | 
 20 | 
 21 | (fiveam:def-test basic-commit ()
 22 |   (let ((fwoar.cl-git:*git-repository* *fake-repo*)
 23 |         (object (fwoar.cl-git::extract-loose-object
 24 |                  nil
 25 |                  (asdf:system-relative-pathname
 26 |                   :co.fwoar.cl-git
 27 |                   "tests/sample-git-objects/hello-world-commit.git-obj")
 28 |                  (make-instance 'fake-ref :hash "the-hash"))))
 29 |     (5am:is (typep object 'fwoar.cl-git:git-commit))
 30 |     (5am:is (equal "hello, git!
 31 | "
 32 |                    (component :message object)))
 33 |     (5am:is (equal ()
 34 |                    (component :parents object)))
 35 |     (5am:is (equal "L Edgley <foo@bar.com> 1605513585 -0800"
 36 |                    (component :author object)))
 37 |     (5am:is (equal "Ed L <el-github@elangley.org> 1605513585 -0800"
 38 |                    (component :committer object)))
 39 |     (5am:is (equal ()
 40 |                    (component :parents object)))
 41 |     (5am:is (equal "1da546ab4697b719efb62f11fd785d6ad3b226d2"
 42 |                    (fwoar.cl-git.ref:ref-hash (component :tree object))))
 43 |     (5am:is (equal *fake-repo*
 44 |                    (fwoar.cl-git.ref:ref-repo (component :tree object))))
 45 |     (5am:is (equal '(("author" "L Edgley <foo@bar.com> 1605513585 -0800")
 46 |                      ("committer" "Ed L <el-github@elangley.org> 1605513585 -0800")
 47 |                      ("tree" "1da546ab4697b719efb62f11fd785d6ad3b226d2"))
 48 |                    (coerce (sort (copy-seq (fwoar.cl-git.commit:metadata object))
 49 |                                  'string-lessp
 50 |                                  :key 'car)
 51 |                            'list)))))
 52 | 
 53 | (fiveam:def-test basic-tree ()
 54 |   (let ((object (fwoar.cl-git::extract-loose-object
 55 |                  nil
 56 |                  (asdf:system-relative-pathname
 57 |                   :co.fwoar.cl-git
 58 |                   "tests/sample-git-objects/hello-world-tree.git-obj")
 59 |                  (make-instance 'fake-ref :hash "the-hash"))))
 60 |     (5am:is (typep object 'fwoar.cl-git::git-tree))
 61 |     (let* ((entries (fwoar.cl-git::entries object))
 62 |            (entry (progn (5am:is (= (length entries) 1))
 63 |                          (car entries))))
 64 |       (5am:is (equal "4b5fa63702dd96796042e92787f464e28f09f17d"
 65 |                      (component :hash entry)))
 66 |       (5am:is (equal "a"
 67 |                      (component :name entry)))
 68 |       (5am:is (equal "100644"
 69 |                      (component :mode entry))))))
 70 | 
 71 | (defparameter *fake-repo* :fwoar.cl-git.git-objects.pack)
 72 | (defmethod fwoar.cl-git:ref ((repo (eql *fake-repo*)) hash)
 73 |   (fake-ref repo hash))
 74 | (defmethod fwoar.cl-git::pack-files ((repo (eql *fake-repo*)))
 75 |   (list
 76 |    (fwoar.cl-git.pack:pack (asdf:system-relative-pathname
 77 |                             :co.fwoar.cl-git
 78 |                             "tests/sample-git-objects/hello-world-pack.idx")
 79 |                            (asdf:system-relative-pathname
 80 |                             :co.fwoar.cl-git
 81 |                             "tests/sample-git-objects/hello-world-pack.pack")
 82 |                            repo)))
 83 | 
 84 | (fiveam:def-test pack-files-commit ()
 85 |   (let* ((hash "7d7b56a6a64e090041f55293511f48aba6699f1a")
 86 |          (ref (fwoar.cl-git.pack:packed-ref
 87 |                :fwoar.cl-git.git-objects.pack
 88 |                hash))
 89 |          (object (progn (fiveam:is (not (null ref)))
 90 |                         (fiveam:is (equal hash (fwoar.cl-git.ref:ref-hash ref)))
 91 |                         (fiveam:is (equal *fake-repo* (fwoar.cl-git.ref:ref-repo ref)))
 92 |                         (fwoar.cl-git:extract-object ref))))
 93 | 
 94 |     (5am:is (typep object 'fwoar.cl-git:git-commit))
 95 |     (5am:is (equal "hello, git!
 96 | "
 97 |                    (component :message object)))
 98 |     (5am:is (equal ()
 99 |                    (component :parents object)))
100 |     (5am:is (equal "L Edgley <foo@bar.com> 1605513585 -0800"
101 |                    (component :author object)))
102 |     (5am:is (equal "Ed L <el-github@elangley.org> 1605513585 -0800"
103 |                    (component :committer object)))
104 |     (5am:is (equal ()
105 |                    (component :parents object)))
106 |     (let ((fwoar.cl-git:*git-repository* *fake-repo*))
107 |       (5am:is (equal "1da546ab4697b719efb62f11fd785d6ad3b226d2"
108 |                      (fwoar.cl-git.ref:ref-hash (component :tree object))))
109 |       (5am:is (equal *fake-repo*
110 |                      (fwoar.cl-git.ref:ref-repo (component :tree object)))))
111 |     (5am:is (equal '(("author" "L Edgley <foo@bar.com> 1605513585 -0800")
112 |                      ("committer" "Ed L <el-github@elangley.org> 1605513585 -0800")
113 |                      ("tree" "1da546ab4697b719efb62f11fd785d6ad3b226d2"))
114 |                    (coerce (sort (copy-seq (fwoar.cl-git.commit::metadata object))
115 |                                  'string-lessp
116 |                                  :key 'car)
117 |                            'list)))))
118 | 
119 | (fiveam:def-test pack-files-tree ()
120 |   (let* ((hash "1da546ab4697b719efb62f11fd785d6ad3b226d2")
121 |          (ref (fwoar.cl-git.pack:packed-ref
122 |                :fwoar.cl-git.git-objects.pack
123 |                hash))
124 |          (object (progn (fiveam:is (not (null ref)))
125 |                         (fiveam:is (equal hash (fwoar.cl-git.ref:ref-hash ref)))
126 |                         (fiveam:is (equal *fake-repo* (fwoar.cl-git.ref:ref-repo ref)))
127 |                         (fwoar.cl-git:extract-object ref))))
128 |     (5am:is (typep object 'fwoar.cl-git::git-tree))
129 |     (let* ((entries (fwoar.cl-git::entries object))
130 |            (entry (progn (5am:is (= (length entries) 1))
131 |                          (car entries))))
132 |       (5am:is (equal "4b5fa63702dd96796042e92787f464e28f09f17d"
133 |                      (component :hash entry)))
134 |       (5am:is (equal "a"
135 |                      (component :name entry)))
136 |       (5am:is (equal "100644"
137 |                      (component :mode entry))))))
138 | 
139 | (fiveam:def-test pack-files-blob ()
140 |   (let* ((hash "4b5fa63702dd96796042e92787f464e28f09f17d")
141 |          (ref (fwoar.cl-git.pack:packed-ref
142 |                :fwoar.cl-git.git-objects.pack
143 |                hash))
144 |          (object (progn (fiveam:is (not (null ref)))
145 |                         (fiveam:is (equal hash (fwoar.cl-git.ref:ref-hash ref)))
146 |                         (fiveam:is (equal *fake-repo* (fwoar.cl-git.ref:ref-repo ref)))
147 |                         (fwoar.cl-git:extract-object ref))))
148 |     (5am:is (typep object 'fwoar.cl-git.blob:blob))
149 |     (5am:is (equal "hello, world
150 | "                   (babel:octets-to-string
151 |                      (fwoar.cl-git.blob:data
152 |                       (fwoar.cl-git:extract-object
153 |                        (fwoar.cl-git.pack:packed-ref
154 |                         :fwoar.cl-git.git-objects.pack
155 |                         "4b5fa63702dd96796042e92787f464e28f09f17d")))
156 |                      :encoding :utf-8)))))
157 | 
158 | 
159 | (defparameter *fake-repo-2* :fwoar.cl-git.git-objects.pack-2)
160 | (defclass fake-ref-2 (fake-ref)
161 |   ())
162 | (defun fake-ref-2 (repo hash)
163 |   (fwoar.lisputils:new 'fake-ref-2 repo hash))
164 | (defmethod fwoar.cl-git.pack:packed-ref-pack ((ref fake-ref-2))
165 |   (let* ((pack-file (asdf:system-relative-pathname
166 |                      :co.fwoar.cl-git/tests
167 |                      "tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack"))
168 |          (index-file (asdf:system-relative-pathname
169 |                       :co.fwoar.cl-git/tests
170 |                       "tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx")))
171 |     (make-instance 'fwoar.cl-git.pack:pack
172 |                    :repository nil
173 |                    :index index-file
174 |                    :pack pack-file)))
175 | (defmethod fwoar.cl-git.pack:packed-ref-offset ((ref fake-ref-2))
176 |   (nth-value 1 (fwoar.cl-git.pack::find-sha-in-pack (fwoar.cl-git.pack:packed-ref-pack ref)
177 |                                                     (fwoar.cl-git.ref:ref-hash ref))))
178 | (defmethod fwoar.cl-git:ref ((repo (eql *fake-repo-2*)) hash)
179 |   (fake-ref-2 repo hash))
180 | (defmethod fwoar.cl-git::pack-files ((repo (eql *fake-repo-2*)))
181 |   (list
182 |    (let* ((pack-file (asdf:system-relative-pathname
183 |                       :co.fwoar.cl-git/tests
184 |                       "tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack"))
185 |           (index-file (asdf:system-relative-pathname
186 |                        :co.fwoar.cl-git/tests
187 |                        "tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx")))
188 |      (make-instance 'fwoar.cl-git.pack:pack
189 |                     :repository nil
190 |                     :index index-file
191 |                     :pack pack-file))))
192 | 
193 | (fiveam:def-test pack-files-offsets ()
194 |   (let* ((fwoar.cl-git.pack::*want-delta* t)
195 |          (expectations-file
196 |            (asdf:system-relative-pathname
197 |             :co.fwoar.cl-git/tests
198 |             "tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.delta-bases"))
199 |          (expectations (uiop:read-file-form expectations-file)))
200 |     (loop for (ref . base-offset) in expectations
201 |           do (5am:is (equal base-offset
202 |                             (second
203 |                              (fwoar.cl-git.delta:base
204 |                               (fwoar.cl-git:extract-object
205 |                                (fwoar.cl-git.pack:packed-ref *fake-repo-2* ref)))))))
206 |     ))
207 | 
208 | (fiveam:def-test test-pack-roundtrip ()
209 |   (let ((shas '("b7df27f1c873f5796462cdce8aabf46c1b3e3ff2"
210 |                 "d468a84b54e73968d9426af96c1944c80ffa3a4f"
211 |                 "4cc1ee4919056be337922f0a57e0bfe7281b8c57"
212 |                 "4d4ea31b3d349ffd06e97469743f824578555edf"
213 |                 "7df80f061ae5bf6177a1c0888d085281be2801e1"
214 |                 "846489f7ae91bfaf0c78a6939b177697a89a81d0"
215 |                 "bc7ccfbd98e684d9188b6833ec39f7d1d72edfdf"
216 |                 "6089dc804725925c30d621c3d2f72c8b1b14bc17"
217 |                 "500325f0022a9adc41929b58fbb5c2d55b60524b"
218 |                 "72870f874f3ef712d9bea352e300b9b5f6aa60ee"
219 |                 "0c24c8f931ad5c0d2e5add01710678abddd3ec03"
220 |                 "e499f64d2ead6d14d74fe0f484d06f33bbd38261"
221 |                 "efe60b9f578c4966cb2258ace1661edd080ca0dc"
222 |                 "821ddf96c37e65ccc9a0f4bfe2b8ac6e255a2cb6"
223 |                 "077088c8c359489ed1f6d8e441ec76438076542e"
224 |                 "e1f7c67a8774d65bb941eeb2b41f71f333fa1a94"
225 |                 "ff33293b415cc1907a6071650d045b3dffd8e5c0"
226 |                 "e98a5866a0148fe573197e8c48a543fc3039f1bc"
227 |                 "f09f6f1b30fd3579649f8abf23719901496accde"
228 |                 "692f03101cd8ebf6830618805217b6348ddfd3a8"
229 |                 "f710cf28a9f511911e1def85c4cb98bfbcfd9017"
230 |                 "0b3ed8597e1968306c3732f7507256694357009f"
231 |                 "88e003ecce9e9420632d0bab857270819e922674"
232 |                 "5c205fb851671ff0938c86d7c0cc742f2ca2d32f"
233 |                 "8f6a890959795d2b340615a074170ce404d7f2b9"
234 |                 "e079ee4a351de0841c09f87dffdee333ef936673"
235 |                 "347e97b1efa866e3bd00bbfb68c5b660e378f3b5"
236 |                 "ad9b8a82065f70aac3da61e845ab2cd37a71e649"
237 |                 "83674eea1c0a2f2df2886b38b9539ed1193b00c3"
238 |                 "e623be68f6fd0c36dee0145a4c95dbbf85174774"
239 |                 "a7c6e622cca243456481ffbeafaab739e4687681"
240 |                 "b0bbceded2a17389a9a6ddc765398a257199c78e"
241 |                 "82c268c1e7afe543ac14bf2748df53a729fa35cb"
242 |                 "2fb0a2fc57327dc6a533b596a0643ad991847b3b"
243 |                 "f1a12e8a19691afcd5ee08d615a1b4d14b5051f9"
244 |                 "991d0162019ac2e21592553a10ab16eb337222d8"
245 |                 "94acd859d12ae611e631cfd66b7ed164d6b5ac89"
246 |                 "f115dea85d331cb5c01e247d77886bba2690e726"
247 |                 "488cc8612e7b24a1737a260b10bff0037b55636e"
248 |                 "be4ef77fd7da17393e02ef933e8d21e67be7fbec"
249 |                 "a84a7f712398c1659f2e809d903ae51b44cf7f4a"
250 |                 "8a9fe9f77149f74fed5c05388be8e5ffd4a31678"
251 |                 "e69de29bb2d1d6434b8b29ae775ad8c2e48c5391"
252 |                 "0306819e780fa57dc3bf6b99a0a059670b605ae0"
253 |                 "a52be677adeda194bcdfdd12740f00535b6b0997"
254 |                 "fb265bb344fee602dc175d1d5eac6bdc2d013a10"
255 |                 "9db42f61f21e11529b9bc1c52ee118c03d663c04"
256 |                 "197e10755343900cfbcb7fc6d863d4b3231e74d4"
257 |                 "83324cbcb0ef5b778588cc6ba547c43c46bff8c6"
258 |                 "88988d16b44fc03054807882783ed176162228f4"
259 |                 "d2818bb88b8ec5235a8ae91309f31ba58d941d42"
260 |                 "c1b83741c4dc3104f1686c20b143300db0a0e258"
261 |                 "7e24a6a7a4349497fce06830fa132e9a8ef6fd06"
262 |                 "9567a5825bf65b7e90d6f9a02574a00b53af9171"
263 |                 "b757bb704b4c7a54622b7bd197ad5c1ea51ef2cc"
264 |                 "ccccc07814249fc7a129bfffd07f09704d0f017b"
265 |                 "a4b5b13466bb8e80d6f8015e2bf27667533ea441"
266 |                 "3d894d70b6e1036034f22654408a382b6e303335"
267 |                 "fed9d70ab2441d8c8abf19648668f885ed5a4986"
268 |                 "b50c3a28d0bdab4d922d4b363cada4c582349178"
269 |                 "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
270 |                 "71da880a8be0356b67d593fac348dfe429d1e0b6"
271 |                 "cab7cafae3b61c5b101ee914cd4f5c8357e77fad"
272 |                 "f03a8d1b4cea085ee9555037d09bca2dbfb990cb")))
273 |     (loop for commit in shas
274 |           for obj = (fwoar.cl-git.pack:raw-object-for-ref
275 |                      (fwoar.cl-git:ref :fwoar.cl-git.git-objects.pack-2 commit))
276 |           do (5am:is (equal (crypto:byte-array-to-hex-string
277 |                              (crypto:digest-sequence :sha1 obj))
278 |                             commit)))))
279 | 
280 | (fiveam:def-test pack-file-apply-delta-commands ()
281 |   (flet ((test-ref (ref)
282 |            (let* ((expectations-file
283 |                     (asdf:system-relative-pathname
284 |                      :co.fwoar.cl-git/tests
285 |                      (format nil "tests/sample-git-objects/blob-~a-fixture"
286 |                              (subseq ref 0 7))))
287 |                   (expectations
288 |                     (alexandria:read-file-into-byte-vector expectations-file)))
289 |              (5am:is
290 |               (serapeum:vector=
291 |                expectations
292 |                (fwoar.cl-git.blob:data
293 |                 (fwoar.cl-git:extract-object
294 |                  (fwoar.cl-git.pack:packed-ref :fwoar.cl-git.git-objects.pack-2 ref))))))))
295 | 
296 |     (test-ref "87c2b9b2dfaa1fbf66b3fe88d3a925593886b159")
297 | 
298 |     (test-ref "9776df71b5ddf298c56e99b7291f9e68906cf049")
299 | 
300 |     (test-ref "31576396aff0fff28f69e0ef84571c0dc8cc43ec")
301 | 
302 |     (test-ref "c516dfc248544509c3ae58e3a8c2ab81c225aa9c")
303 | 
304 |     (test-ref "53d13ed284f8b57297d1b216e2bab7fb43f8db60")
305 | 
306 |     (test-ref "912d31a169ddf1fca122d4c6fe1b1e6be7cd1176")))
307 | 


--------------------------------------------------------------------------------