Implement gitsafe: secret-scanning git hooks in Jerboa Scheme
ober
a25e1dd584d5c2443ed61d6057d35d99317334e2
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +gitsafe-bin +*.so +*.wpo new file mode 100644 --- /dev/null +++ b/build-binary.ss @@ -0,0 +1,214 @@ +#!chezscheme +;; Build the gitsafe static binary. +;; +;; Usage: make binary +;; (which runs: scheme --libdirs . --script build-binary.ss) +;; +;; Produces: ./gitsafe-bin (single ELF binary with embedded boot files + program) + +(import (chezscheme)) + +;; --- Helper: generate C header from binary file --- +(define (file->c-header input-path output-path array-name size-name) + (let* ([port (open-file-input-port input-path)] + [data (get-bytevector-all port)] + [size (bytevector-length data)]) + (close-port port) + (call-with-output-file output-path + (lambda (out) + (fprintf out "/* Auto-generated — do not edit */\n") + (fprintf out "static const unsigned char ~a[] = {\n" array-name) + (let loop ([i 0]) + (when (< i size) + (when (= 0 (modulo i 16)) (fprintf out " ")) + (fprintf out "0x~2,'0x" (bytevector-u8-ref data i)) + (when (< (+ i 1) size) (fprintf out ",")) + (when (= 15 (modulo i 16)) (fprintf out "\n")) + (loop (+ i 1)))) + (fprintf out "\n};\n") + (fprintf out "static const unsigned int ~a = ~a;\n" size-name size)) + 'replace) + (printf " ~a: ~a bytes\n" output-path size))) + +;; --- Detect OS --- +(define freebsd? + (let ([mt (symbol->string (machine-type))]) + (or (string=? mt "ta6fb") (string=? mt "a6fb") + (string=? mt "tarm64fb") (string=? mt "arm64fb")))) + +(define termux? + (let ([p (getenv "PREFIX")]) + (and p (> (string-length p) 0) + (file-exists? (string-append p "/bin/termux-info"))))) + +;; --- Locate Chez install directory --- +(define (find-csv-dir lib-dir mt) + (let ([csv-dir + (let lp ([dirs (guard (e [#t '()]) (directory-list lib-dir))]) + (cond + [(null? dirs) #f] + [(and (> (string-length (car dirs)) 3) + (string=? "csv" (substring (car dirs) 0 3))) + (format "~a/~a/~a" lib-dir (car dirs) mt)] + [else (lp (cdr dirs))]))]) + (and csv-dir + (file-exists? (format "~a/main.o" csv-dir)) + csv-dir))) + +(define chez-dir + (or (getenv "CHEZ_DIR") + (let ([mt (symbol->string (machine-type))] + [home (getenv "HOME")]) + (or (find-csv-dir (format "~a/.local/lib" home) mt) + (find-csv-dir "/usr/local/lib" mt) + (find-csv-dir "/usr/lib" mt) + (let ([p (getenv "PREFIX")]) + (and p (find-csv-dir (format "~a/lib" p) mt))))))) + +(unless chez-dir + (display "Error: Cannot find Chez install dir. Set CHEZ_DIR.\n") + (exit 1)) + +(define home (getenv "HOME")) +(define jerboa-dir (or (getenv "JERBOA_HOME") + (format "~a/mine/jerboa" home))) + +(printf "Chez dir: ~a\n" chez-dir) +(printf "Jerboa dir: ~a\n" jerboa-dir) + +;; Add library paths +(library-directories + (append + (list (cons (current-directory) (current-directory)) + (cons (format "~a/lib" jerboa-dir) + (format "~a/lib" jerboa-dir))) + (library-directories))) + +;; --- Step 1: Compile all modules (optimize-level 3, WPO) --- +(printf "\n[1/5] Compiling all modules (optimize-level 3, WPO)...\n") +(parameterize ([compile-imported-libraries #t] + [optimize-level 3] + [cp0-effort-limit 500] + [cp0-score-limit 50] + [cp0-outer-unroll-limit 1] + [commonization-level 4] + [enable-unsafe-application #t] + [enable-unsafe-variable-reference #t] + [enable-arithmetic-left-associative #t] + [debug-level 0] + [generate-inspector-information #f] + [generate-wpo-files #t]) + (compile-program "gitsafe/main-binary.ss")) + +;; --- Step 2: Whole-program optimization --- +(printf "[2/5] Running whole-program optimization...\n") +(let ([missing (compile-whole-program "gitsafe/main-binary.wpo" "gitsafe-all.so")]) + (unless (null? missing) + (printf " WPO: ~a libraries not incorporated (missing .wpo):\n" (length missing)) + (for-each (lambda (lib) (printf " ~a\n" lib)) missing))) + +;; --- Step 3: Create boot file + C headers --- +(printf "[3/5] Creating boot file and C headers...\n") + +(define (existing-so-files paths) + (filter file-exists? paths)) + +(define gitsafe-modules + '("gitsafe/entropy" + "gitsafe/config" + "gitsafe/allowlist" + "gitsafe/patterns" + "gitsafe/git" + "gitsafe/scanner" + "gitsafe/output")) + +(apply make-boot-file "gitsafe.boot" '("scheme" "petite") + (existing-so-files + (map (lambda (m) (format "~a.so" m)) gitsafe-modules))) + +(file->c-header "gitsafe-all.so" + "gitsafe_program.h" + "gitsafe_program_data" "gitsafe_program_size") +(file->c-header (format "~a/petite.boot" chez-dir) + "gitsafe_petite_boot.h" + "petite_boot_data" "petite_boot_size") +(file->c-header (format "~a/scheme.boot" chez-dir) + "gitsafe_scheme_boot.h" + "scheme_boot_data" "scheme_boot_size") +(file->c-header "gitsafe.boot" + "gitsafe_boot.h" + "gitsafe_boot_data" "gitsafe_boot_size") + +;; --- Step 4: Generate C main, compile, and link --- +(printf "[4/5] Compiling and linking...\n") + +(call-with-output-file "gitsafe-main.c" + (lambda (out) + (fprintf out "/* Auto-generated — do not edit */\n") + (fprintf out "#define _GNU_SOURCE\n") + (fprintf out "#include <stdlib.h>\n") + (fprintf out "#include <stdio.h>\n") + (fprintf out "#include <string.h>\n") + (fprintf out "#include <unistd.h>\n") + (fprintf out "#include \"scheme.h\"\n") + (fprintf out "#include \"gitsafe_petite_boot.h\"\n") + (fprintf out "#include \"gitsafe_scheme_boot.h\"\n") + (fprintf out "#include \"gitsafe_boot.h\"\n") + (fprintf out "#include \"gitsafe_program.h\"\n") + (fprintf out "\n") + (fprintf out "int main(int argc, char *argv[]) {\n") + (fprintf out " char prog_path[256];\n") + (fprintf out " const char *tmpdir = getenv(\"TMPDIR\");\n") + (fprintf out " if (!tmpdir) tmpdir = \"/tmp\";\n") + (display " snprintf(prog_path, sizeof(prog_path), \"%s/gitsafe-XXXXXX\", tmpdir);\n" out) + (fprintf out " int fd = mkstemp(prog_path);\n") + (fprintf out " if (fd < 0) { perror(\"mkstemp\"); return 1; }\n") + (fprintf out " if (write(fd, gitsafe_program_data, gitsafe_program_size)\n") + (fprintf out " != (ssize_t)gitsafe_program_size) {\n") + (fprintf out " perror(\"write\"); close(fd); unlink(prog_path); return 1;\n") + (fprintf out " }\n") + (fprintf out " close(fd);\n") + (fprintf out "\n") + (fprintf out " Sscheme_init(NULL);\n") + (fprintf out " Sregister_boot_file_bytes(\"petite\", (void*)petite_boot_data, petite_boot_size);\n") + (fprintf out " Sregister_boot_file_bytes(\"scheme\", (void*)scheme_boot_data, scheme_boot_size);\n") + (fprintf out " Sregister_boot_file_bytes(\"gitsafe\", (void*)gitsafe_boot_data, gitsafe_boot_size);\n") + (fprintf out " Sbuild_heap(NULL, NULL);\n") + (fprintf out " int status = Sscheme_script(prog_path, argc, (const char **)argv);\n") + (fprintf out " unlink(prog_path);\n") + (fprintf out " Sscheme_deinit();\n") + (fprintf out " return status;\n") + (fprintf out "}\n")) + 'replace) + +(define link-libs + (cond + [freebsd? "-lkernel -llz4 -lz -lm -lpthread -lncurses"] + [termux? "-lkernel -llz4 -lz -lm -ldl -lpthread -lncurses -liconv"] + [else "-lkernel -llz4 -lz -lm -ldl -lpthread -luuid -lncurses"])) + +(let ([cc (or (getenv "CC") "cc")]) + (let ([rc (system (format "~a -c -I~a -o gitsafe-main.o gitsafe-main.c" cc chez-dir))]) + (unless (= rc 0) (printf "Error: C compilation failed\n") (exit 1))) + (let ([rc (system (format "~a -o gitsafe-bin gitsafe-main.o -L~a ~a" + cc chez-dir link-libs))]) + (unless (= rc 0) (printf "Error: linking failed\n") (exit 1)))) + +;; --- Step 5: Cleanup --- +(printf "[5/5] Cleaning up intermediate files...\n") +(for-each (lambda (f) (when (file-exists? f) (delete-file f))) + '("gitsafe-main.c" "gitsafe-main.o" + "gitsafe_program.h" "gitsafe_petite_boot.h" + "gitsafe_scheme_boot.h" "gitsafe_boot.h" + "gitsafe-all.so" "gitsafe.boot" + "gitsafe/main-binary.wpo" "gitsafe/main-binary.so")) + +(for-each (lambda (m) + (for-each (lambda (ext) + (let ([f (format "~a~a" m ext)]) + (when (file-exists? f) (delete-file f)))) + '(".so" ".wpo"))) + gitsafe-modules) + +(printf "\nDone! Binary: ./gitsafe-bin\n") +(printf " Install: make install\n") new file mode 100644 --- /dev/null +++ b/gitsafe.json @@ -0,0 +1,27 @@ +{ + "severity": "medium", + "entropy": true, + "patterns": { + "disabled": [], + "custom": [] + }, + "exclude": [ + "*.lock", + "go.sum", + "*.md", + "vendor/**", + "node_modules/**", + "*.min.js", + "*.min.css", + "test/fixtures/**" + ], + "allowlist": { + "files": [], + "patterns": [ + "EXAMPLE_KEY", + "YOUR_API_KEY_HERE", + "fake_secret_for_testing", + "XXXXXX" + ] + } +} new file mode 100644 --- /dev/null +++ b/gitsafe/allowlist.ss @@ -0,0 +1,70 @@ +#!chezscheme +(library (gitsafe allowlist) + (export line-suppressed? + allowlisted? + load-ignorefile + ignored-file?) + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (jerboa prelude) + (std pregexp) + (std misc ports) + (std misc string) + (gitsafe config)) + + ;; --- Inline suppression detection --- + ;; Supports: + ;; # gitsafe:ignore + ;; # gitsafe:ignore=pattern-id + ;; // gitsafe:ignore + ;; /* gitsafe:ignore */ + + (def *suppress-pat* + (pregexp "(?:#|//|/\\*)\\s*gitsafe:ignore(?:=([A-Za-z0-9_-]+))?")) + + ;; Returns #t if the line is suppressed (optionally for a specific pattern-id symbol). + (def (line-suppressed? line (pattern-id #f)) + (let ([m (pregexp-match *suppress-pat* line)]) + (if (not m) + #f + ;; m = (full-match maybe-pattern-id-group) + (let ([specific (and (pair? (cdr m)) (cadr m))]) + (cond + ;; No specific pattern in comment — suppress all + [(not specific) #t] + ;; No pattern-id filter requested — suppress all + [(not pattern-id) #t] + ;; Specific pattern matches requested id + [else (string=? specific (symbol->string pattern-id))]))))) + + ;; --- Allowlist string check --- + ;; Returns #t if the matched text contains any known-safe string. + (def (allowlisted? matched-text config) + (and (any (lambda (s) (string-contains matched-text s)) + (gitsafe-config-allowlist-strings config)) + #t)) + + ;; --- .gitsafeignore file --- + ;; Loads glob patterns from a gitignore-style file. + ;; Blank lines and lines starting with # are ignored. + (def (load-ignorefile (path ".gitsafeignore")) + (if (not (file-exists? path)) + '() + (filter (lambda (line) + (and (not (string-empty? line)) + (not (string-prefix? "#" line)))) + (read-file-lines path)))) + + ;; --- Check if a file path matches any ignorefile pattern --- + (def (ignored-file? path ignore-patterns) + (any (lambda (glob) (glob-match? glob path)) + ignore-patterns)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/gitsafe/config.ss @@ -0,0 +1,158 @@ +#!chezscheme +(library (gitsafe config) + (export make-gitsafe-config + gitsafe-config? + gitsafe-config-severity + gitsafe-config-entropy-enabled + gitsafe-config-disabled-patterns + gitsafe-config-custom-patterns + gitsafe-config-exclude-globs + gitsafe-config-allowlist-files + gitsafe-config-allowlist-strings + default-config + load-config + config-excluded? + glob-match?) + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (jerboa prelude) + (std text json) + (std misc ports) + (std misc string)) + + ;; --- Config struct --- + (defstruct gitsafe-config + (severity ;; symbol: 'low | 'medium | 'high | 'critical + entropy-enabled ;; boolean + disabled-patterns ;; list of symbols (pattern IDs to skip) + custom-patterns ;; list of alists from JSON + exclude-globs ;; list of glob strings + allowlist-files ;; list of file paths + allowlist-strings ;; list of literal strings known safe + )) + + ;; --- Default configuration --- + (def (default-config) + (make-gitsafe-config + 'medium ;; severity + #t ;; entropy-enabled + '() ;; disabled-patterns + '() ;; custom-patterns + ;; Standard excludes: lock files, docs, test dirs + '("*.lock" "go.sum" "*.md" "vendor/**" + "node_modules/**" "*.min.js" "*.min.css") + '() ;; allowlist-files + '() ;; allowlist-strings + )) + + ;; --- Glob matching --- + ;; Supports: * (non-separator), ** (any), ? (single char) + (def (glob-match? pattern path) + (let loop ([ps (string->list pattern)] + [xs (string->list path)]) + (cond + ;; Both exhausted — match + [(and (null? ps) (null? xs)) #t] + ;; Pattern exhausted, path not — no match + [(null? ps) #f] + ;; ** matches any sequence including / + [(and (pair? ps) (char=? (car ps) #\*) + (pair? (cdr ps)) (char=? (cadr ps) #\*)) + (let ([rest-ps (cddr ps)]) + ;; Skip any leading / after ** + (let ([rest-ps (if (and (pair? rest-ps) (char=? (car rest-ps) #\/)) + (cdr rest-ps) + rest-ps)]) + (or (loop rest-ps xs) + (and (pair? xs) + (loop ps (cdr xs))))))] + ;; * matches any non-/ chars + [(char=? (car ps) #\*) + (let ([rest-ps (cdr ps)]) + (or (loop rest-ps xs) + (and (pair? xs) + (not (char=? (car xs) #\/)) + (loop ps (cdr xs)))))] + ;; ? matches a single non-/ char + [(char=? (car ps) #\?) + (and (pair? xs) + (not (char=? (car xs) #\/)) + (loop (cdr ps) (cdr xs)))] + ;; Path exhausted, pattern not — no match + [(null? xs) #f] + ;; Literal character match + [(char=? (car ps) (car xs)) + (loop (cdr ps) (cdr xs))] + ;; No match + [else #f]))) + + ;; --- Check if path matches any exclude glob --- + (def (config-excluded? config path) + (any (lambda (glob) (glob-match? glob path)) + (gitsafe-config-exclude-globs config))) + + ;; --- Parse severity string to symbol --- + (def (parse-severity s) + (match s + ["low" 'low] + ["medium" 'medium] + ["high" 'high] + ["critical" 'critical] + [_ 'medium])) + + ;; --- Parse a JSON value as a list of strings --- + (def (json->string-list v) + (if (vector? v) + (filter string? (vector->list v)) + '())) + + ;; --- Load config from file --- + (def (load-config (path ".gitsafe.json")) + (if (not (file-exists? path)) + (default-config) + (try + (let* ([content (read-file-string path)] + [obj (string->json-object content)] + [severity (parse-severity + (hash-ref obj "severity" "medium"))] + [entropy (let ([v (hash-ref obj "entropy" #t)]) + (if (boolean? v) v #t))] + [patterns-obj (hash-ref obj "patterns" #f)] + [disabled (if (and patterns-obj + (hash-key? patterns-obj "disabled")) + (map string->symbol + (json->string-list + (hash-ref patterns-obj "disabled" (vector)))) + '())] + [custom (if (and patterns-obj + (hash-key? patterns-obj "custom")) + (let ([cv (hash-ref patterns-obj "custom" (vector))]) + (if (vector? cv) + (vector->list cv) + '())) + '())] + [excludes (json->string-list (hash-ref obj "exclude" (vector)))] + [allowlist-obj (hash-ref obj "allowlist" #f)] + [al-files (if allowlist-obj + (json->string-list + (hash-ref allowlist-obj "files" (vector))) + '())] + [al-strs (if allowlist-obj + (json->string-list + (hash-ref allowlist-obj "patterns" (vector))) + '())]) + (make-gitsafe-config + severity entropy disabled custom + excludes al-files al-strs)) + (catch (e) + (displayln "gitsafe: warning: could not parse .gitsafe.json, using defaults") + (default-config))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/gitsafe/entropy.ss @@ -0,0 +1,86 @@ +#!chezscheme +(library (gitsafe entropy) + (export shannon-entropy + high-entropy? + string-charset + *entropy-threshold-hex* + *entropy-threshold-base64* + *entropy-threshold-generic*) + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (jerboa prelude)) + + ;; --- Thresholds --- + (def *entropy-threshold-hex* 3.0) + (def *entropy-threshold-base64* 4.0) + (def *entropy-threshold-generic* 4.5) + + ;; Shannon entropy of a string (bits per character). + ;; Returns a flonum in [0.0, ~6.0] for printable ASCII. + (def (shannon-entropy str) + (let ([len (string-length str)]) + (if (= len 0) + 0.0 + (let ([freqs (make-vector 256 0)]) + ;; Count character frequencies + (let loop ([i 0]) + (when (< i len) + (let ([b (char->integer (string-ref str i))]) + (vector-set! freqs b (+ 1 (vector-ref freqs b)))) + (loop (+ i 1)))) + ;; Calculate entropy: sum of -p*log2(p) + (let ([n (inexact len)]) + (let loop ([i 0] [entropy 0.0]) + (if (>= i 256) + entropy + (let ([count (vector-ref freqs i)]) + (if (= count 0) + (loop (+ i 1) entropy) + (let ([p (/ (inexact count) n)]) + (loop (+ i 1) (- entropy (* p (log p 2)))))))))))))) + + ;; Check if a string exceeds the entropy threshold. + (def (high-entropy? str (threshold *entropy-threshold-generic*)) + (> (shannon-entropy str) threshold)) + + ;; Classify the character set of a string. + ;; Returns: 'hex | 'base64 | 'alphanumeric | 'printable | 'mixed + (def (string-charset str) + (let ([len (string-length str)]) + (if (= len 0) + 'empty + (let loop ([i 0] [is-hex #t] [is-b64 #t] [is-alnum #t] [is-printable #t]) + (if (>= i len) + (cond + [is-hex 'hex] + [is-b64 'base64] + [is-alnum 'alphanumeric] + [is-printable 'printable] + [else 'mixed]) + (let ([c (string-ref str i)]) + (let ([hex? (or (char<=? #\0 c #\9) + (char<=? #\a c #\f) + (char<=? #\A c #\F))] + [b64? (or (char<=? #\A c #\Z) + (char<=? #\a c #\z) + (char<=? #\0 c #\9) + (char=? c #\+) (char=? c #\/) + (char=? c #\=))] + [alnum? (or (char<=? #\A c #\Z) + (char<=? #\a c #\z) + (char<=? #\0 c #\9))] + [print? (and (char>=? c #\space) (char<? c #\delete))]) + (loop (+ i 1) + (and is-hex hex?) + (and is-b64 b64?) + (and is-alnum alnum?) + (and is-printable print?))))))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/gitsafe/git.ss @@ -0,0 +1,172 @@ +#!chezscheme +(library (gitsafe git) + (export staged-files + staged-diff + staged-content + push-commits + changed-files-in-range + range-diff + git-repo? + git-root + make-diff-hunk + diff-hunk? + diff-hunk-file + diff-hunk-old-start + diff-hunk-new-start + diff-hunk-lines) + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (jerboa prelude) + (std pregexp) + (std misc process) + (std misc string) + (std misc ports)) + + ;; --- Diff hunk struct --- + (defstruct diff-hunk + (file ;; string: file path + old-start ;; integer: original line number start + new-start ;; integer: new line number start + lines ;; list of (line-number . content) pairs (added lines only) + )) + + ;; --- Internal helpers --- + + ;; Run a git command and return trimmed stdout. + ;; Returns "" on error (non-zero exit). + (def (git-output args) + (try + (let ([out (run-process args)]) + (string-trim out)) + (catch (e) ""))) + + ;; Run git command and return exit code. + (def (git-exit args) + (try + (run-process/batch args) + (catch (e) 1))) + + ;; Split a string on newlines and remove empty lines. + (def (split-lines str) + (filter (lambda (s) (not (string-empty? s))) + (string-split str #\newline))) + + ;; --- Parse unified diff format --- + ;; Returns list of diff-hunk structs from a git diff output string. + ;; Only captures added lines (lines starting with +, not +++). + (def (parse-unified-diff diff-text current-file) + (let loop ([lines (string-split diff-text #\newline)] + [hunks '()] + [cur-hunk #f] + [new-line-no 0]) + (if (null? lines) + ;; Flush last hunk + (reverse (if (and cur-hunk + (not (null? (diff-hunk-lines cur-hunk)))) + (cons cur-hunk hunks) + hunks)) + (let ([line (car lines)] + [rest (cdr lines)]) + (cond + ;; Hunk header: @@ -old,count +new,count @@ + [(pregexp-match "^@@ -[0-9,]+ \\+([0-9]+)(?:,[0-9]+)? @@" line) + => + (lambda (m) + (let* ([start-str (cadr m)] + [new-start (string->number start-str)] + ;; Save previous hunk if it had findings + [hunks* (if (and cur-hunk + (not (null? (diff-hunk-lines cur-hunk)))) + (cons cur-hunk hunks) + hunks)]) + (loop rest + hunks* + (make-diff-hunk current-file 0 new-start '()) + new-start)))] + ;; Added line (not +++ header) + [(and cur-hunk + (> (string-length line) 0) + (char=? (string-ref line 0) #\+) + (not (string-prefix? "+++" line))) + (let ([content (substring line 1 (string-length line))] + [ln new-line-no]) + ;; Append line to current hunk + (let ([updated-hunk + (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))))]) + (loop rest hunks updated-hunk (+ new-line-no 1))))] + ;; Context line (space) — advance new-line counter + [(and cur-hunk + (> (string-length line) 0) + (char=? (string-ref line 0) #\space)) + (loop rest hunks cur-hunk (+ new-line-no 1))] + ;; Removed line (-) — don't advance new-line counter + [(and cur-hunk + (> (string-length line) 0) + (char=? (string-ref line 0) #\-)) + (loop rest hunks cur-hunk new-line-no)] + ;; Any other line (diff header, etc.) + [else + (loop rest hunks cur-hunk new-line-no)]))))) + + ;; --- Public API --- + + ;; Returns #t if inside a git repository. + (def (git-repo?) + (= 0 (git-exit '("git" "rev-parse" "--git-dir")))) + + ;; Returns the absolute path to the repo root. + (def (git-root) + (git-output '("git" "rev-parse" "--show-toplevel"))) + + ;; Returns list of staged file paths (files added/modified/renamed in index). + (def (staged-files) + (split-lines + (git-output '("git" "diff" "--cached" "--name-only" + "--diff-filter=ACMR")))) + + ;; Returns a list of diff-hunk structs for a staged file. + ;; Only includes added lines. + (def (staged-diff path) + (let ([diff-text (git-output + (list "git" "diff" "--cached" "-U0" "--" path))]) + (if (string-empty? diff-text) + '() + (parse-unified-diff diff-text path)))) + + ;; Returns the full staged (index) content of a file. + ;; This is what would be committed, not the working copy. + (def (staged-content path) + (try + (run-process (list "git" "show" (string-append ":" path))) + (catch (e) ""))) + + ;; Returns list of commit SHAs being pushed (from remote-ref..local-ref). + (def (push-commits local-ref remote-ref) + (let ([range (string-append remote-ref ".." local-ref)]) + (split-lines + (git-output (list "git" "rev-list" range))))) + + ;; Returns list of file paths changed in a commit range. + (def (changed-files-in-range from-ref to-ref) + (split-lines + (git-output (list "git" "diff" "--name-only" + "--diff-filter=ACMR" + from-ref to-ref)))) + + ;; Returns unified diff text for a file in a commit range. + (def (range-diff from-ref to-ref path) + (git-output (list "git" "diff" "-U0" from-ref to-ref "--" path))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/gitsafe/main-binary.ss @@ -0,0 +1,235 @@ +#!chezscheme +;;; gitsafe/main-binary -- Entry point for compiled static binary. +;;; In binary mode all libraries are already compiled in via boot files. +;;; No library-directories setup needed. + +(import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (jerboa prelude) + (std misc process) + (std misc ports) + (gitsafe config) + (gitsafe scanner) + (gitsafe git) + (gitsafe output)) + +;; --- Version --- +(def *gitsafe-version* "0.1.0") + +;; --- Hook installation --- + +(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"))) + (begin + (write-file-string hook-path content) + (displayln " Updated: " hook-path)) + (begin + (displayln " Warning: " hook-path " already exists and wasn't installed by gitsafe.") + (displayln " Append manually or back it up first.")))) + (begin + (write-file-string hook-path content) + (displayln " Created: " hook-path)))) + +(def (make-executable! path) + (run-process (list "chmod" "+x" path)) + (void)) + +(def (cmd-install) + (if (not (git-repo?)) + (begin (displayln "gitsafe: error: not inside a git repository") (exit 2)) + (let* ([root (git-root)] + [hooks-dir (string-append root "/.git/hooks")]) + (displayln "Installing git hooks into " hooks-dir "...") + (install-hook! + (string-append hooks-dir "/pre-commit") + "#!/bin/sh\n# Installed by gitsafe\nexec gitsafe pre-commit\n") + (make-executable! (string-append hooks-dir "/pre-commit")) + (install-hook! + (string-append hooks-dir "/pre-push") + "#!/bin/sh\n# Installed by gitsafe\nwhile read local_ref local_sha remote_ref remote_sha; do\n gitsafe pre-push --local-ref \"$local_ref\" --remote-ref \"$remote_ref\" || exit $?\ndone\n") + (make-executable! (string-append hooks-dir "/pre-push")) + (displayln "Done.")))) + +(def (cmd-uninstall) + (if (not (git-repo?)) + (begin (displayln "gitsafe: error: not inside a git repository") (exit 2)) + (let* ([root (git-root)] + [hooks-dir (string-append root "/.git/hooks")] + [pre-commit (string-append hooks-dir "/pre-commit")] + [pre-push (string-append hooks-dir "/pre-push")]) + (for-each (lambda (hook-path) + (if (file-exists? hook-path) + (let ([content (read-file-string hook-path)]) + (if (string-contains content "Installed by gitsafe") + (begin + (delete-file hook-path) + (displayln " Removed: " hook-path)) + (displayln " Skipped: " hook-path " (not installed by gitsafe)"))) + (displayln " Not found: " hook-path))) + (list pre-commit pre-push)) + (displayln "Done.")))) + +;; --- Scanning dispatch --- + +(def (run-scan findings format verbose?) + (if (null? findings) + (begin + (when verbose? (display-findings findings format verbose?)) + (display-summary findings) + (exit 0)) + (begin + (display-findings findings format verbose?) + (exit 1)))) + +(def (cmd-pre-commit config format verbose?) + (if (not (git-repo?)) + (begin (displayln "gitsafe: error: not inside a git repository") (exit 2)) + (run-scan (scan-staged config) format verbose?))) + +(def (cmd-pre-push local-ref remote-ref config format verbose?) + (if (not (git-repo?)) + (begin (displayln "gitsafe: error: not inside a git repository") (exit 2)) + (run-scan (scan-push-range local-ref remote-ref config) format verbose?))) + +(def (cmd-scan paths config format verbose?) + (if (null? paths) + (begin (displayln "gitsafe: error: no paths specified") (exit 2)) + (run-scan (scan-files paths config) format verbose?))) + +;; --- Argument parsing (identical to main.ss) --- + +(def (parse-args args) + (let loop ([args args] + [mode "pre-commit"] + [paths '()] + [cfg-path ".gitsafe.json"] + [format "text"] + [severity #f] + [entropy #t] + [verbose #f] + [local-ref #f] + [remote-ref #f]) + (cond + [(null? args) + (list mode paths cfg-path format severity entropy verbose local-ref remote-ref)] + + [(member (car args) '("pre-commit" "pre-push" "scan" "install" "uninstall")) + (loop (cdr args) (car args) paths cfg-path format severity entropy verbose local-ref remote-ref)] + + [(string=? (car args) "--config") + (if (pair? (cdr args)) + (loop (cddr args) mode paths (cadr args) format severity entropy verbose local-ref remote-ref) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref))] + + [(string=? (car args) "--format") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path (cadr args) severity entropy verbose local-ref remote-ref) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref))] + + [(string=? (car args) "--severity") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format (cadr args) entropy verbose local-ref remote-ref) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref))] + + [(string=? (car args) "--no-entropy") + (loop (cdr args) mode paths cfg-path format severity #f verbose local-ref remote-ref)] + + [(string=? (car args) "--verbose") + (loop (cdr args) mode paths cfg-path format severity entropy #t local-ref remote-ref)] + + [(string=? (car args) "--local-ref") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose (cadr args) remote-ref) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref))] + + [(string=? (car args) "--remote-ref") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref (cadr args)) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref))] + + [(string=? (car args) "--version") + (displayln "gitsafe " *gitsafe-version*) + (exit 0)] + + [(string=? (car args) "--help") + (display +"Usage: gitsafe [MODE] [OPTIONS] + +Modes: + pre-commit Scan staged files (default) + pre-push Scan commits being pushed + scan PATH... Scan specific files or directories + install Install git hooks in .git/hooks/ + uninstall Remove git hooks + +Options: + --config PATH Path to .gitsafe.json (default: .gitsafe.json) + --format text|json Output format (default: text) + --severity LEVEL Minimum severity: low|medium|high|critical (default: medium) + --no-entropy Disable entropy analysis + --verbose Show scan statistics + --version Print version + --help Print this help +") + (exit 0)] + + [else + (loop (cdr args) mode (append paths (list (car args))) + cfg-path format severity entropy verbose local-ref remote-ref)]))) + +;; --- Entry point --- + +(let* ([args (cdr (command-line))] + [parsed (parse-args args)] + [mode (list-ref parsed 0)] + [paths (list-ref parsed 1)] + [cfg-path (list-ref parsed 2)] + [format (list-ref parsed 3)] + [severity (list-ref parsed 4)] + [entropy (list-ref parsed 5)] + [verbose (list-ref parsed 6)] + [local-ref (list-ref parsed 7)] + [remote-ref (list-ref parsed 8)] + [config (let ([c (load-config cfg-path)]) + (make-gitsafe-config + (if severity + (match severity + ["low" 'low] + ["medium" 'medium] + ["high" 'high] + ["critical" 'critical] + [_ (gitsafe-config-severity c)]) + (gitsafe-config-severity c)) + (if entropy + (gitsafe-config-entropy-enabled c) + #f) + (gitsafe-config-disabled-patterns c) + (gitsafe-config-custom-patterns c) + (gitsafe-config-exclude-globs c) + (gitsafe-config-allowlist-files c) + (gitsafe-config-allowlist-strings c)))]) + (match mode + ["install" (cmd-install)] + ["uninstall" (cmd-uninstall)] + ["pre-commit" (cmd-pre-commit config format verbose)] + ["pre-push" + (let ([lr (or local-ref "HEAD")] + [rr (or remote-ref "origin/HEAD")]) + (cmd-pre-push lr rr config format verbose))] + ["scan" + (cmd-scan paths config format verbose)] + [_ + (displayln "gitsafe: unknown mode: " mode) + (exit 2)])) new file mode 100644 --- /dev/null +++ b/gitsafe/main.ss @@ -0,0 +1,255 @@ +#!chezscheme +;;; gitsafe/main -- Interpreter entry point (dev/install mode) +;;; Sets up library-directories before any gitsafe imports. + +(import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time)) + +;; --- Library path setup --- +(define home (or (getenv "HOME") "."))