sx-git extension: git-wire import — the inverse adapter, round-trip law (TDD)
lib/git/import.sx parses loose payloads back to native objects bottom-up over an export-set table: tree mode/name/raw-sha triples, ident lines, header/message split, committer stored only when distinct so export defaults regenerate identical bytes. Laws verified: export->import->export is BYTE-IDENTICAL (head sha + every object), imported blobs/default-mode trees regain their original native cids, 100755/tags/distinct-committer/ multi-line messages all survive. 15/15, total 267/267. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
@@ -13,7 +13,7 @@ if [ ! -x "$SX_SERVER" ]; then
|
|||||||
exit 1
|
exit 1
|
||||||
fi
|
fi
|
||||||
|
|
||||||
SUITES=(object ref dag worktree diff merge porcelain export)
|
SUITES=(object ref dag worktree diff merge porcelain export import)
|
||||||
|
|
||||||
OUT_JSON="lib/git/scoreboard.json"
|
OUT_JSON="lib/git/scoreboard.json"
|
||||||
OUT_MD="lib/git/scoreboard.md"
|
OUT_MD="lib/git/scoreboard.md"
|
||||||
@@ -51,6 +51,7 @@ run_suite() {
|
|||||||
(load "lib/git/porcelain.sx")
|
(load "lib/git/porcelain.sx")
|
||||||
(load "lib/git/sha1.sx")
|
(load "lib/git/sha1.sx")
|
||||||
(load "lib/git/export.sx")
|
(load "lib/git/export.sx")
|
||||||
|
(load "lib/git/import.sx")
|
||||||
(epoch 2)
|
(epoch 2)
|
||||||
(eval "(define git-test-pass 0)")
|
(eval "(define git-test-pass 0)")
|
||||||
(eval "(define git-test-fail 0)")
|
(eval "(define git-test-fail 0)")
|
||||||
|
|||||||
244
lib/git/import.sx
Normal file
244
lib/git/import.sx
Normal file
@@ -0,0 +1,244 @@
|
|||||||
|
; lib/git/import.sx — git-wire IMPORT (inverse of export.sx).
|
||||||
|
; Parses loose-object payloads "<type> <len>\0<body>" back into native
|
||||||
|
; objects, bottom-up over an export-set-shaped table {sha1 -> {:bytes ...}}.
|
||||||
|
; Wire round-trip (bytes -> native -> bytes) is byte-exact: messages kept
|
||||||
|
; verbatim, non-default tree modes preserved as entry :mode, committer
|
||||||
|
; fields stored only when they differ from the author (so export's defaults
|
||||||
|
; regenerate identical bytes). Native cids of imported blobs/trees with
|
||||||
|
; default modes equal the originals'.
|
||||||
|
; Requires: lib/git/object.sx, lib/git/sha1.sx, lib/git/export.sx.
|
||||||
|
|
||||||
|
; ---- scanning ----
|
||||||
|
(define
|
||||||
|
git/import-index-of
|
||||||
|
(fn
|
||||||
|
(s ch i n)
|
||||||
|
(cond
|
||||||
|
((>= i n) -1)
|
||||||
|
((equal? (substring s i (+ i 1)) ch) i)
|
||||||
|
(else (git/import-index-of s ch (+ i 1) n)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-find
|
||||||
|
(fn (s ch from) (git/import-index-of s ch from (string-length s))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-rfind
|
||||||
|
(fn
|
||||||
|
(s ch i)
|
||||||
|
(cond
|
||||||
|
((< i 0) -1)
|
||||||
|
((equal? (substring s i (+ i 1)) ch) i)
|
||||||
|
(else (git/import-rfind s ch (- i 1))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-find2
|
||||||
|
(fn
|
||||||
|
(s i n)
|
||||||
|
(cond
|
||||||
|
((> (+ i 2) n) -1)
|
||||||
|
((equal? (substring s i (+ i 2)) "\n\n") i)
|
||||||
|
(else (git/import-find2 s (+ i 1) n)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/raw->hex-go
|
||||||
|
(fn
|
||||||
|
(raw i n acc)
|
||||||
|
(if
|
||||||
|
(>= i n)
|
||||||
|
acc
|
||||||
|
(git/raw->hex-go
|
||||||
|
raw
|
||||||
|
(+ i 1)
|
||||||
|
n
|
||||||
|
(str
|
||||||
|
acc
|
||||||
|
(git/sha1-byte-hex (char-code (substring raw i (+ i 1)))))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/raw->hex
|
||||||
|
(fn (raw) (git/raw->hex-go raw 0 (string-length raw) "")))
|
||||||
|
|
||||||
|
; ---- payload header ----
|
||||||
|
(define
|
||||||
|
git/import-payload
|
||||||
|
(fn
|
||||||
|
(bytes)
|
||||||
|
(let
|
||||||
|
((sp (git/import-find bytes " " 0))
|
||||||
|
(z (git/import-find bytes git/export-nul 0)))
|
||||||
|
{:type (substring bytes 0 sp) :body (substring bytes (+ z 1) (string-length bytes))})))
|
||||||
|
|
||||||
|
; ---- tree body: "<mode> <name>\0<20 raw sha>" sequence ----
|
||||||
|
(define
|
||||||
|
git/import-tree-entries
|
||||||
|
(fn
|
||||||
|
(body i n acc)
|
||||||
|
(if
|
||||||
|
(>= i n)
|
||||||
|
acc
|
||||||
|
(let
|
||||||
|
((sp (git/import-find body " " i)))
|
||||||
|
(let
|
||||||
|
((z (git/import-find body git/export-nul sp)))
|
||||||
|
(git/import-tree-entries
|
||||||
|
body
|
||||||
|
(+ z 21)
|
||||||
|
n
|
||||||
|
(append acc (list {:name (substring body (+ sp 1) z) :sha (git/raw->hex (substring body (+ z 1) (+ z 21))) :mode (substring body i sp)}))))))))
|
||||||
|
|
||||||
|
; ---- ident: "name <email> time tz" ----
|
||||||
|
(define
|
||||||
|
git/import-ident
|
||||||
|
(fn
|
||||||
|
(line)
|
||||||
|
(let
|
||||||
|
((lt (git/import-rfind line "<" (- (string-length line) 1)))
|
||||||
|
(gt (git/import-rfind line ">" (- (string-length line) 1))))
|
||||||
|
(let
|
||||||
|
((rest (substring line (+ gt 2) (string-length line))))
|
||||||
|
(let ((sp (git/import-find rest " " 0))) {:name (substring line 0 (max 0 (- lt 1))) :tz (substring rest (+ sp 1) (string-length rest)) :email (substring line (+ lt 1) gt) :time (parse-int (substring rest 0 sp))})))))
|
||||||
|
|
||||||
|
; ---- commit / tag bodies ----
|
||||||
|
(define
|
||||||
|
git/import-headers
|
||||||
|
(fn
|
||||||
|
(body)
|
||||||
|
(let
|
||||||
|
((cut (git/import-find2 body 0 (string-length body))))
|
||||||
|
{:message (substring body (+ cut 2) (string-length body)) :lines (split (substring body 0 cut) "\n")})))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-commit-parse
|
||||||
|
(fn
|
||||||
|
(body)
|
||||||
|
(let
|
||||||
|
((h (git/import-headers body)))
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc line)
|
||||||
|
(cond
|
||||||
|
((starts-with? line "tree ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:tree (substring line 5 (string-length line))))
|
||||||
|
((starts-with? line "parent ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:parents (append
|
||||||
|
(get acc :parents)
|
||||||
|
(list (substring line 7 (string-length line))))))
|
||||||
|
((starts-with? line "author ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:author (git/import-ident
|
||||||
|
(substring line 7 (string-length line)))))
|
||||||
|
((starts-with? line "committer ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:committer (git/import-ident
|
||||||
|
(substring line 10 (string-length line)))))
|
||||||
|
(else acc)))
|
||||||
|
{:message (get h :message) :parents (list)}
|
||||||
|
(get h :lines)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-tag-parse
|
||||||
|
(fn
|
||||||
|
(body)
|
||||||
|
(let
|
||||||
|
((h (git/import-headers body)))
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc line)
|
||||||
|
(cond
|
||||||
|
((starts-with? line "object ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:object (substring line 7 (string-length line))))
|
||||||
|
((starts-with? line "tag ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:tag (substring line 4 (string-length line))))
|
||||||
|
((starts-with? line "tagger ")
|
||||||
|
(assoc
|
||||||
|
acc
|
||||||
|
:tagger (git/import-ident
|
||||||
|
(substring line 7 (string-length line)))))
|
||||||
|
(else acc)))
|
||||||
|
{:message (get h :message)}
|
||||||
|
(get h :lines)))))
|
||||||
|
|
||||||
|
; ident dict -> native commit meta fields
|
||||||
|
(define git/import-author-meta (fn (a) {:tz (get a :tz) :email (get a :email) :time (get a :time) :author (get a :name)}))
|
||||||
|
|
||||||
|
(define
|
||||||
|
git/import-commit-meta
|
||||||
|
(fn
|
||||||
|
(p)
|
||||||
|
(let
|
||||||
|
((a (get p :author)) (c (get p :committer)))
|
||||||
|
(merge
|
||||||
|
(merge (git/import-author-meta a) {:message (get p :message)})
|
||||||
|
(if (or (equal? c nil) (= a c)) {} {:committer (get c :name) :committer-tz (get c :tz) :committer-email (get c :email) :committer-time (get c :time)})))))
|
||||||
|
|
||||||
|
; ---- bottom-up import over a sha->{:bytes} table; memo: sha -> native cid ----
|
||||||
|
(define
|
||||||
|
git/import-sha
|
||||||
|
(fn
|
||||||
|
(repo objects sha memo)
|
||||||
|
(if
|
||||||
|
(has-key? memo sha)
|
||||||
|
memo
|
||||||
|
(let
|
||||||
|
((p (git/import-payload (get (get objects sha) :bytes))))
|
||||||
|
(cond
|
||||||
|
((equal? (get p :type) "blob")
|
||||||
|
(assoc memo sha (git/write-blob repo (get p :body))))
|
||||||
|
((equal? (get p :type) "tree")
|
||||||
|
(let
|
||||||
|
((res (reduce (fn (acc pe) (let ((m2 (git/import-sha repo objects (get pe :sha) (first acc)))) (list m2 (assoc (nth acc 1) (get pe :name) (let ((base {:kind (if (equal? (get pe :mode) "40000") "tree" "blob") :cid (get m2 (get pe :sha))})) (if (or (equal? (get pe :mode) "40000") (equal? (get pe :mode) "100644")) base (merge base {:mode (get pe :mode)}))))))) (list memo {}) (git/import-tree-entries (get p :body) 0 (string-length (get p :body)) (list)))))
|
||||||
|
(assoc
|
||||||
|
(first res)
|
||||||
|
sha
|
||||||
|
(git/write repo (git/tree (nth res 1))))))
|
||||||
|
((equal? (get p :type) "commit")
|
||||||
|
(let
|
||||||
|
((cp (git/import-commit-parse (get p :body))))
|
||||||
|
(let
|
||||||
|
((m2 (git/import-sha repo objects (get cp :tree) (reduce (fn (mm ps) (git/import-sha repo objects ps mm)) memo (get cp :parents)))))
|
||||||
|
(assoc
|
||||||
|
m2
|
||||||
|
sha
|
||||||
|
(git/write
|
||||||
|
repo
|
||||||
|
(git/commit
|
||||||
|
(get m2 (get cp :tree))
|
||||||
|
(map (fn (ps) (get m2 ps)) (get cp :parents))
|
||||||
|
(git/import-commit-meta cp)))))))
|
||||||
|
((equal? (get p :type) "tag")
|
||||||
|
(let
|
||||||
|
((tp (git/import-tag-parse (get p :body))))
|
||||||
|
(let
|
||||||
|
((m2 (git/import-sha repo objects (get tp :object) memo)))
|
||||||
|
(assoc
|
||||||
|
m2
|
||||||
|
sha
|
||||||
|
(git/write
|
||||||
|
repo
|
||||||
|
(git/tag
|
||||||
|
(get m2 (get tp :object))
|
||||||
|
(get tp :tag)
|
||||||
|
(merge
|
||||||
|
(git/import-author-meta (get tp :tagger))
|
||||||
|
{:message (get tp :message)})))))))
|
||||||
|
(else memo))))))
|
||||||
|
|
||||||
|
; import a {:head :objects} set; returns the native cid of the head object
|
||||||
|
(define
|
||||||
|
git/import-set
|
||||||
|
(fn
|
||||||
|
(repo set)
|
||||||
|
(get
|
||||||
|
(git/import-sha repo (get set :objects) (get set :head) {})
|
||||||
|
(get set :head))))
|
||||||
@@ -7,9 +7,10 @@
|
|||||||
"diff": {"pass": 27, "fail": 0},
|
"diff": {"pass": 27, "fail": 0},
|
||||||
"merge": {"pass": 28, "fail": 0},
|
"merge": {"pass": 28, "fail": 0},
|
||||||
"porcelain": {"pass": 40, "fail": 0},
|
"porcelain": {"pass": 40, "fail": 0},
|
||||||
"export": {"pass": 25, "fail": 0}
|
"export": {"pass": 25, "fail": 0},
|
||||||
|
"import": {"pass": 15, "fail": 0}
|
||||||
},
|
},
|
||||||
"total_pass": 252,
|
"total_pass": 267,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"total": 252
|
"total": 267
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -12,4 +12,5 @@ _Generated by `lib/git/conformance.sh`_
|
|||||||
| merge | 28 | 0 | 28 |
|
| merge | 28 | 0 | 28 |
|
||||||
| porcelain | 40 | 0 | 40 |
|
| porcelain | 40 | 0 | 40 |
|
||||||
| export | 25 | 0 | 25 |
|
| export | 25 | 0 | 25 |
|
||||||
| **Total** | **252** | **0** | **252** |
|
| import | 15 | 0 | 15 |
|
||||||
|
| **Total** | **267** | **0** | **267** |
|
||||||
|
|||||||
174
lib/git/tests/import.sx
Normal file
174
lib/git/tests/import.sx
Normal file
@@ -0,0 +1,174 @@
|
|||||||
|
; Extension — git-wire import (inverse adapter). The law under test:
|
||||||
|
; export-set -> import-set -> export-set is BYTE-IDENTICAL (same head sha,
|
||||||
|
; same object table), and imported blobs/trees with default modes get the
|
||||||
|
; same native cids as the originals.
|
||||||
|
|
||||||
|
(define gim-db (persist/mem-backend))
|
||||||
|
(define gim (git/repo gim-db))
|
||||||
|
(define gim-hello (git/write-blob gim "hello\n"))
|
||||||
|
(define gim-sub (git/write-blob gim "sub\n"))
|
||||||
|
(define
|
||||||
|
gim-tsub
|
||||||
|
(git/write
|
||||||
|
gim
|
||||||
|
(git/tree (assoc {} "c.txt" (git/tree-entry "blob" gim-sub)))))
|
||||||
|
(define
|
||||||
|
gim-t1
|
||||||
|
(git/write
|
||||||
|
gim
|
||||||
|
(git/tree
|
||||||
|
(assoc
|
||||||
|
(assoc {} "a.txt" (git/tree-entry "blob" gim-hello))
|
||||||
|
"sub"
|
||||||
|
(git/tree-entry "tree" gim-tsub)))))
|
||||||
|
(define gim-c1 (git/write gim (git/commit gim-t1 (list) {:message "c1" :tz "+0000" :email "ada@sx" :time 1700000000 :author "ada"})))
|
||||||
|
(define
|
||||||
|
gim-c2
|
||||||
|
(git/write
|
||||||
|
gim
|
||||||
|
(git/commit
|
||||||
|
(git/write
|
||||||
|
gim
|
||||||
|
(git/tree
|
||||||
|
(assoc
|
||||||
|
(assoc
|
||||||
|
{}
|
||||||
|
"a.txt"
|
||||||
|
(git/tree-entry "blob" (git/write-blob gim "hello2\n")))
|
||||||
|
"sub"
|
||||||
|
(git/tree-entry "tree" gim-tsub))))
|
||||||
|
(list gim-c1)
|
||||||
|
{:message "c2" :tz "+0000" :email "ada@sx" :time 1700000100 :author "ada"})))
|
||||||
|
|
||||||
|
; ---- parsing units ----
|
||||||
|
(git-test
|
||||||
|
"payload splits type and body"
|
||||||
|
(git/import-payload (str "blob 6" git/export-nul "hello\n"))
|
||||||
|
{:type "blob" :body "hello\n"})
|
||||||
|
(git-test
|
||||||
|
"ident parses name/email/time/tz"
|
||||||
|
(= (git/import-ident "ada lovelace <ada@sx> 1700000000 +0100") {:name "ada lovelace" :tz "+0100" :email "ada@sx" :time 1700000000})
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"raw->hex inverts hex->raw"
|
||||||
|
(git/raw->hex (git/hex->raw "ce013625030ba8dba906f756967f9e9ca394464a"))
|
||||||
|
"ce013625030ba8dba906f756967f9e9ca394464a")
|
||||||
|
(git-test
|
||||||
|
"tree body parses mode/name/sha triples"
|
||||||
|
(=
|
||||||
|
(map
|
||||||
|
(fn (e) (get e :name))
|
||||||
|
(git/import-tree-entries
|
||||||
|
(get
|
||||||
|
(git/import-payload (get (git/export gim gim-t1) :bytes))
|
||||||
|
:body)
|
||||||
|
0
|
||||||
|
(string-length
|
||||||
|
(get
|
||||||
|
(git/import-payload (get (git/export gim gim-t1) :bytes))
|
||||||
|
:body))
|
||||||
|
(list)))
|
||||||
|
(list "a.txt" "sub"))
|
||||||
|
true)
|
||||||
|
|
||||||
|
; ---- the round-trip law ----
|
||||||
|
(define gim-set1 (git/export-set gim gim-c2))
|
||||||
|
(define gim-fresh (git/repo-named (persist/mem-backend) "imported"))
|
||||||
|
(define gim-head (git/import-set gim-fresh gim-set1))
|
||||||
|
(define gim-set2 (git/export-set gim-fresh gim-head))
|
||||||
|
|
||||||
|
(git-test
|
||||||
|
"wire round-trip: head sha is identical"
|
||||||
|
(get gim-set2 :head)
|
||||||
|
(get gim-set1 :head))
|
||||||
|
(git-test
|
||||||
|
"wire round-trip: same number of objects"
|
||||||
|
(=
|
||||||
|
(len (keys (get gim-set2 :objects)))
|
||||||
|
(len (keys (get gim-set1 :objects))))
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"wire round-trip: every sha re-exports byte-identical"
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc sha)
|
||||||
|
(and
|
||||||
|
acc
|
||||||
|
(equal?
|
||||||
|
(get (get (get gim-set2 :objects) sha) :bytes)
|
||||||
|
(get (get (get gim-set1 :objects) sha) :bytes))))
|
||||||
|
true
|
||||||
|
(keys (get gim-set1 :objects)))
|
||||||
|
true)
|
||||||
|
|
||||||
|
; ---- native identity on the wire-expressible subset ----
|
||||||
|
(git-test
|
||||||
|
"imported blob has the original native cid"
|
||||||
|
(git/has? gim-fresh gim-hello)
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"imported default-mode tree has the original native cid"
|
||||||
|
(git/has? gim-fresh gim-t1)
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"imported commit graph walks natively"
|
||||||
|
(= (git/log-messages gim-fresh gim-head) (list "c2\n" "c1\n"))
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"imported parents map to native cids"
|
||||||
|
(=
|
||||||
|
(git/parents gim-fresh gim-head)
|
||||||
|
(list
|
||||||
|
(git/cid
|
||||||
|
(git/read gim-fresh (first (git/parents gim-fresh gim-head))))))
|
||||||
|
true)
|
||||||
|
|
||||||
|
; ---- mode + tag + committer round-trips ----
|
||||||
|
(git-test
|
||||||
|
"non-default mode survives the round-trip"
|
||||||
|
(let
|
||||||
|
((r (git/repo (persist/mem-backend))))
|
||||||
|
(let
|
||||||
|
((t (git/write r (git/tree (assoc {} "x.sh" (merge (git/tree-entry "blob" (git/write-blob r "hello\n")) {:mode "100755"}))))))
|
||||||
|
(let
|
||||||
|
((s1 (git/export-set r t)))
|
||||||
|
(let
|
||||||
|
((r2 (git/repo-named (persist/mem-backend) "i")))
|
||||||
|
(get (git/export-set r2 (git/import-set r2 s1)) :head)))))
|
||||||
|
"54925a269ee97325d7da275bda4250d83b338e65")
|
||||||
|
(git-test
|
||||||
|
"annotated tag round-trips through the wire"
|
||||||
|
(let
|
||||||
|
((tag (git/write gim (git/tag gim-c1 "v1" {:message "first" :tz "+0000" :email "ada@sx" :time 1700000200 :author "ada"}))))
|
||||||
|
(let
|
||||||
|
((s1 (git/export-set gim tag)))
|
||||||
|
(let
|
||||||
|
((r2 (git/repo-named (persist/mem-backend) "i")))
|
||||||
|
(equal?
|
||||||
|
(get (git/export-set r2 (git/import-set r2 s1)) :head)
|
||||||
|
(get s1 :head)))))
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"distinct committer survives the round-trip"
|
||||||
|
(let
|
||||||
|
((c (git/write gim (git/commit gim-t1 (list) {:message "handoff" :committer "bob" :committer-tz "+0200" :tz "+0000" :committer-email "bob@sx" :email "ada@sx" :committer-time 1700000300 :time 1700000000 :author "ada"}))))
|
||||||
|
(let
|
||||||
|
((s1 (git/export-set gim c)))
|
||||||
|
(let
|
||||||
|
((r2 (git/repo-named (persist/mem-backend) "i")))
|
||||||
|
(equal?
|
||||||
|
(get (git/export-set r2 (git/import-set r2 s1)) :head)
|
||||||
|
(get s1 :head)))))
|
||||||
|
true)
|
||||||
|
(git-test
|
||||||
|
"multi-line message round-trips byte-exact"
|
||||||
|
(let
|
||||||
|
((c (git/write gim (git/commit gim-t1 (list) {:message "subject\n\nbody line one\nbody line two\n" :tz "+0000" :email "ada@sx" :time 1 :author "ada"}))))
|
||||||
|
(let
|
||||||
|
((s1 (git/export-set gim c)))
|
||||||
|
(let
|
||||||
|
((r2 (git/repo-named (persist/mem-backend) "i")))
|
||||||
|
(equal?
|
||||||
|
(get (git/export-set r2 (git/import-set r2 s1)) :head)
|
||||||
|
(get s1 :head)))))
|
||||||
|
true)
|
||||||
Reference in New Issue
Block a user