rose-ash/lib/git/tests/export.sx

; 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)