; lib/git/import.sx — git-wire IMPORT (inverse of export.sx). ; Parses loose-object payloads " \0" 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: " \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 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))))