fix: fail-closed on git errors, thread clamp, unicode OOB, marker detection, O(n²) perf, symlink cycles
ober
72b2f719c32ee77997dd5391098abf2576e7fe5e
--- a/gitsafe/git.ss +++ b/gitsafe/git.ss @@ -46,17 +46,20 @@ ;; --- Internal helpers --- ;; Run a git command and return trimmed stdout. - ;; Returns "" on error (non-zero exit), but warns on stderr. + ;; Fails closed: if git exits non-zero (corrupt index, lock, etc.) we raise + ;; instead of returning "", so a broken `git diff --cached` aborts the scan + ;; rather than silently reporting zero findings. (def (git-output args) (try (let ([out (run-process args)]) (string-trim out)) (catch (e) (let ([p (current-error-port)]) - (display "gitsafe: warning: git command failed: " p) + (display "gitsafe: error: git command failed: " p) (display (string-join args " ") p) (newline p)) - ""))) + (error 'git-output "git command failed; refusing to scan" + (string-join args " "))))) ;; Run git command and return exit code. (def (git-exit args) @@ -75,6 +78,16 @@ (def *hunk-header-re* (re "^@@ -[0-9,]+ \\+([0-9]+)(?:,[0-9]+)? @@")) + ;; Hunks accumulate their added lines in reverse (via cons, O(1) per line) + ;; while being built; finalize-hunk reverses them into forward order before + ;; the hunk is emitted to callers. + (def (finalize-hunk hunk) + (make-diff-hunk + (diff-hunk-file hunk) + (diff-hunk-old-start hunk) + (diff-hunk-new-start hunk) + (reverse (diff-hunk-lines hunk)))) + (def (parse-unified-diff diff-text current-file) (let loop ([lines (string-split diff-text #\newline)] [hunks '()] @@ -84,7 +97,7 @@ ;; Flush last hunk (reverse (if (and cur-hunk (not (null? (diff-hunk-lines cur-hunk)))) - (cons cur-hunk hunks) + (cons (finalize-hunk cur-hunk) hunks) hunks)) (let ([line (car lines)] [rest (cdr lines)]) @@ -97,7 +110,7 @@ ;; Save previous hunk if it had findings [hunks* (if (and cur-hunk (not (null? (diff-hunk-lines cur-hunk)))) - (cons cur-hunk hunks) + (cons (finalize-hunk cur-hunk) hunks) hunks)]) (loop rest hunks* @@ -116,8 +129,7 @@ (diff-hunk-file cur-hunk) (diff-hunk-old-start cur-hunk) (diff-hunk-new-start cur-hunk) - (append (diff-hunk-lines cur-hunk) - (list (cons ln content))))]) + (cons (cons ln content) (diff-hunk-lines cur-hunk)))]) (loop rest hunks updated-hunk (+ new-line-no 1))))] ;; Context line (space) — advance new-line counter [(and cur-hunk @@ -136,7 +148,7 @@ (def (flush-hunk hunks cur-hunk) (if (and cur-hunk (not (null? (diff-hunk-lines cur-hunk)))) - (cons cur-hunk hunks) + (cons (finalize-hunk cur-hunk) hunks) hunks)) (def *diff-new-file-re* @@ -178,16 +190,15 @@ (not (string-prefix? "+++" line))) (let ([content (substring line 1 (string-length line))] [ln new-line-no]) - (loop rest - current-file - hunks - (make-diff-hunk - (diff-hunk-file cur-hunk) - (diff-hunk-old-start cur-hunk) - (diff-hunk-new-start cur-hunk) - (append (diff-hunk-lines cur-hunk) - (list (cons ln content)))) - (+ new-line-no 1)))] + (loop rest + current-file + hunks + (make-diff-hunk + (diff-hunk-file cur-hunk) + (diff-hunk-old-start cur-hunk) + (diff-hunk-new-start cur-hunk) + (cons (cons ln content) (diff-hunk-lines cur-hunk))) + (+ new-line-no 1)))] [(and cur-hunk (> (string-length line) 0) (char=? (string-ref line 0) #\space)) --- a/gitsafe/main.ss +++ b/gitsafe/main.ss @@ -56,11 +56,20 @@ (def (install-hook! hook-path content) (if (file-exists? hook-path) - (let ([existing (call-with-input-file hook-path - (lambda (p) (get-line p)))]) - (if (and (string? existing) - (or (string-contains existing "gitsafe") - (string-contains existing "Installed by gitsafe"))) + (let ([lines (call-with-input-file hook-path + (lambda (p) + (let loop ([n 0] [acc '()]) + (if (>= n 3) + (reverse acc) + (let ([ln (get-line p)]) + (if (eof-object? ln) + (reverse acc) + (loop (+ n 1) (cons ln acc))))))))]) + (if (any (lambda (existing) + (and (string? existing) + (or (string-contains existing "gitsafe") + (string-contains existing "Installed by gitsafe")))) + lines) (begin (write-hook-file! hook-path content) (displayln " Updated: " hook-path)) --- a/gitsafe/patterns.ss +++ b/gitsafe/patterns.ss @@ -45,7 +45,7 @@ (let ([freqs (make-vector 256 0)]) (let loop ([i 0]) (when (< i len) - (let ([b (char->integer (string-ref str i))]) + (let ([b (modulo (char->integer (string-ref str i)) 256)]) (vector-set! freqs b (+ 1 (vector-ref freqs b)))) (loop (+ i 1)))) (let ([n (inexact len)]) --- a/gitsafe/scanner.ss +++ b/gitsafe/scanner.ss @@ -39,6 +39,7 @@ (std misc ports) (std os path) (only (std os path-util) file-size) + (only (std os posix) posix-stat stat-dev stat-ino free-stat) (gitsafe patterns) (gitsafe entropy) (gitsafe config) @@ -64,15 +65,15 @@ ;; --- Number of CPU cores for parallel scanning --- ;; Respects GITSAFE_THREADS env var; otherwise uses platform-native cpu-count. (def *num-cpus* - (or (and (getenv "GITSAFE_THREADS") - (string->number (getenv "GITSAFE_THREADS"))) - (cpu-count))) + (max 1 (or (and (getenv "GITSAFE_THREADS") + (string->number (getenv "GITSAFE_THREADS"))) + (cpu-count)))) ;; --- Split lst into k roughly equal contiguous chunks --- (def (chunk-list lst k) (let* ([v (list->vector lst)] [total (vector-length v)] - [n (min k total)]) + [n (max 1 (min k total))]) (map (lambda (i) (let ([start (quotient (* i total) n)] [end (quotient (* (+ i 1) total) n)]) @@ -648,7 +649,7 @@ [line-no 1] [results '()]) (if (null? lines) - (reverse results) + results (let ([findings (scan-fragment (make-scan-fragment file line-no (car lines) 'file #f #f) @@ -656,7 +657,7 @@ config)]) (loop (cdr lines) (+ line-no 1) - (append results findings)))))) + (append (reverse findings) results)))))) ;; --- Scan full file content (string), honouring ML-data sniffing --- (def (scan-content file content config) @@ -847,22 +848,42 @@ (string-append dir name) (string-append dir "/" name)))) + ;; Canonical identity for a directory: device + inode via stat(2). stat + ;; follows symlinks, so a symlinked directory reports its target's dev/ino, + ;; which lets the visited-set below detect symlink cycles. #f if stat fails. + (def (directory-identity path) + (try + (let ([buf (posix-stat path)]) + (let ([id (string-append (number->string (stat-dev buf)) + ":" + (number->string (stat-ino buf)))]) + (free-stat buf) + id)) + (catch (e) #f))) + (def (expand-scan-path path) - (cond - [(not (file-exists? path)) '()] - [(and (file-directory? path) - (string=? (path-strip-directory path) ".git")) - '()] - [(file-directory? path) - (let loop ([entries (try (directory-list path) (catch (e) '()))] - [acc '()]) - (if (null? entries) - (reverse acc) - (let* ([name (entry->string (car entries))] - [full (join-path path name)]) - (loop (cdr entries) - (append (expand-scan-path full) acc)))))] - [else (list path)])) + (let ([visited (make-hash-table)]) + (let expand ([path path]) + (cond + [(not (file-exists? path)) '()] + [(and (file-directory? path) + (string=? (path-strip-directory path) ".git")) + '()] + [(file-directory? path) + (let ([id (directory-identity path)]) + (if (and id (hash-key? visited id)) + '() + (begin + (when id (hash-put! visited id #t)) + (let loop ([entries (try (directory-list path) (catch (e) '()))] + [acc '()]) + (if (null? entries) + (reverse acc) + (let* ([name (entry->string (car entries))] + [full (join-path path name)]) + (loop (cdr entries) + (append (expand full) acc))))))))] + [else (list path)])))) (def (expand-scan-paths paths) (apply append (map expand-scan-path paths))) @@ -894,8 +915,10 @@ (filter-ignored-findings (pmap-files (lambda (path) - (let ([content (read-file-string path)]) - (scan-content path content config))) + (let ([content (try (read-file-string path) (catch (e) #f))]) + (if content + (scan-content path content config) + '()))) to-scan) ignore-pats config)