refactor: extract shared CLI logic from main.ss/main-binary.ss into common module
ober
2e0523839c4c4b1c9605f5ec023e074d45608595
--- a/build-binary.ss +++ b/build-binary.ss @@ -179,7 +179,8 @@ "gitsafe/patterns" "gitsafe/git" "gitsafe/scanner" - "gitsafe/output")) + "gitsafe/output" + "gitsafe/cli-common")) ;; Bundle both gitsafe modules and any stdlib .so files the WPO couldn't inline. ;; This makes gitsafe-bin self-contained without requiring Chez library paths at runtime. --- a/build-common.ss +++ b/build-common.ss @@ -92,7 +92,8 @@ "gitsafe/source" "gitsafe/decoder" "gitsafe/scanner" - "gitsafe/output")) + "gitsafe/output" + "gitsafe/cli-common")) ;; --- Step 0: add library search paths --- (define (setup-library-dirs!) new file mode 100644 --- /dev/null +++ b/gitsafe/cli-common.ss @@ -0,0 +1,328 @@ +#!chezscheme +;;; gitsafe/cli-common -- Shared CLI logic for both entry points. +;;; Imported by gitsafe/main.ss (interpreter) and gitsafe/main-binary.ss +;;; (compiled static binary). Entry-point-specific bootstrap (library path +;;; setup) stays in each entry script; everything else lives here. + +(library (gitsafe cli-common) + (export *gitsafe-version* + write-hook-file! + delete-hook-file! + install-hook! + make-executable! + cmd-install + cmd-uninstall + run-scan + cmd-pre-commit + cmd-pre-push + cmd-scan + cmd-stdin + parse-args + parse-decode-depth + cli-main) + (import (except (scheme) + 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) + (except (jerboa prelude) meta atom?) + (std misc process) + (std misc ports) + (only (std security taint) check-untainted! safe-delete-file) + (gitsafe config) + (gitsafe scanner) + (gitsafe git) + (gitsafe output)) + + ;; --- Version --- + (def *gitsafe-version* "0.1.0") + + ;; --- Checked file sinks --- + + (def (write-hook-file! path content) + (check-untainted! path 'write-hook-file!) + (write-file-string path content)) + + (def (delete-hook-file! path) + (check-untainted! path 'delete-hook-file!) + (safe-delete-file path)) + + ;; --- Hook installation --- + + (def (install-hook! hook-path content) + (if (file-exists? hook-path) + (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)) + (begin + (displayln " Warning: " hook-path " already exists and wasn't installed by gitsafe.") + (displayln " Append manually or back it up first.")))) + (begin + (write-hook-file! hook-path content) + (displayln " Created: " hook-path)))) + + (def (make-executable! path) + (check-untainted! path 'make-executable!) + (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")]) + (when (not (file-exists? hooks-dir)) + (mkdir hooks-dir)) + (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_sha\" --remote-ref \"$remote_sha\" || 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-hook-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.")))) + + ;; --- Main scanning dispatch --- + + (def (run-scan findings format verbose? (scanned-files #f)) + (if (null? findings) + (begin + (when (or verbose? (not (string=? format "text"))) + (display-findings findings format verbose? scanned-files)) + (display-summary findings scanned-files) + (exit 0)) + (begin + (display-findings findings format verbose? scanned-files) + (display-summary findings scanned-files) + (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)) + (call-with-values + (lambda () (scan-files-with-count paths config)) + (lambda (findings scanned-files) + (run-scan findings format verbose? scanned-files))))) + + (def (cmd-stdin config format verbose?) + (run-scan + (scan-content "<stdin>" (get-string-all (current-input-port)) config) + format + verbose? + 1)) + + ;; --- Argument parsing --- + + (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] + [decode-depth #f] + [baseline-path #f]) + (cond + [(null? args) + (list mode paths cfg-path format severity entropy verbose local-ref remote-ref + decode-depth baseline-path)] + + [(member (car args) '("pre-commit" "pre-push" "scan" "stdin" "install" "uninstall")) + (loop (cdr args) (car args) paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path)] + + [(string=? (car args) "--config") + (if (pair? (cdr args)) + (loop (cddr args) mode paths (cadr args) format severity entropy verbose local-ref remote-ref decode-depth baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--format") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path (cadr args) severity entropy verbose local-ref remote-ref decode-depth baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--severity") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format (cadr args) entropy verbose local-ref remote-ref decode-depth baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--no-entropy") + (loop (cdr args) mode paths cfg-path format severity #f verbose local-ref remote-ref decode-depth baseline-path)] + + [(string=? (car args) "--verbose") + (loop (cdr args) mode paths cfg-path format severity entropy #t local-ref remote-ref decode-depth baseline-path)] + + [(string=? (car args) "--local-ref") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose (cadr args) remote-ref decode-depth baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--remote-ref") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref (cadr args) decode-depth baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--max-decode-depth") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref (cadr args) baseline-path) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(string=? (car args) "--baseline") + (if (pair? (cdr args)) + (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth (cadr args)) + (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] + + [(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 + stdin Scan content from stdin + install Install git hooks in .git/hooks/ + uninstall Remove git hooks + + Options: + --config PATH Path to .gitsafe.json (default: .gitsafe.json) + --format text|json|sarif + Output format (default: text) + --severity LEVEL Minimum severity: low|medium|high|critical (default: medium) + --no-entropy Disable entropy analysis + --max-decode-depth N + Recursively scan decoded percent/unicode/hex/base64 text + --baseline PATH Suppress findings from a previous JSON or SARIF report + --verbose Show scan statistics + --version Print version + --help Print this help + ") + (exit 0)] + + ;; Positional args go to paths (for scan mode) + [else + (loop (cdr args) mode (append paths (list (car args))) + cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path)]))) + + (def (parse-decode-depth s default) + (let ([n (and s (string->number s))]) + (if (and n (integer? n) (>= n 0)) + n + default))) + + ;; --- Entry point --- + + (def (cli-main) + (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)] + [decode-depth (list-ref parsed 9)] + [baseline-path (list-ref parsed 10)] + [config (let ([c (load-config cfg-path)]) + ;; Override config fields from CLI flags + (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) + (gitsafe-config-max-file-size-mb c) + (gitsafe-config-ml-data-detection c) + (parse-decode-depth decode-depth + (gitsafe-config-max-decode-depth c)) + (unique + (append + (gitsafe-config-baseline-fingerprints c) + (if baseline-path + (load-baseline-fingerprints baseline-path) + '())))))]) + (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)] + ["stdin" + (cmd-stdin config format verbose)] + [_ + (displayln "gitsafe: unknown mode: " mode) + (exit 2)])))) --- a/gitsafe/main-binary.ss +++ b/gitsafe/main-binary.ss @@ -1,299 +1,9 @@ #!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. +;;; In binary mode all libraries are already compiled in via boot files, so +;;; no library-directories setup is needed. All real logic lives in +;;; (gitsafe cli-common); this file just invokes it. -(import (except (scheme) - 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) - (except (jerboa prelude) meta atom?) - (std misc process) - (std misc ports) - (only (std security taint) check-untainted! safe-delete-file) - (gitsafe config) - (gitsafe scanner) - (gitsafe git) - (gitsafe output)) +(import (gitsafe cli-common)) -;; --- Version --- -(def *gitsafe-version* "0.1.0") - -;; --- Checked file sinks --- - -(def (write-hook-file! path content) - (check-untainted! path 'write-hook-file!) - (write-file-string path content)) - -(def (delete-hook-file! path) - (check-untainted! path 'delete-hook-file!) - (safe-delete-file path)) - -;; --- 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-hook-file! 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-hook-file! hook-path content) - (displayln " Created: " hook-path)))) - -(def (make-executable! path) - (check-untainted! path 'make-executable!) - (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")]) - (when (not (file-exists? hooks-dir)) - (mkdir hooks-dir)) - (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_sha\" --remote-ref \"$remote_sha\" || 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-hook-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? (scanned-files #f)) - (if (null? findings) - (begin - (when (or verbose? (not (string=? format "text"))) - (display-findings findings format verbose? scanned-files)) - (display-summary findings scanned-files) - (exit 0)) - (begin - (display-findings findings format verbose? scanned-files) - (display-summary findings scanned-files) - (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)) - (call-with-values - (lambda () (scan-files-with-count paths config)) - (lambda (findings scanned-files) - (run-scan findings format verbose? scanned-files))))) - -(def (cmd-stdin config format verbose?) - (run-scan - (scan-content "<stdin>" (get-string-all (current-input-port)) config) - format - verbose? - 1)) - -;; --- 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] - [decode-depth #f] - [baseline-path #f]) - (cond - [(null? args) - (list mode paths cfg-path format severity entropy verbose local-ref remote-ref - decode-depth baseline-path)] - - [(member (car args) '("pre-commit" "pre-push" "scan" "stdin" "install" "uninstall")) - (loop (cdr args) (car args) paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--config") - (if (pair? (cdr args)) - (loop (cddr args) mode paths (cadr args) format severity entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--format") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path (cadr args) severity entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--severity") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format (cadr args) entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--no-entropy") - (loop (cdr args) mode paths cfg-path format severity #f verbose local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--verbose") - (loop (cdr args) mode paths cfg-path format severity entropy #t local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--local-ref") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose (cadr args) remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--remote-ref") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref (cadr args) decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--max-decode-depth") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref (cadr args) baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--baseline") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth (cadr args)) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(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 - stdin Scan content from stdin - install Install git hooks in .git/hooks/ - uninstall Remove git hooks - -Options: - --config PATH Path to .gitsafe.json (default: .gitsafe.json) - --format text|json|sarif - Output format (default: text) - --severity LEVEL Minimum severity: low|medium|high|critical (default: medium) - --no-entropy Disable entropy analysis - --max-decode-depth N - Recursively scan decoded percent/unicode/hex/base64 text - --baseline PATH Suppress findings from a previous JSON or SARIF report - --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 decode-depth baseline-path)]))) - -(def (parse-decode-depth s default) - (let ([n (and s (string->number s))]) - (if (and n (integer? n) (>= n 0)) - n - default))) - -;; --- 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)] - [decode-depth (list-ref parsed 9)] - [baseline-path (list-ref parsed 10)] - [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) - (gitsafe-config-max-file-size-mb c) - (gitsafe-config-ml-data-detection c) - (parse-decode-depth decode-depth - (gitsafe-config-max-decode-depth c)) - (unique - (append - (gitsafe-config-baseline-fingerprints c) - (if baseline-path - (load-baseline-fingerprints baseline-path) - '())))))]) - (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)] - ["stdin" - (cmd-stdin config format verbose)] - [_ - (displayln "gitsafe: unknown mode: " mode) - (exit 2)])) +(cli-main) --- a/gitsafe/main.ss +++ b/gitsafe/main.ss @@ -1,16 +1,10 @@ #!chezscheme ;;; gitsafe/main -- Interpreter entry point (dev/install mode) -;;; Sets up library-directories before any gitsafe imports. +;;; Sets up library-directories before importing the shared CLI module. +;;; All real logic lives in (gitsafe cli-common); this file only bootstraps +;;; the library search path needed in interpreter mode. -(import (except (scheme) - 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)) +(import (scheme)) ;; --- Library path setup --- (define home (or (getenv "HOME") ".")) @@ -29,300 +23,7 @@ (string-append jerboa-dir "/lib"))) (library-directories))) -;; --- Now we can import gitsafe modules --- - (import (except (jerboa prelude) meta atom?) - (std misc process) - (std misc ports) - (only (std security taint) check-untainted! safe-delete-file) - (gitsafe config) - (gitsafe scanner) - (gitsafe git) - (gitsafe output)) +;; --- Now we can import the shared CLI module and run --- +(import (gitsafe cli-common)) -;; --- Version --- -(def *gitsafe-version* "0.1.0") - -;; --- Checked file sinks --- - -(def (write-hook-file! path content) - (check-untainted! path 'write-hook-file!) - (write-file-string path content)) - -(def (delete-hook-file! path) - (check-untainted! path 'delete-hook-file!) - (safe-delete-file path)) - -;; --- Hook installation --- - -(def (install-hook! hook-path content) - (if (file-exists? hook-path) - (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)) - (begin - (displayln " Warning: " hook-path " already exists and wasn't installed by gitsafe.") - (displayln " Append manually or back it up first.")))) - (begin - (write-hook-file! hook-path content) - (displayln " Created: " hook-path)))) - -(def (make-executable! path) - (check-untainted! path 'make-executable!) - (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")]) - (when (not (file-exists? hooks-dir)) - (mkdir hooks-dir)) - (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_sha\" --remote-ref \"$remote_sha\" || 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-hook-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.")))) - -;; --- Main scanning dispatch --- - -(def (run-scan findings format verbose? (scanned-files #f)) - (if (null? findings) - (begin - (when (or verbose? (not (string=? format "text"))) - (display-findings findings format verbose? scanned-files)) - (display-summary findings scanned-files) - (exit 0)) - (begin - (display-findings findings format verbose? scanned-files) - (display-summary findings scanned-files) - (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)) - (call-with-values - (lambda () (scan-files-with-count paths config)) - (lambda (findings scanned-files) - (run-scan findings format verbose? scanned-files))))) - -(def (cmd-stdin config format verbose?) - (run-scan - (scan-content "<stdin>" (get-string-all (current-input-port)) config) - format - verbose? - 1)) - -;; --- Argument parsing --- - -(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] - [decode-depth #f] - [baseline-path #f]) - (cond - [(null? args) - (list mode paths cfg-path format severity entropy verbose local-ref remote-ref - decode-depth baseline-path)] - - [(member (car args) '("pre-commit" "pre-push" "scan" "stdin" "install" "uninstall")) - (loop (cdr args) (car args) paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--config") - (if (pair? (cdr args)) - (loop (cddr args) mode paths (cadr args) format severity entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--format") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path (cadr args) severity entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--severity") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format (cadr args) entropy verbose local-ref remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--no-entropy") - (loop (cdr args) mode paths cfg-path format severity #f verbose local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--verbose") - (loop (cdr args) mode paths cfg-path format severity entropy #t local-ref remote-ref decode-depth baseline-path)] - - [(string=? (car args) "--local-ref") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose (cadr args) remote-ref decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--remote-ref") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref (cadr args) decode-depth baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--max-decode-depth") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref (cadr args) baseline-path) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(string=? (car args) "--baseline") - (if (pair? (cdr args)) - (loop (cddr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth (cadr args)) - (loop (cdr args) mode paths cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path))] - - [(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 - stdin Scan content from stdin - install Install git hooks in .git/hooks/ - uninstall Remove git hooks - -Options: - --config PATH Path to .gitsafe.json (default: .gitsafe.json) - --format text|json|sarif - Output format (default: text) - --severity LEVEL Minimum severity: low|medium|high|critical (default: medium) - --no-entropy Disable entropy analysis - --max-decode-depth N - Recursively scan decoded percent/unicode/hex/base64 text - --baseline PATH Suppress findings from a previous JSON or SARIF report - --verbose Show scan statistics - --version Print version - --help Print this help -") - (exit 0)] - - ;; Positional args go to paths (for scan mode) - [else - (loop (cdr args) mode (append paths (list (car args))) - cfg-path format severity entropy verbose local-ref remote-ref decode-depth baseline-path)]))) - -(def (parse-decode-depth s default) - (let ([n (and s (string->number s))]) - (if (and n (integer? n) (>= n 0)) - n - default))) - -;; --- 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)] - [decode-depth (list-ref parsed 9)] - [baseline-path (list-ref parsed 10)] - [config (let ([c (load-config cfg-path)]) - ;; Override config fields from CLI flags - (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) - (gitsafe-config-max-file-size-mb c) - (gitsafe-config-ml-data-detection c) - (parse-decode-depth decode-depth - (gitsafe-config-max-decode-depth c)) - (unique - (append - (gitsafe-config-baseline-fingerprints c) - (if baseline-path - (load-baseline-fingerprints baseline-path) - '())))))]) - (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)] - ["stdin" - (cmd-stdin config format verbose)] - [_ - (displayln "gitsafe: unknown mode: " mode) - (exit 2)])) +(cli-main)