giles
2c9e8e4850
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>
245 lines
7.8 KiB
Plaintext
245 lines
7.8 KiB
Plaintext
; 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))))
|