├── .github └── workflows │ └── test.yaml ├── .gitignore ├── .projectile ├── LICENSE ├── README.org ├── blob.lisp ├── branch.lisp ├── co.fwoar.cl-git.asd ├── commit.lisp ├── delta.lisp ├── docker-run └── main.lisp ├── docs ├── CNAME ├── index.html ├── index.org └── static │ └── style.css ├── extract.lisp ├── git.lisp ├── graph.lisp ├── model.lisp ├── pack.lisp ├── package.lisp ├── porcelain.lisp ├── protocol.lisp ├── ref.lisp ├── repository.lisp ├── tests ├── branch-resolution.lisp ├── git-objects.lisp ├── sample-git-objects │ ├── blob-3157639-fixture │ ├── blob-53d13ed-fixture │ ├── blob-87c2b9b-fixture │ ├── blob-912d31a-fixture │ ├── blob-9776df7-fixture │ ├── blob-c516dfc-fixture │ ├── hello-world-commit.git-obj │ ├── hello-world-pack.idx │ ├── hello-world-pack.pack │ ├── hello-world-pack.txt │ ├── hello-world-tree.git-obj │ ├── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.delta-bases │ ├── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx │ └── pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack └── tests.lisp ├── tree.lisp ├── types.lisp ├── undelta.lisp └── util.lisp /.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 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | *.64xfasl 4 | -------------------------------------------------------------------------------- /.projectile: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/.projectile -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | : # {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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 " 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 " 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /docs/CNAME: -------------------------------------------------------------------------------- 1 | cl-git.fiddlerwoaroof.com -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | ‎ 10 | 11 | 12 | 196 | 197 | 198 | 199 |
200 |
201 |

Table of Contents

202 |
203 | 206 |
207 |
208 | 209 |
210 |

1. CL Git!

211 |
212 |
213 |
214 |

Author: Edward Langley

215 |

Created: 2023-10-31 Tue 03:20

216 |

Validate

217 |
218 | 219 | -------------------------------------------------------------------------------- /docs/index.org: -------------------------------------------------------------------------------- 1 | #+HTML_HEAD: 2 | 3 | * CL Git! 4 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 1605513585 -0800" 36 | (component :author object))) 37 | (5am:is (equal "Ed L 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 1605513585 -0800") 46 | ("committer" "Ed L 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 1605513585 -0800" 101 | (component :author object))) 102 | (5am:is (equal "Ed L 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 1605513585 -0800") 112 | ("committer" "Ed L 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 " 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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/hello-world-commit.git-obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/hello-world-commit.git-obj -------------------------------------------------------------------------------- /tests/sample-git-objects/hello-world-pack.idx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/hello-world-pack.idx -------------------------------------------------------------------------------- /tests/sample-git-objects/hello-world-pack.pack: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/hello-world-pack.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 | -------------------------------------------------------------------------------- /tests/sample-git-objects/hello-world-tree.git-obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/hello-world-tree.git-obj -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.idx -------------------------------------------------------------------------------- /tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fiddlerwoaroof/cl-git/595d4a88d67475665f18291146b20bbc654fe05e/tests/sample-git-objects/pack-a0533639fdee4493fdbfc1b701872ace63b95e5f.pack -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :fwoar.cl-git.types) 2 | 3 | (deftype octet () 4 | '(unsigned-byte 8)) 5 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------