sx-git extension: git-wire export adapter — byte-exact loose objects + SHA-1 (TDD)
lib/git/sha1.sx: SHA-1 in pure SX over host bitwise prims (FIPS vectors + multi-block verified). lib/git/export.sx: native objects -> git payloads "<type> <len>\0<body>" with real git identity, golden-verified against git CLI (hash-object/mktree/commit-tree/mktag with pinned idents): tree entry sorting with dirs keyed "name/", raw 20-byte child shas, "40000" subtree mode, :mode overrides, deterministic ident defaults, trailing-newline message rule. export-closure/export-set emit a host-writable object table. Adapter-at-the-edge: native model untouched; zlib/packfiles remain host-side concerns. 25/25, total 252/252. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
202
lib/git/tests/export.sx
Normal file
202
lib/git/tests/export.sx
Normal file
@@ -0,0 +1,202 @@
|
||||
; Extension — git-wire export adapter. Golden values generated with real git
|
||||
; (hash-object/mktree/commit-tree with pinned idents) — the adapter must
|
||||
; reproduce byte-exact payloads and SHA-1s.
|
||||
|
||||
; ---- SHA-1 vectors ----
|
||||
(git-test
|
||||
"sha1 of empty"
|
||||
(git/sha1-hex "")
|
||||
"da39a3ee5e6b4b0d3255bfef95601890afd80709")
|
||||
(git-test
|
||||
"sha1 of abc"
|
||||
(git/sha1-hex "abc")
|
||||
"a9993e364706816aba3e25717850c26c9cd0d89d")
|
||||
(git-test
|
||||
"sha1 crossing the padding boundary"
|
||||
(git/sha1-hex "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
|
||||
"84983e441c3bd26ebaae4aa1f95129e5e54670f1")
|
||||
(define
|
||||
gex-rep
|
||||
(fn
|
||||
(s n)
|
||||
(if (= n 0) "" (str s (gex-rep s (- n 1))))))
|
||||
(git-test
|
||||
"sha1 over multiple blocks"
|
||||
(git/sha1-hex (gex-rep "a" 200))
|
||||
"e61cfffe0d9195a525fc6cf06ca2d77119c24a40")
|
||||
(git-test
|
||||
"raw digest is 20 bytes"
|
||||
(= (string-length (git/sha1-raw "abc")) 20)
|
||||
true)
|
||||
(git-test
|
||||
"hex->raw round-trips through byte codes"
|
||||
(char-code (substring (git/hex->raw "ff00a1") 1 2))
|
||||
0)
|
||||
|
||||
; ---- fixture (mirrors the golden git repo exactly) ----
|
||||
(define gex-db (persist/mem-backend))
|
||||
(define gex (git/repo gex-db))
|
||||
(define gex-hello (git/write-blob gex "hello\n"))
|
||||
(define gex-sub (git/write-blob gex "sub\n"))
|
||||
(define gex-hello2 (git/write-blob gex "hello2\n"))
|
||||
(define gex-subtxt (git/write-blob gex "not a dir\n"))
|
||||
(define
|
||||
gex-tsub
|
||||
(git/write
|
||||
gex
|
||||
(git/tree (assoc {} "c.txt" (git/tree-entry "blob" gex-sub)))))
|
||||
(define
|
||||
gex-t1
|
||||
(git/write
|
||||
gex
|
||||
(git/tree
|
||||
(assoc
|
||||
(assoc {} "a.txt" (git/tree-entry "blob" gex-hello))
|
||||
"sub"
|
||||
(git/tree-entry "tree" gex-tsub)))))
|
||||
(define
|
||||
gex-t2
|
||||
(git/write
|
||||
gex
|
||||
(git/tree
|
||||
(assoc
|
||||
(assoc {} "a.txt" (git/tree-entry "blob" gex-hello2))
|
||||
"sub"
|
||||
(git/tree-entry "tree" gex-tsub)))))
|
||||
(define
|
||||
gex-t3
|
||||
(git/write
|
||||
gex
|
||||
(git/tree
|
||||
(assoc
|
||||
(assoc
|
||||
(assoc {} "a.txt" (git/tree-entry "blob" gex-hello))
|
||||
"sub"
|
||||
(git/tree-entry "tree" gex-tsub))
|
||||
"sub.txt"
|
||||
(git/tree-entry "blob" gex-subtxt)))))
|
||||
(define
|
||||
gex-t4
|
||||
(git/write
|
||||
gex
|
||||
(git/tree
|
||||
(assoc
|
||||
{}
|
||||
"x.sh"
|
||||
(merge (git/tree-entry "blob" gex-hello) {:mode "100755"})))))
|
||||
(define gex-c1 (git/write gex (git/commit gex-t1 (list) {:message "c1" :tz "+0000" :email "ada@sx" :time 1700000000 :author "ada"})))
|
||||
(define gex-c2 (git/write gex (git/commit gex-t2 (list gex-c1) {:message "c2" :tz "+0000" :email "ada@sx" :time 1700000100 :author "ada"})))
|
||||
(define gex-tag (git/write gex (git/tag gex-c1 "v1" {:message "first" :tz "+0000" :email "ada@sx" :time 1700000200 :author "ada"})))
|
||||
|
||||
; ---- blob payloads ----
|
||||
(git-test
|
||||
"blob export matches git hash-object"
|
||||
(git/export-sha gex gex-hello)
|
||||
"ce013625030ba8dba906f756967f9e9ca394464a")
|
||||
(git-test
|
||||
"empty blob is git's famous e69de29"
|
||||
(git/export-sha gex (git/write-blob gex ""))
|
||||
"e69de29bb2d1d6434b8b29ae775ad8c2e48c5391")
|
||||
(git-test
|
||||
"blob payload bytes are '<type> <len>NUL<data>'"
|
||||
(equal?
|
||||
(get (git/export gex gex-hello) :bytes)
|
||||
(str "blob 6" git/export-nul "hello\n"))
|
||||
true)
|
||||
|
||||
; ---- tree payloads (git sort rules, raw child shas) ----
|
||||
(git-test
|
||||
"leaf tree matches git mktree"
|
||||
(git/export-sha gex gex-tsub)
|
||||
"2282cb13a4b7999406280aac69e4fc45260fb909")
|
||||
(git-test
|
||||
"nested tree matches git mktree"
|
||||
(git/export-sha gex gex-t1)
|
||||
"77918032f1f02d785d3bc222ab29b4969cd83854")
|
||||
(git-test
|
||||
"modified tree matches git mktree"
|
||||
(git/export-sha gex gex-t2)
|
||||
"aaf1022f60da7b14837d52232a75fa3fc2d3e3a7")
|
||||
(git-test
|
||||
"directories sort as 'name/': sub.txt before dir sub"
|
||||
(git/export-sha gex gex-t3)
|
||||
"58c19e599aa988a4ee6fba065f8801c700777a3d")
|
||||
(git-test
|
||||
"entry :mode override (100755) is honored"
|
||||
(git/export-sha gex gex-t4)
|
||||
"54925a269ee97325d7da275bda4250d83b338e65")
|
||||
(git-test
|
||||
"the empty tree is git's 4b825dc"
|
||||
(git/export-sha gex (git/write gex (git/tree {})))
|
||||
"4b825dc642cb6eb9a060e54bf8d69288fbee4904")
|
||||
|
||||
; ---- commit payloads ----
|
||||
(git-test
|
||||
"root commit matches git commit-tree"
|
||||
(git/export-sha gex gex-c1)
|
||||
"baeeb137fc255e62c1e3b980e70b2d8dd2be6e83")
|
||||
(git-test
|
||||
"child commit matches git commit-tree -p"
|
||||
(git/export-sha gex gex-c2)
|
||||
"a8eac1e101bf4f6b7d614a4384592a981a67ce92")
|
||||
(git-test
|
||||
"commit body is byte-exact"
|
||||
(get (git/export gex gex-c1) :bytes)
|
||||
(str
|
||||
"commit 127"
|
||||
git/export-nul
|
||||
"tree 77918032f1f02d785d3bc222ab29b4969cd83854\n"
|
||||
"author ada <ada@sx> 1700000000 +0000\n"
|
||||
"committer ada <ada@sx> 1700000000 +0000\n"
|
||||
"\n"
|
||||
"c1\n"))
|
||||
|
||||
; ---- tag payload ----
|
||||
(git-test
|
||||
"annotated tag matches git hash-object -t tag"
|
||||
(git/export-sha gex gex-tag)
|
||||
"b28ebfd4213f10fd0c2127d1d14a26179fcf12e0")
|
||||
(git-test
|
||||
"tag body names the target type"
|
||||
(contains? (get (git/export gex gex-tag) :bytes) "type commit")
|
||||
true)
|
||||
|
||||
; ---- closure + set ----
|
||||
(git-test
|
||||
"closure of the child commit covers all 8 reachable objects"
|
||||
(len (keys (git/export-closure gex gex-c2)))
|
||||
8)
|
||||
(git-test
|
||||
"closure of the tag reaches through the commit"
|
||||
(len (keys (git/export-closure gex gex-tag)))
|
||||
6)
|
||||
(git-test
|
||||
"export-set is keyed by git sha with the head marked"
|
||||
(let
|
||||
((s (git/export-set gex gex-c2)))
|
||||
(list
|
||||
(get s :head)
|
||||
(get
|
||||
(get (get s :objects) "baeeb137fc255e62c1e3b980e70b2d8dd2be6e83")
|
||||
:type)))
|
||||
(list "a8eac1e101bf4f6b7d614a4384592a981a67ce92" "commit"))
|
||||
|
||||
; ---- defaults + trailing newline rule ----
|
||||
(git-test
|
||||
"idents default deterministically"
|
||||
(contains?
|
||||
(get
|
||||
(git/export gex (git/write gex (git/commit gex-t1 (list) {:message "m\n"})))
|
||||
:bytes)
|
||||
"author sx <sx@sx> 0 +0000")
|
||||
true)
|
||||
(git-test
|
||||
"message gains a trailing newline when missing"
|
||||
(let
|
||||
((e1 (git/export gex (git/write gex (git/commit gex-t1 (list) {:message "m"}))))
|
||||
(e2
|
||||
(git/export
|
||||
gex
|
||||
(git/write gex (git/commit gex-t1 (list) {:message "m\n" :x 1})))))
|
||||
(equal? (get e1 :sha1) (get e2 :sha1)))
|
||||
true)
|
||||
Reference in New Issue
Block a user