giles
e228d462eb
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>
300 lines
6.0 KiB
Plaintext
300 lines
6.0 KiB
Plaintext
; lib/git/sha1.sx — SHA-1 in pure SX (host bitwise prims, no deps).
|
|
; Exists ONLY for the git-wire export adapter: native sx-git identity stays
|
|
; sx1:/sha256 (object.sx); SHA-1 is what the exported byte format demands.
|
|
; Strings are treated as byte strings (char-code on 1-byte substrings).
|
|
|
|
(define git/sha1-mask 4294967295)
|
|
(define git/u32 (fn (x) (bitwise-and x git/sha1-mask)))
|
|
|
|
(define
|
|
git/rotl
|
|
(fn
|
|
(x n)
|
|
(git/u32
|
|
(bitwise-or
|
|
(arithmetic-shift x n)
|
|
(arithmetic-shift x (- n 32))))))
|
|
|
|
; ---- byte plumbing ----
|
|
(define
|
|
git/sha1-take
|
|
(fn
|
|
(xs n)
|
|
(if
|
|
(or (= n 0) (empty? xs))
|
|
(list)
|
|
(cons (first xs) (git/sha1-take (rest xs) (- n 1))))))
|
|
|
|
(define
|
|
git/sha1-drop
|
|
(fn
|
|
(xs n)
|
|
(if
|
|
(or (= n 0) (empty? xs))
|
|
xs
|
|
(git/sha1-drop (rest xs) (- n 1)))))
|
|
|
|
(define
|
|
git/sha1-sb
|
|
(fn
|
|
(s i n acc)
|
|
(if
|
|
(>= i n)
|
|
(reverse acc)
|
|
(git/sha1-sb
|
|
s
|
|
(+ i 1)
|
|
n
|
|
(cons (char-code (substring s i (+ i 1))) acc)))))
|
|
|
|
(define
|
|
git/sha1-str-bytes
|
|
(fn (s) (git/sha1-sb s 0 (string-length s) (list))))
|
|
|
|
(define
|
|
git/sha1-zeros
|
|
(fn
|
|
(k)
|
|
(if
|
|
(= k 0)
|
|
(list)
|
|
(cons 0 (git/sha1-zeros (- k 1))))))
|
|
|
|
(define
|
|
git/sha1-be8
|
|
(fn
|
|
(v)
|
|
(map
|
|
(fn
|
|
(sh)
|
|
(bitwise-and (arithmetic-shift v (- 0 sh)) 255))
|
|
(list
|
|
56
|
|
48
|
|
40
|
|
32
|
|
24
|
|
16
|
|
8
|
|
0))))
|
|
|
|
; append 0x80, zero-pad to 56 mod 64, then the 64-bit big-endian bit length
|
|
(define
|
|
git/sha1-pad
|
|
(fn
|
|
(bytes)
|
|
(let
|
|
((n (len bytes)))
|
|
(let
|
|
((zeros (remainder (+ (- 56 (remainder (+ n 1) 64)) 64) 64)))
|
|
(append
|
|
bytes
|
|
(append
|
|
(cons 128 (git/sha1-zeros zeros))
|
|
(git/sha1-be8 (* n 8))))))))
|
|
|
|
; ---- message schedule: w as an index-keyed dict ----
|
|
(define
|
|
git/sha1-w-init-go
|
|
(fn
|
|
(bs j w)
|
|
(if
|
|
(= j 16)
|
|
w
|
|
(git/sha1-w-init-go
|
|
(git/sha1-drop bs 4)
|
|
(+ j 1)
|
|
(assoc
|
|
w
|
|
(str j)
|
|
(bitwise-or
|
|
(arithmetic-shift (nth bs 0) 24)
|
|
(bitwise-or
|
|
(arithmetic-shift (nth bs 1) 16)
|
|
(bitwise-or
|
|
(arithmetic-shift (nth bs 2) 8)
|
|
(nth bs 3)))))))))
|
|
|
|
(define
|
|
git/sha1-w-expand
|
|
(fn
|
|
(w t)
|
|
(if
|
|
(= t 80)
|
|
w
|
|
(git/sha1-w-expand
|
|
(assoc
|
|
w
|
|
(str t)
|
|
(git/rotl
|
|
(bitwise-xor
|
|
(bitwise-xor
|
|
(get w (str (- t 3)))
|
|
(get w (str (- t 8))))
|
|
(bitwise-xor
|
|
(get w (str (- t 14)))
|
|
(get w (str (- t 16)))))
|
|
1))
|
|
(+ t 1)))))
|
|
|
|
; ---- rounds ----
|
|
(define
|
|
git/sha1-f
|
|
(fn
|
|
(t b c d)
|
|
(cond
|
|
((< t 20)
|
|
(bitwise-or
|
|
(bitwise-and b c)
|
|
(bitwise-and (bitwise-and (bitwise-not b) git/sha1-mask) d)))
|
|
((< t 40) (bitwise-xor (bitwise-xor b c) d))
|
|
((< t 60)
|
|
(bitwise-or
|
|
(bitwise-or (bitwise-and b c) (bitwise-and b d))
|
|
(bitwise-and c d)))
|
|
(else (bitwise-xor (bitwise-xor b c) d)))))
|
|
|
|
(define
|
|
git/sha1-k
|
|
(fn
|
|
(t)
|
|
(cond
|
|
((< t 20) 1518500249)
|
|
((< t 40) 1859775393)
|
|
((< t 60) 2400959708)
|
|
(else 3395469782))))
|
|
|
|
(define
|
|
git/sha1-rounds
|
|
(fn
|
|
(w t a b c d e)
|
|
(if
|
|
(= t 80)
|
|
(list a b c d e)
|
|
(git/sha1-rounds
|
|
w
|
|
(+ t 1)
|
|
(git/u32
|
|
(+
|
|
(+
|
|
(+ (+ (git/rotl a 5) (git/sha1-f t b c d)) e)
|
|
(git/sha1-k t))
|
|
(get w (str t))))
|
|
a
|
|
(git/rotl b 30)
|
|
c
|
|
d))))
|
|
|
|
(define
|
|
git/sha1-blocks
|
|
(fn
|
|
(bs hs)
|
|
(if
|
|
(empty? bs)
|
|
hs
|
|
(let
|
|
((w (git/sha1-w-expand (git/sha1-w-init-go (git/sha1-take bs 64) 0 {}) 16)))
|
|
(let
|
|
((r (git/sha1-rounds w 0 (nth hs 0) (nth hs 1) (nth hs 2) (nth hs 3) (nth hs 4))))
|
|
(git/sha1-blocks
|
|
(git/sha1-drop bs 64)
|
|
(list
|
|
(git/u32 (+ (nth hs 0) (nth r 0)))
|
|
(git/u32 (+ (nth hs 1) (nth r 1)))
|
|
(git/u32 (+ (nth hs 2) (nth r 2)))
|
|
(git/u32 (+ (nth hs 3) (nth r 3)))
|
|
(git/u32 (+ (nth hs 4) (nth r 4))))))))))
|
|
|
|
(define
|
|
git/sha1-words
|
|
(fn
|
|
(s)
|
|
(git/sha1-blocks
|
|
(git/sha1-pad (git/sha1-str-bytes s))
|
|
(list 1732584193 4023233417 2562383102 271733878 3285377520))))
|
|
|
|
; ---- digest forms ----
|
|
(define
|
|
git/sha1-word-bytes
|
|
(fn
|
|
(v)
|
|
(list
|
|
(bitwise-and (arithmetic-shift v -24) 255)
|
|
(bitwise-and (arithmetic-shift v -16) 255)
|
|
(bitwise-and (arithmetic-shift v -8) 255)
|
|
(bitwise-and v 255))))
|
|
|
|
(define
|
|
git/sha1-digest-bytes
|
|
(fn
|
|
(s)
|
|
(reduce
|
|
(fn (acc v) (append acc (git/sha1-word-bytes v)))
|
|
(list)
|
|
(git/sha1-words s))))
|
|
|
|
(define git/sha1-hexd "0123456789abcdef")
|
|
(define
|
|
git/sha1-byte-hex
|
|
(fn
|
|
(b)
|
|
(str
|
|
(substring
|
|
git/sha1-hexd
|
|
(quotient b 16)
|
|
(+ (quotient b 16) 1))
|
|
(substring
|
|
git/sha1-hexd
|
|
(remainder b 16)
|
|
(+ (remainder b 16) 1)))))
|
|
|
|
(define
|
|
git/sha1-hex
|
|
(fn
|
|
(s)
|
|
(reduce
|
|
(fn (acc b) (str acc (git/sha1-byte-hex b)))
|
|
""
|
|
(git/sha1-digest-bytes s))))
|
|
|
|
(define
|
|
git/sha1-raw
|
|
(fn
|
|
(s)
|
|
(list->string
|
|
(map (fn (b) (integer->char b)) (git/sha1-digest-bytes s)))))
|
|
|
|
; hex string -> raw bytes (tree entries embed 20 raw sha bytes)
|
|
(define
|
|
git/hex-digit-val
|
|
(fn
|
|
(c)
|
|
(let
|
|
((v (char-code c)))
|
|
(if (< v 58) (- v 48) (- v 87)))))
|
|
|
|
(define
|
|
git/hex->raw-go
|
|
(fn
|
|
(h i n acc)
|
|
(if
|
|
(>= i n)
|
|
(list->string (reverse acc))
|
|
(git/hex->raw-go
|
|
h
|
|
(+ i 2)
|
|
n
|
|
(cons
|
|
(integer->char
|
|
(+
|
|
(*
|
|
16
|
|
(git/hex-digit-val (substring h i (+ i 1))))
|
|
(git/hex-digit-val
|
|
(substring h (+ i 1) (+ i 2)))))
|
|
acc)))))
|
|
|
|
(define
|
|
git/hex->raw
|
|
(fn (h) (git/hex->raw-go h 0 (string-length h) (list))))
|