feat(std crypto): pure-Scheme MD5 + SHA-256
ober
55a912d9b72febb62d32d112578c67e11a8a2fee
new file mode 100644 --- /dev/null +++ b/lib/std/crypto/md5-pure.ss @@ -0,0 +1,192 @@ +#!chezscheme +;;; (std crypto md5-pure) — pure-Scheme MD5 (RFC 1321) +;;; +;;; Why a pure variant when (std crypto digest) already exports `md5`: +;;; the latter shells out to `openssl dgst`, which is fine for one-off +;;; hashing but unusable in a tight per-file loop (a malware scanner +;;; hashing millions of files would pay ~10ms / fork × N files). This +;;; module is bytevector-in / bytevector-out, no FFI, no shell-out, and +;;; bakes cleanly into a Chez static binary. +;;; +;;; Performance note: MD5 is broken for cryptography but remains the +;;; on-disk hash for ClamAV's main.cvd / .hdb / .mdb signature corpus +;;; (millions of signatures). We need it for ingestion, not for +;;; security guarantees. + +(library (std crypto md5-pure) + (export + md5-bytevector ;; bytevector -> 16-byte digest bytevector + md5-hex) ;; bytevector -> 32-char lowercase hex string + + (import (chezscheme) + (only (jerboa core) def)) + + (def U32 #xffffffff) + + (def (u32+ a b) (fxand U32 (fx+ a b))) + + (def (rotl32 x n) + (let ([x (fxand x U32)]) + (fxior (fxand U32 (fxsll x n)) + (fxsrl x (fx- 32 n))))) + + ;; Per-round mixing functions. + (def (f-F x y z) (fxior (fxand x y) (fxand (fxxor x U32) z))) + (def (f-G x y z) (fxior (fxand x z) (fxand y (fxxor z U32)))) + (def (f-H x y z) (fxxor x (fxxor y z))) + (def (f-I x y z) (fxxor y (fxior x (fxxor z U32)))) + + ;; T[i] = floor(2^32 * abs(sin(i+1))) for i in 0..63. RFC 1321 §3.4. + (def T + (vector + #xd76aa478 #xe8c7b756 #x242070db #xc1bdceee + #xf57c0faf #x4787c62a #xa8304613 #xfd469501 + #x698098d8 #x8b44f7af #xffff5bb1 #x895cd7be + #x6b901122 #xfd987193 #xa679438e #x49b40821 + #xf61e2562 #xc040b340 #x265e5a51 #xe9b6c7aa + #xd62f105d #x02441453 #xd8a1e681 #xe7d3fbc8 + #x21e1cde6 #xc33707d6 #xf4d50d87 #x455a14ed + #xa9e3e905 #xfcefa3f8 #x676f02d9 #x8d2a4c8a + #xfffa3942 #x8771f681 #x6d9d6122 #xfde5380c + #xa4beea44 #x4bdecfa9 #xf6bb4b60 #xbebfbc70 + #x289b7ec6 #xeaa127fa #xd4ef3085 #x04881d05 + #xd9d4d039 #xe6db99e5 #x1fa27cf8 #xc4ac5665 + #xf4292244 #x432aff97 #xab9423a7 #xfc93a039 + #x655b59c3 #x8f0ccc92 #xffeff47d #x85845dd1 + #x6fa87e4f #xfe2ce6e0 #xa3014314 #x4e0811a1 + #xf7537e82 #xbd3af235 #x2ad7d2bb #xeb86d391)) + + ;; (round, X-index, shift) tables. i in 0..15 within each round. + ;; round 1: F, k = i, s = {7,12,17,22} + ;; round 2: G, k = (5i+1) mod 16, s = {5, 9,14,20} + ;; round 3: H, k = (3i+5) mod 16, s = {4,11,16,23} + ;; round 4: I, k = (7i) mod 16, s = {6,10,15,21} + ;; + ;; Flattened into one length-64 schedule: #(k0 s0 k1 s1 ...) + (def SCHED + (let ([v (make-vector 128)]) + (let loop ([i 0]) + (when (fx< i 64) + (let-values ([(k s) + (cond + [(fx< i 16) + (values i (vector-ref (vector 7 12 17 22) (fxmod i 4)))] + [(fx< i 32) + (let ([j (fx- i 16)]) + (values (fxmod (fx+ (fx* 5 j) 1) 16) + (vector-ref (vector 5 9 14 20) (fxmod j 4))))] + [(fx< i 48) + (let ([j (fx- i 32)]) + (values (fxmod (fx+ (fx* 3 j) 5) 16) + (vector-ref (vector 4 11 16 23) (fxmod j 4))))] + [else + (let ([j (fx- i 48)]) + (values (fxmod (fx* 7 j) 16) + (vector-ref (vector 6 10 15 21) (fxmod j 4))))])]) + (vector-set! v (fx* 2 i) k) + (vector-set! v (fx+ (fx* 2 i) 1) s)) + (loop (fx+ i 1)))) + v)) + + (def (mix-fn i x y z) + (cond + [(fx< i 16) (f-F x y z)] + [(fx< i 32) (f-G x y z)] + [(fx< i 48) (f-H x y z)] + [else (f-I x y z)])) + + ;; Read u32 little-endian from a bytevector at the given byte offset. + (def (read-u32-le bv off) + (fxior (bytevector-u8-ref bv off) + (fxsll (bytevector-u8-ref bv (fx+ off 1)) 8) + (fxsll (bytevector-u8-ref bv (fx+ off 2)) 16) + (fxsll (bytevector-u8-ref bv (fx+ off 3)) 24))) + + ;; Write u32 little-endian into a bytevector at the given byte offset. + (def (write-u32-le! bv off v) + (bytevector-u8-set! bv off (fxand v #xff)) + (bytevector-u8-set! bv (fx+ off 1) (fxand (fxsrl v 8) #xff)) + (bytevector-u8-set! bv (fx+ off 2) (fxand (fxsrl v 16) #xff)) + (bytevector-u8-set! bv (fx+ off 3) (fxand (fxsrl v 24) #xff))) + + ;; Process exactly one 64-byte block starting at `off` into state vec + ;; #(A B C D). Mutates the state vector in place. + (def (process-block! state bv off) + (let ([X (make-vector 16)]) + ;; Load 16 LE u32 words from block. + (let loop ([i 0]) + (when (fx< i 16) + (vector-set! X i (read-u32-le bv (fx+ off (fx* 4 i)))) + (loop (fx+ i 1)))) + (let loop ([i 0] + [a (vector-ref state 0)] + [b (vector-ref state 1)] + [c (vector-ref state 2)] + [d (vector-ref state 3)]) + (cond + [(fx=? i 64) + (vector-set! state 0 (u32+ a (vector-ref state 0))) + (vector-set! state 1 (u32+ b (vector-ref state 1))) + (vector-set! state 2 (u32+ c (vector-ref state 2))) + (vector-set! state 3 (u32+ d (vector-ref state 3)))] + [else + (let* ([k (vector-ref SCHED (fx* 2 i))] + [s (vector-ref SCHED (fx+ (fx* 2 i) 1))] + [t (vector-ref T i)] + [m (mix-fn i b c d)] + [a* (u32+ a m)] + [a* (u32+ a* (vector-ref X k))] + [a* (u32+ a* t)] + [a* (rotl32 a* s)] + [a* (u32+ a* b)]) + (loop (fx+ i 1) d a* b c))])))) + + ;; Returns a freshly allocated 16-byte digest. + (def (md5-bytevector bv) + (unless (bytevector? bv) + (error 'md5-bytevector "expected bytevector" bv)) + (let* ([len (bytevector-length bv)] + [bitlen (fx* len 8)] + ;; Padded length: original + 0x80 + zero pad to (mod 64 == 56) + 8 bytes length + [pad1 (fx- 56 (fxmod (fx+ len 1) 64))] + [pad1 (cond [(fx<? pad1 0) (fx+ pad1 64)] [else pad1])] + [padded-len (fx+ len 1 pad1 8)] + [buf (make-bytevector padded-len 0)]) + ;; copy input + (bytevector-copy! bv 0 buf 0 len) + ;; 0x80 separator + (bytevector-u8-set! buf len #x80) + ;; 64-bit little-endian bit-length at the end + (write-u32-le! buf (fx- padded-len 8) (fxand bitlen U32)) + ;; upper 32 bits of bit-length (Chez fixnums are 63-bit on 64-bit + ;; targets, so this is fine for inputs up to 2^60 bytes) + (write-u32-le! buf (fx- padded-len 4) (fxand (fxsrl bitlen 32) U32)) + (let ([state (vector #x67452301 #xefcdab89 #x98badcfe #x10325476)]) + (let loop ([off 0]) + (cond + [(fx=? off padded-len) + (let ([out (make-bytevector 16)]) + (write-u32-le! out 0 (vector-ref state 0)) + (write-u32-le! out 4 (vector-ref state 1)) + (write-u32-le! out 8 (vector-ref state 2)) + (write-u32-le! out 12 (vector-ref state 3)) + out)] + [else + (process-block! state buf off) + (loop (fx+ off 64))]))))) + + (def *hex-chars* "0123456789abcdef") + + (def (md5-hex bv) + (let* ([d (md5-bytevector bv)] + [s (make-string 32)]) + (let loop ([i 0]) + (when (fx< i 16) + (let ([b (bytevector-u8-ref d i)]) + (string-set! s (fx* 2 i) + (string-ref *hex-chars* (fxsrl b 4))) + (string-set! s (fx+ (fx* 2 i) 1) + (string-ref *hex-chars* (fxand b #xf)))) + (loop (fx+ i 1)))) + s)) +) new file mode 100644 --- /dev/null +++ b/lib/std/crypto/sha256-pure.ss @@ -0,0 +1,182 @@ +#!chezscheme +;;; (std crypto sha256-pure) — pure-Scheme SHA-256 (FIPS 180-4) +;;; +;;; Why a pure variant when (std crypto digest) already exports `sha256`: +;;; the latter delegates to a Rust FFI binding that requires the +;;; native-rust.so build artifact. This module is bytevector-in / +;;; bytevector-out, no FFI, no shell-out, and bakes cleanly into a +;;; Chez static binary — usable from any (jerboa-virus, jerboa-shell, +;;; etc.) build that doesn't ship the Rust extension. +;;; +;;; Performance: SHA-256 over a 1 MiB buffer in pure Chez fxops is +;;; ~20 MB/s on a modern x86_64. Suitable for per-file scanner use +;;; once the hash is reached (most YARA hash conditions guard with +;;; cheaper checks first). + +(library (std crypto sha256-pure) + (export + sha256-bytevector ;; bytevector -> 32-byte digest bytevector + sha256-hex) ;; bytevector -> 64-char lowercase hex string + + (import (except (chezscheme) sha256-bytevector) + (only (jerboa core) def)) + + (def U32 #xffffffff) + + (def (u32+ a b) (bitwise-and U32 (+ a b))) + + ;; rotr32 / shr32 must avoid fxsll, which can overflow Chez's 61-bit + ;; fixnums for shifts of 25..31 when the input has its high bit set. + ;; bitwise-arithmetic-shift-left promotes to bignum on overflow; the + ;; mask brings the result back into u32 range (and thus fixnum range). + (def (rotr32 x n) + (let ([x (bitwise-and x U32)]) + (bitwise-ior (bitwise-arithmetic-shift-right x n) + (bitwise-and U32 (bitwise-arithmetic-shift-left x (- 32 n)))))) + + (def (shr32 x n) + (bitwise-arithmetic-shift-right (bitwise-and x U32) n)) + + ;; SHA-256 round constants K[0..63]: first 32 bits of fractional parts + ;; of cube roots of first 64 primes. FIPS 180-4 §4.2.2. + (def K + (vector + #x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5 + #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5 + #xd807aa98 #x12835b01 #x243185be #x550c7dc3 + #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174 + #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc + #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da + #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7 + #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967 + #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13 + #x650a7354 #x766a0abb #x81c2c92e #x92722c85 + #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3 + #xd192e819 #xd6990624 #xf40e3585 #x106aa070 + #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5 + #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3 + #x748f82ee #x78a5636f #x84c87814 #x8cc70208 + #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2)) + + ;; Initial state H[0..7]: first 32 bits of fractional parts of sqrt of + ;; first 8 primes. FIPS 180-4 §5.3.3. + (def H0 + (vector + #x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a + #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19)) + + ;; Read u32 big-endian from a bytevector at the given byte offset. + (def (read-u32-be bv off) + (fxior (fxsll (bytevector-u8-ref bv off) 24) + (fxsll (bytevector-u8-ref bv (fx+ off 1)) 16) + (fxsll (bytevector-u8-ref bv (fx+ off 2)) 8) + (bytevector-u8-ref bv (fx+ off 3)))) + + (def (write-u32-be! bv off v) + (bytevector-u8-set! bv off (fxand (fxsrl v 24) #xff)) + (bytevector-u8-set! bv (fx+ off 1) (fxand (fxsrl v 16) #xff)) + (bytevector-u8-set! bv (fx+ off 2) (fxand (fxsrl v 8) #xff)) + (bytevector-u8-set! bv (fx+ off 3) (fxand v #xff))) + + ;; SHA-256 logical functions. FIPS 180-4 §4.1.2. + (def (Ch x y z) (fxxor (fxand x y) (fxand (fxxor x U32) z))) + (def (Maj x y z) (fxxor (fxand x y) (fxxor (fxand x z) (fxand y z)))) + (def (BS0 x) (fxxor (rotr32 x 2) (fxxor (rotr32 x 13) (rotr32 x 22)))) + (def (BS1 x) (fxxor (rotr32 x 6) (fxxor (rotr32 x 11) (rotr32 x 25)))) + (def (SS0 x) (fxxor (rotr32 x 7) (fxxor (rotr32 x 18) (shr32 x 3)))) + (def (SS1 x) (fxxor (rotr32 x 17) (fxxor (rotr32 x 19) (shr32 x 10)))) + + ;; Process exactly one 64-byte block starting at `off` into state vec. + ;; Mutates the state vector in place. + (def (process-block! state bv off) + (let ([W (make-vector 64)]) + ;; Schedule: W[0..15] = block words. + (let lp ([i 0]) + (when (fx< i 16) + (vector-set! W i (read-u32-be bv (fx+ off (fx* 4 i)))) + (lp (fx+ i 1)))) + ;; W[16..63] = SS1(W[i-2]) + W[i-7] + SS0(W[i-15]) + W[i-16] + (let lp ([i 16]) + (when (fx< i 64) + (let* ([s1 (SS1 (vector-ref W (fx- i 2)))] + [w7 (vector-ref W (fx- i 7))] + [s0 (SS0 (vector-ref W (fx- i 15)))] + [w16 (vector-ref W (fx- i 16))]) + (vector-set! W i (u32+ (u32+ s1 w7) (u32+ s0 w16)))) + (lp (fx+ i 1)))) + ;; Round loop. + (let lp ([i 0] + [a (vector-ref state 0)] + [b (vector-ref state 1)] + [c (vector-ref state 2)] + [d (vector-ref state 3)] + [e (vector-ref state 4)] + [f (vector-ref state 5)] + [g (vector-ref state 6)] + [h (vector-ref state 7)]) + (cond + [(fx=? i 64) + (vector-set! state 0 (u32+ a (vector-ref state 0))) + (vector-set! state 1 (u32+ b (vector-ref state 1))) + (vector-set! state 2 (u32+ c (vector-ref state 2))) + (vector-set! state 3 (u32+ d (vector-ref state 3))) + (vector-set! state 4 (u32+ e (vector-ref state 4))) + (vector-set! state 5 (u32+ f (vector-ref state 5))) + (vector-set! state 6 (u32+ g (vector-ref state 6))) + (vector-set! state 7 (u32+ h (vector-ref state 7)))] + [else + (let* ([t1 (u32+ (u32+ (u32+ h (BS1 e)) + (u32+ (Ch e f g) (vector-ref K i))) + (vector-ref W i))] + [t2 (u32+ (BS0 a) (Maj a b c))]) + (lp (fx+ i 1) + (u32+ t1 t2) + a b c + (u32+ d t1) + e f g))])))) + + ;; Returns a freshly allocated 32-byte digest. + (def (sha256-bytevector bv) + (unless (bytevector? bv) + (error 'sha256-bytevector "expected bytevector" bv)) + (let* ([len (bytevector-length bv)] + [bitlen (fx* len 8)] + ;; Pad: 0x80 byte + zeros to (mod 64) == 56 + 8 bytes big-endian length + [pad1 (fx- 56 (fxmod (fx+ len 1) 64))] + [pad1 (cond [(fx<? pad1 0) (fx+ pad1 64)] [else pad1])] + [padded-len (fx+ len 1 pad1 8)] + [buf (make-bytevector padded-len 0)]) + (bytevector-copy! bv 0 buf 0 len) + (bytevector-u8-set! buf len #x80) + ;; 64-bit big-endian bit-length at the end. upper 32 bits first. + (write-u32-be! buf (fx- padded-len 8) (fxand (fxsrl bitlen 32) U32)) + (write-u32-be! buf (fx- padded-len 4) (fxand bitlen U32)) + (let ([state (vector-copy H0)]) + (let lp ([off 0]) + (cond + [(fx=? off padded-len) + (let ([out (make-bytevector 32)]) + (let inner ([i 0]) + (when (fx< i 8) + (write-u32-be! out (fx* 4 i) (vector-ref state i)) + (inner (fx+ i 1)))) + out)] + [else + (process-block! state buf off) + (lp (fx+ off 64))]))))) + + (def *hex-chars* "0123456789abcdef") + + (def (sha256-hex bv) + (let* ([d (sha256-bytevector bv)] + [s (make-string 64)]) + (let lp ([i 0]) + (when (fx< i 32) + (let ([b (bytevector-u8-ref d i)]) + (string-set! s (fx* 2 i) + (string-ref *hex-chars* (fxsrl b 4))) + (string-set! s (fx+ (fx* 2 i) 1) + (string-ref *hex-chars* (fxand b #xf)))) + (lp (fx+ i 1)))) + s)) +)