Extract Semgrep finding builder helpers
ober
97af96e6222d70d984daf475541cc5c11847d98c
--- a/SEMGREP_JERBOA_IMPLEMENTATION.md +++ b/SEMGREP_JERBOA_IMPLEMENTATION.md @@ -461,6 +461,8 @@ Completed in the repo: `src/semgrep/result/findings.ss` - extracted regex pattern rewriting and regex capture binding helpers into `src/semgrep/engine/regex-support.ss` + - extracted node/binding finding builders and semicolon range shaping into + `src/semgrep/result/builders.ss` Validation at this checkpoint: new file mode 100644 --- /dev/null +++ b/lib/semgrep/result/builders.sls @@ -0,0 +1,134 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/result/builders.ss + +(library (semgrep result builders) + (export + finding-from-node + finding-from-binding + maybe-extend-expression-semicolon + maybe-trim-dart-statement-semicolon) + (import + (except (chezscheme) make-hash-table hash-table? sort sort! + printf fprintf format path-extension path-absolute? + with-input-from-string with-output-to-string iota \x31;+ + \x31;- partition make-date make-time meta atom?) + (except (jerboa prelude) meta atom?) + (tree-sitter tree-sitter) (semgrep rule) (semgrep result) + (semgrep result findings) (semgrep source offsets) + (semgrep match structural)) + (def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + (def (sg-string-suffix? suffix s) + (let ([suffix-len (string-length suffix)] + [len (string-length s)]) + (and (<= suffix-len len) + (string=? (substring s (- len suffix-len) len) suffix)))) + (def (template-content-binding node extra) + (and (string=? (node-type node) "template_string") + (let ([bindings (alist-ref/default extra 'metavars '())] + [content-start (+ (node-start-byte node) 1)] + [content-end (- (node-end-byte node) 1)]) + (let loop ([xs bindings]) + (and (not (null? xs)) + (let ([binding (cdar xs)]) + (if (and (= (metavariable-binding-start-byte + binding) + content-start) + (= (metavariable-binding-end-byte binding) + content-end)) + binding + (loop (cdr xs))))))))) + (def (template-finding-end-byte node extra) + (let ([content-binding (template-content-binding + node + extra)]) + (cond + [content-binding + (metavariable-binding-end-byte content-binding)] + [(and (string=? (node-type node) "template_string") + (> (node-end-byte node) (node-start-byte node))) + (- (node-end-byte node) 1)] + [else (node-end-byte node)]))) + (def (semicolon-trimmable-node? node) + (or (string=? (node-type node) "variable_declaration") + (string=? (node-type node) "lexical_declaration") + (string=? (node-type node) "import_statement") + (string=? (node-type node) "return_statement"))) + (def (trim-node-finding-end source node start end) + (if (and (semicolon-trimmable-node? node) + (> end start) + (char=? (string-ref source (- end 1)) #\;)) + (- end 1) + end)) + (def (finding-from-node rule path source node extra message) + (let* ([raw-start (node-start-byte node)] + [start-index (tree-byte-offset->source-index + source + raw-start)] + [start (source-index->semgrep-offset source start-index)] + [raw-end-byte (template-finding-end-byte node extra)] + [raw-end-index (tree-byte-offset->source-index + source + raw-end-byte)] + [end-index (trim-node-finding-end + source + node + start-index + raw-end-index)] + [end (source-index->semgrep-offset source end-index)]) + (let-values ([(start-line start-col) + (offset->line-col source start-index)] + [(end-line end-col) + (offset->line-col source end-index)]) + (make-finding (rule-id rule) path start-line start-col + end-line end-col start end message (rule-severity rule) + extra)))) + (def (finding-from-binding rule path binding extra message) + (make-finding (rule-id rule) path + (metavariable-binding-start-line binding) + (metavariable-binding-start-col binding) + (metavariable-binding-end-line binding) + (metavariable-binding-end-col binding) + (metavariable-binding-start-byte binding) + (metavariable-binding-end-byte binding) message + (rule-severity rule) extra)) + (def (pattern-trailing-semicolon? pattern) + (sg-string-suffix? ";" (string-trim pattern))) + (def (extend-finding-over-semicolon rule finding source) + (let ([end (finding-end-offset finding)]) + (if (and (< end (string-length source)) + (char=? (string-ref source end) #\;)) + (let* ([new-end (+ end 1)] + [message (finding-message finding)] + [extra (finding-extra finding)]) + (let-values ([(end-line end-col) + (offset->line-col source new-end)]) + (make-finding (rule-id rule) (finding-path finding) + (finding-start-line finding) (finding-start-col finding) + end-line end-col (finding-start-offset finding) new-end + message (finding-severity finding) extra))) + finding))) + (def (maybe-extend-expression-semicolon rule pattern source + node finding) + (if (and (pattern-trailing-semicolon? pattern) + (not (semicolon-trimmable-node? node))) + (extend-finding-over-semicolon rule finding source) + finding)) + (def (maybe-trim-dart-statement-semicolon language pattern + source node finding) + (if (and (string=? language "dart") + (not (pattern-trailing-semicolon? pattern)) + (string=? (node-type node) "expression_statement") + (let ([t (node-text node)]) + (and (> (string-length t) 0) + (char=? + (string-ref t (- (string-length t) 1)) + #\;)))) + (finding-with-range + finding + source + (finding-start-offset finding) + (- (finding-end-offset finding) 1)) + finding))) --- a/lib/semgrep/scan.sls +++ b/lib/semgrep/scan.sls @@ -15,11 +15,11 @@ \x31;- partition make-date make-time meta atom?) (except (jerboa prelude) meta atom?) (std regex) (tree-sitter tree-sitter) (semgrep lang) (semgrep rule) - (semgrep result) (semgrep result findings) - (semgrep engine rule-plan) (semgrep engine regex-support) - (semgrep rule parse-rule) (semgrep parse parse-target) - (semgrep source offsets) (semgrep targeting path-filter) - (semgrep match structural)) + (semgrep result) (semgrep result builders) + (semgrep result findings) (semgrep engine rule-plan) + (semgrep engine regex-support) (semgrep rule parse-rule) + (semgrep parse parse-target) (semgrep source offsets) + (semgrep targeting path-filter) (semgrep match structural)) (def (alist-ref/default xs key default) (let ([found (assoc key xs)]) (if found (cdr found) default))) @@ -88,113 +88,6 @@ (make-finding (rule-id rule) path 1 1 end-line end-col 0 end (rule-message rule) (rule-severity rule) (finding-extra-for-match rule '() source))))) - (def (template-content-binding node extra) - (and (string=? (node-type node) "template_string") - (let ([bindings (alist-ref/default extra 'metavars '())] - [content-start (+ (node-start-byte node) 1)] - [content-end (- (node-end-byte node) 1)]) - (let loop ([xs bindings]) - (and (not (null? xs)) - (let ([binding (cdar xs)]) - (if (and (= (metavariable-binding-start-byte - binding) - content-start) - (= (metavariable-binding-end-byte binding) - content-end)) - binding - (loop (cdr xs))))))))) - (def (template-finding-end-byte node extra) - (let ([content-binding (template-content-binding - node - extra)]) - (cond - [content-binding - (metavariable-binding-end-byte content-binding)] - [(and (string=? (node-type node) "template_string") - (> (node-end-byte node) (node-start-byte node))) - (- (node-end-byte node) 1)] - [else (node-end-byte node)]))) - (def (semicolon-trimmable-node? node) - (or (string=? (node-type node) "variable_declaration") - (string=? (node-type node) "lexical_declaration") - (string=? (node-type node) "import_statement") - (string=? (node-type node) "return_statement"))) - (def (trim-node-finding-end source node start end) - (if (and (semicolon-trimmable-node? node) - (> end start) - (char=? (string-ref source (- end 1)) #\;)) - (- end 1) - end)) - (def (finding-from-node rule path source node extra message) - (let* ([raw-start (node-start-byte node)] - [start-index (tree-byte-offset->source-index - source - raw-start)] - [start (source-index->semgrep-offset source start-index)] - [raw-end-byte (template-finding-end-byte node extra)] - [raw-end-index (tree-byte-offset->source-index - source - raw-end-byte)] - [end-index (trim-node-finding-end - source - node - start-index - raw-end-index)] - [end (source-index->semgrep-offset source end-index)]) - (let-values ([(start-line start-col) - (offset->line-col source start-index)] - [(end-line end-col) - (offset->line-col source end-index)]) - (make-finding (rule-id rule) path start-line start-col - end-line end-col start end message (rule-severity rule) - extra)))) - (def (finding-from-binding rule path binding extra message) - (make-finding (rule-id rule) path - (metavariable-binding-start-line binding) - (metavariable-binding-start-col binding) - (metavariable-binding-end-line binding) - (metavariable-binding-end-col binding) - (metavariable-binding-start-byte binding) - (metavariable-binding-end-byte binding) message - (rule-severity rule) extra)) - (def (pattern-trailing-semicolon? pattern) - (sg-string-suffix? ";" (string-trim pattern))) - (def (extend-finding-over-semicolon rule finding source) - (let ([end (finding-end-offset finding)]) - (if (and (< end (string-length source)) - (char=? (string-ref source end) #\;)) - (let* ([new-end (+ end 1)] - [message (finding-message finding)] - [extra (finding-extra finding)]) - (let-values ([(end-line end-col) - (offset->line-col source new-end)]) - (make-finding (rule-id rule) (finding-path finding) - (finding-start-line finding) (finding-start-col finding) - end-line end-col (finding-start-offset finding) new-end - message (finding-severity finding) extra))) - finding))) - (def (maybe-extend-expression-semicolon rule pattern source - node finding) - (if (and (pattern-trailing-semicolon? pattern) - (not (semicolon-trimmable-node? node))) - (extend-finding-over-semicolon rule finding source) - finding)) - (def (maybe-trim-dart-statement-semicolon language pattern - source node finding) - (if (and (string=? language "dart") - (not (pattern-trailing-semicolon? pattern)) - (string=? (node-type node) "expression_statement") - (let ([t (node-text node)]) - (and (> (string-length t) 0) - (char=? - (string-ref t (- (string-length t) 1)) - #\;)))) - (finding-with-range - finding - source - (finding-start-offset finding) - (- (finding-end-offset finding) 1)) - finding)) (def (base-finding-extra rule) (if (null? (rule-metadata rule)) '() --- a/src/.jerbuild-hashes +++ b/src/.jerbuild-hashes @@ -8,11 +8,12 @@ ("src/semgrep/output/json.ss" . "293881CFA2ADB7BC") ("src/semgrep/lang.ss" . "6982E07679D20836") ("src/semgrep/parse/parse-target.ss" . "97AA8FFEB12736DA") - ("src/semgrep/scan.ss" . "54C4A1386DE353B4") + ("src/semgrep/scan.ss" . "F056CECD5465287C") ("src/semgrep/rule.ss" . "E12C108153C181FA") ("src/semgrep/schema/lang.ss" . "CAE2CA859C9A9FD0") ("src/semgrep/output/text.ss" . "BE476CB84B807FBA") ("src/semgrep/source/offsets.ss" . "834EFDB706823794") ("src/semgrep/engine/regex-support.ss" . "9FCF118903259C97") ("src/semgrep/main.ss" . "A4EC9E7F2A09D25E") + ("src/semgrep/result/builders.ss" . "93A64AF4435E6132") ("src/semgrep/cli.ss" . "EBDC4B1DAD3F13CC")) new file mode 100644 --- /dev/null +++ b/src/semgrep/result/builders.ss @@ -0,0 +1,146 @@ +(export + finding-from-node + finding-from-binding + maybe-extend-expression-semicolon + maybe-trim-dart-statement-semicolon) + +(import (except (jerboa prelude) meta atom?) + (tree-sitter tree-sitter) + (semgrep rule) + (semgrep result) + (semgrep result findings) + (semgrep source offsets) + (semgrep match structural)) + +(def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + +(def (sg-string-suffix? suffix s) + (let ([suffix-len (string-length suffix)] + [len (string-length s)]) + (and (<= suffix-len len) + (string=? (substring s (- len suffix-len) len) suffix)))) + +(def (template-content-binding node extra) + (and (string=? (node-type node) "template_string") + (let ([bindings (alist-ref/default extra 'metavars '())] + [content-start (+ (node-start-byte node) 1)] + [content-end (- (node-end-byte node) 1)]) + (let loop ([xs bindings]) + (and (not (null? xs)) + (let ([binding (cdar xs)]) + (if (and (= (metavariable-binding-start-byte binding) + content-start) + (= (metavariable-binding-end-byte binding) + content-end)) + binding + (loop (cdr xs))))))))) + +(def (template-finding-end-byte node extra) + (let ([content-binding (template-content-binding node extra)]) + (cond + [content-binding (metavariable-binding-end-byte content-binding)] + [(and (string=? (node-type node) "template_string") + (> (node-end-byte node) (node-start-byte node))) + (- (node-end-byte node) 1)] + [else (node-end-byte node)]))) + +(def (semicolon-trimmable-node? node) + (or (string=? (node-type node) "variable_declaration") + (string=? (node-type node) "lexical_declaration") + (string=? (node-type node) "import_statement") + (string=? (node-type node) "return_statement"))) + +(def (trim-node-finding-end source node start end) + (if (and (semicolon-trimmable-node? node) + (> end start) + (char=? (string-ref source (- end 1)) #\;)) + (- end 1) + end)) + +(def (finding-from-node rule path source node extra message) + (let* ([raw-start (node-start-byte node)] + [start-index (tree-byte-offset->source-index source raw-start)] + [start (source-index->semgrep-offset source start-index)] + [raw-end-byte (template-finding-end-byte node extra)] + [raw-end-index (tree-byte-offset->source-index source raw-end-byte)] + [end-index (trim-node-finding-end source node start-index raw-end-index)] + [end (source-index->semgrep-offset source end-index)]) + (let-values ([(start-line start-col) (offset->line-col source start-index)] + [(end-line end-col) (offset->line-col source end-index)]) + (make-finding + (rule-id rule) + path + start-line + start-col + end-line + end-col + start + end + message + (rule-severity rule) + extra)))) + +(def (finding-from-binding rule path binding extra message) + (make-finding + (rule-id rule) + path + (metavariable-binding-start-line binding) + (metavariable-binding-start-col binding) + (metavariable-binding-end-line binding) + (metavariable-binding-end-col binding) + (metavariable-binding-start-byte binding) + (metavariable-binding-end-byte binding) + message + (rule-severity rule) + extra)) + +(def (pattern-trailing-semicolon? pattern) + (sg-string-suffix? ";" (string-trim pattern))) + +(def (extend-finding-over-semicolon rule finding source) + (let ([end (finding-end-offset finding)]) + (if (and (< end (string-length source)) + (char=? (string-ref source end) #\;)) + (let* ([new-end (+ end 1)] + [message (finding-message finding)] + [extra (finding-extra finding)]) + (let-values ([(end-line end-col) (offset->line-col source new-end)]) + (make-finding + (rule-id rule) + (finding-path finding) + (finding-start-line finding) + (finding-start-col finding) + end-line + end-col + (finding-start-offset finding) + new-end + message + (finding-severity finding) + extra))) + finding))) + +(def (maybe-extend-expression-semicolon rule pattern source node finding) + (if (and (pattern-trailing-semicolon? pattern) + (not (semicolon-trimmable-node? node))) + (extend-finding-over-semicolon rule finding source) + finding)) + +;; Dart has no wrapping expression node for a call (`print(x)` is an identifier +;; plus a selector under expression_statement), so an expression pattern like +;; `print($X)` extracts/matches the whole statement, including its `;`. When the +;; pattern itself has no trailing `;`, trim that statement terminator so the +;; finding range matches Semgrep's expression span. +(def (maybe-trim-dart-statement-semicolon language pattern source node finding) + (if (and (string=? language "dart") + (not (pattern-trailing-semicolon? pattern)) + (string=? (node-type node) "expression_statement") + (let ([t (node-text node)]) + (and (> (string-length t) 0) + (char=? (string-ref t (- (string-length t) 1)) #\;)))) + (finding-with-range finding + source + (finding-start-offset finding) + (- (finding-end-offset finding) 1)) + finding)) --- a/src/semgrep/scan.ss +++ b/src/semgrep/scan.ss @@ -10,6 +10,7 @@ (semgrep lang) (semgrep rule) (semgrep result) + (semgrep result builders) (semgrep result findings) (semgrep engine rule-plan) (semgrep engine regex-support) @@ -115,130 +116,6 @@ (rule-severity rule) (finding-extra-for-match rule '() source))))) - -(def (template-content-binding node extra) - (and (string=? (node-type node) "template_string") - (let ([bindings (alist-ref/default extra 'metavars '())] - [content-start (+ (node-start-byte node) 1)] - [content-end (- (node-end-byte node) 1)]) - (let loop ([xs bindings]) - (and (not (null? xs)) - (let ([binding (cdar xs)]) - (if (and (= (metavariable-binding-start-byte binding) - content-start) - (= (metavariable-binding-end-byte binding) - content-end)) - binding - (loop (cdr xs))))))))) - -(def (template-finding-end-byte node extra) - (let ([content-binding (template-content-binding node extra)]) - (cond - [content-binding (metavariable-binding-end-byte content-binding)] - [(and (string=? (node-type node) "template_string") - (> (node-end-byte node) (node-start-byte node))) - (- (node-end-byte node) 1)] - [else (node-end-byte node)]))) - -(def (semicolon-trimmable-node? node) - (or (string=? (node-type node) "variable_declaration") - (string=? (node-type node) "lexical_declaration") - (string=? (node-type node) "import_statement") - (string=? (node-type node) "return_statement"))) - -(def (trim-node-finding-end source node start end) - (if (and (semicolon-trimmable-node? node) - (> end start) - (char=? (string-ref source (- end 1)) #\;)) - (- end 1) - end)) - -(def (finding-from-node rule path source node extra message) - (let* ([raw-start (node-start-byte node)] - [start-index (tree-byte-offset->source-index source raw-start)] - [start (source-index->semgrep-offset source start-index)] - [raw-end-byte (template-finding-end-byte node extra)] - [raw-end-index (tree-byte-offset->source-index source raw-end-byte)] - [end-index (trim-node-finding-end source node start-index raw-end-index)] - [end (source-index->semgrep-offset source end-index)]) - (let-values ([(start-line start-col) (offset->line-col source start-index)] - [(end-line end-col) (offset->line-col source end-index)]) - (make-finding - (rule-id rule) - path - start-line - start-col - end-line - end-col - start - end - message - (rule-severity rule) - extra)))) - -(def (finding-from-binding rule path binding extra message) - (make-finding - (rule-id rule) - path - (metavariable-binding-start-line binding) - (metavariable-binding-start-col binding) - (metavariable-binding-end-line binding) - (metavariable-binding-end-col binding) - (metavariable-binding-start-byte binding) - (metavariable-binding-end-byte binding) - message - (rule-severity rule) - extra)) - -(def (pattern-trailing-semicolon? pattern) - (sg-string-suffix? ";" (string-trim pattern))) - -(def (extend-finding-over-semicolon rule finding source) - (let ([end (finding-end-offset finding)]) - (if (and (< end (string-length source)) - (char=? (string-ref source end) #\;)) - (let* ([new-end (+ end 1)] - [message (finding-message finding)] - [extra (finding-extra finding)]) - (let-values ([(end-line end-col) (offset->line-col source new-end)]) - (make-finding - (rule-id rule) - (finding-path finding) - (finding-start-line finding) - (finding-start-col finding) - end-line - end-col - (finding-start-offset finding) - new-end - message - (finding-severity finding) - extra))) - finding))) - -(def (maybe-extend-expression-semicolon rule pattern source node finding) - (if (and (pattern-trailing-semicolon? pattern) - (not (semicolon-trimmable-node? node))) - (extend-finding-over-semicolon rule finding source) - finding)) - -;; Dart has no wrapping expression node for a call (`print(x)` is an identifier -;; plus a selector under expression_statement), so an expression pattern like -;; `print($X)` extracts/matches the whole statement, including its `;`. When the -;; pattern itself has no trailing `;`, trim that statement terminator so the -;; finding range matches Semgrep's expression span. -(def (maybe-trim-dart-statement-semicolon language pattern source node finding) - (if (and (string=? language "dart") - (not (pattern-trailing-semicolon? pattern)) - (string=? (node-type node) "expression_statement") - (let ([t (node-text node)]) - (and (> (string-length t) 0) - (char=? (string-ref t (- (string-length t) 1)) #\;)))) - (finding-with-range finding - source - (finding-start-offset finding) - (- (finding-end-offset finding) 1)) - finding)) - (def (base-finding-extra rule) (if (null? (rule-metadata rule)) '()