feat(std archive): pure-Scheme POSIX ustar reader
ober
423111f28ead9304fe2b6d72ee5a46ff709063d8
new file mode 100644 --- /dev/null +++ b/lib/std/archive/tar.ss @@ -0,0 +1,158 @@ +#!chezscheme +;;; (std archive tar) — POSIX ustar reader, pure-Scheme. +;;; +;;; Walks a tar archive supplied as a bytevector and yields each entry +;;; to a user-supplied procedure. Supports the common cases needed for +;;; reading ClamAV CVDs, source-distribution tarballs, and similar: +;;; +;;; - regular files (typeflag '0' and legacy NUL) +;;; - directories (typeflag '5') +;;; - GNU long-name extension (typeflag 'L') +;;; +;;; What it deliberately doesn't do: +;;; - block / character / symlink / hardlink / fifo / sparse files +;;; - pax extended headers +;;; - checksum verification (we accept any header that round-trips +;;; name+size; corrupt tarballs are caller's problem) +;;; +;;; Stream-only — the whole archive must be in memory. For ClamAV CVDs +;;; (~100 MB compressed, ~400 MB uncompressed) that's fine; for tens-of-GB +;;; archives a streaming variant would be needed. + +(library (std archive tar) + (export + tar-walk ;; bv proc — proc called as (name size type data-bv) + tar-entries ;; bv -> list of (alist name size type data) + tar-find ;; bv name -> bytevector | #f + tar-block-size) ;; constant 512 + + (import (chezscheme) + (only (jerboa core) def)) + + (def tar-block-size 512) + + ;; Chez R6RS `bytevector-copy` is full-copy only; for a slice we use + ;; the 5-arg `bytevector-copy!` into a fresh buffer. + (def (bv-slice bv start end) + (let* ([n (fx- end start)] + [out (make-bytevector n)]) + (bytevector-copy! bv start out 0 n) + out)) + + ;; --- header field readers ------------------------------------------ + ;; + ;; ustar fields are mostly NUL- or space-padded ASCII; sizes are + ;; octal. Stop reading at the first NUL or out-of-range char. + + (def (header-string bv off max-len) + (let loop ([i 0]) + (cond + [(or (fx=? i max-len) + (fx=? (bytevector-u8-ref bv (fx+ off i)) 0)) + (utf8->string (bv-slice bv off (fx+ off i)))] + [else (loop (fx+ i 1))]))) + + ;; Parse an octal-ASCII field, stopping at NUL or space. Used for + ;; size, mode, etc. Returns 0 for an all-NUL field (end-of-archive + ;; sentinel block). + (def (header-octal bv off max-len) + (let loop ([i 0] [acc 0]) + (cond + [(fx=? i max-len) acc] + [else + (let ([b (bytevector-u8-ref bv (fx+ off i))]) + (cond + [(or (fx=? b 0) ;; NUL + (fx=? b 32)) ;; space + acc] + [(and (fx>=? b 48) (fx<=? b 55)) ;; '0'..'7' + (loop (fx+ i 1) (fx+ (fx* acc 8) (fx- b 48)))] + [else acc]))]))) + + ;; Is the block at `off` all zeros? Two consecutive zero blocks mark + ;; end-of-archive. + (def (zero-block? bv off) + (let loop ([i 0]) + (cond + [(fx=? i tar-block-size) #t] + [(fx=? (bytevector-u8-ref bv (fx+ off i)) 0) + (loop (fx+ i 1))] + [else #f]))) + + ;; --- name handling --------------------------------------------------- + ;; + ;; ustar splits long names into a 100-byte `name` plus a 155-byte + ;; `prefix` at offset 345 (joined as prefix + "/" + name). GNU's + ;; 'L' typeflag instead puts the long name as the data of a special + ;; entry preceding the real one — we track that via long-name-buf. + (def (ustar-name bv off) + (let ([name (header-string bv off 100)] + [prefix (header-string bv (fx+ off 345) 155)]) + (cond + [(zero? (string-length prefix)) name] + [else (string-append prefix "/" name)]))) + + ;; --- main walker ----------------------------------------------------- + (def (tar-walk bv proc) + (let ([n (bytevector-length bv)]) + (let loop ([off 0] [pending-long-name #f]) + (cond + [(fx>=? (fx+ off tar-block-size) n) (void)] + [(zero-block? bv off) (void)] ;; end-of-archive + [else + (let* ([type-byte (bytevector-u8-ref bv (fx+ off 156))] + [type (cond + [(or (fx=? type-byte 0) (fx=? type-byte 48)) 'file] + [(fx=? type-byte 53) 'dir] + [(fx=? type-byte 76) 'long-name] ;; 'L' + [else 'other])] + [size (header-octal bv (fx+ off 124) 12)] + [data-off (fx+ off tar-block-size)] + [data-pad (fx* tar-block-size + (fxdiv (fx+ size (fx- tar-block-size 1)) + tar-block-size))] + [next-off (fx+ data-off data-pad)] + [name (cond + [pending-long-name pending-long-name] + [else (ustar-name bv off)])]) + (cond + [(eq? type 'long-name) + ;; The data is a NUL-terminated long file name for the + ;; NEXT entry; consume + record + recurse. + (let ([long (let ([raw (bv-slice bv data-off + (fx+ data-off size))]) + ;; strip trailing NUL(s) + (let lp ([m (bytevector-length raw)]) + (cond + [(or (fxzero? m) + (not (fx=? (bytevector-u8-ref raw (fx- m 1)) 0))) + (utf8->string (bv-slice raw 0 m))] + [else (lp (fx- m 1))])))]) + (loop next-off long))] + [(eq? type 'file) + (let ([data (bv-slice bv data-off (fx+ data-off size))]) + (proc name size 'file data) + (loop next-off #f))] + [else + ;; dir / other — skip data, clear pending-long-name + (loop next-off #f)]))])))) + + (def (tar-entries bv) + (let ([acc '()]) + (tar-walk bv + (lambda (name size type data) + (set! acc (cons (list (cons 'name name) + (cons 'size size) + (cons 'type type) + (cons 'data data)) + acc)))) + (reverse acc))) + + (def (tar-find bv name) + (call/cc + (lambda (k) + (tar-walk bv + (lambda (n size type data) + (when (string=? n name) (k data)))) + #f))) +)