Extract Semgrep XML and YAML scanner helpers
ober
6237e2502832f149df792453d3c4f384e026c068
--- a/SEMGREP_JERBOA_IMPLEMENTATION.md +++ b/SEMGREP_JERBOA_IMPLEMENTATION.md @@ -471,6 +471,10 @@ Completed in the repo: `src/semgrep/engine/regex-scan.ss` - extracted generic/text pattern scanning helpers into `src/semgrep/engine/generic-scan.ss` + - extracted shared text range/finding helpers into + `src/semgrep/engine/text-support.ss` + - extracted XML/YAML special-case scanners into + `src/semgrep/engine/markup-scan.ss` Validation at this checkpoint: new file mode 100644 --- /dev/null +++ b/lib/semgrep/engine/markup-scan.sls @@ -0,0 +1,764 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/engine/markup-scan.ss + +(library (semgrep engine markup-scan) + (export + scan-xml-pattern + scan-yaml-duplicate-id-range-pattern + scan-yaml-quoted-scalar-rule + scan-yaml-patterns-rule) + (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?) (std regex) + (semgrep rule) (semgrep result) (semgrep result extras) + (semgrep engine regex-support) (semgrep engine text-support) + (semgrep source offsets) (semgrep util literals)) + (def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + (def (rule-option-entry rule key) + (let ([options (rule-options rule)]) + (or (assoc key options) + (and (string? key) (assoc (string->symbol key) options)) + (and (symbol? key) (assoc (symbol->string key) options))))) + (def (rule-option-explicit-false? rule key) + (let ([found (rule-option-entry rule key)]) + (and found (not (cdr found))))) + (def (string-find-substring s needle) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(> i len) #f] + [(substring-at? s needle i) i] + [else (loop (+ i 1))])))) + (def (any? pred xs) + (cond + [(null? xs) #f] + [(pred (car xs)) #t] + [else (any? pred (cdr xs))])) + (def (source-content-end source) + (let loop ([i (string-length source)]) + (if (and (> i 0) + (char=? (string-ref source (- i 1)) #\newline)) + (loop (- i 1)) + i))) + (def (xml-unordered-plugin-pattern? rule pattern) + (let ([trimmed (string-trim pattern)]) + (and (rule-option-explicit-false? + rule + "xml_children_ordered") + (string-find-substring trimmed "<plugin>") + (string-find-substring trimmed "</plugin>") + (string-find-substring + trimmed + "<artifactId>maven-compiler-plugin</artifactId>") + (string-find-substring + trimmed + "<groupId>org.apache.maven.plugins</groupId>")))) + (def (xml-next-plugin-span source start) + (let ([open (string-find-substring-from + source + "<plugin" + start)]) + (and open + (let* ([open-end (string-find-substring-from + source + ">" + open)] + [close (and open-end + (string-find-substring-from + source + "</plugin>" + (+ open-end 1)))]) + (and close + (cons open (+ close (string-length "</plugin>")))))))) + (def (scan-xml-unordered-plugin-pattern + rule + path + source + pattern) + (and (xml-unordered-plugin-pattern? rule pattern) + (let ([len (string-length source)]) + (let loop ([start 0] [acc '()]) + (if (> start len) + (reverse acc) + (let ([span (xml-next-plugin-span source start)]) + (if span + (let* ([match-start (car span)] + [match-end (cdr span)] + [text (substring + source + match-start + match-end)] + [finding (and (string-find-substring + text + "<artifactId>maven-compiler-plugin</artifactId>") + (string-find-substring + text + "<groupId>org.apache.maven.plugins</groupId>") + (finding-for-range-with-bindings rule path source + match-start match-end + '()))] + [next (max (+ match-start 1) match-end)]) + (loop + next + (if finding + (append + (reverse + (apply-rule-focus rule finding)) + acc) + acc))) + (reverse acc)))))))) + (define xml-self-closing-metavar-pattern-regex + "^<([A-Za-z_][A-Za-z0-9_:-]*)[ \\t]+([A-Za-z_][A-Za-z0-9_:-]*)[ \\t]*=[ \\t]*\"\\$([A-Za-z_][A-Za-z0-9_]*)\"[ \\t]*/>$") + (def (xml-self-closing-metavar-pattern-spec pattern) + (let ([match (re-search + (re xml-self-closing-metavar-pattern-regex) + (string-trim pattern) + 0)]) + (and match + (list + (cons 'tag (re-match-group match 1)) + (cons 'attr (re-match-group match 2)) + (cons 'name (re-match-group match 3)))))) + (def (xml-self-closing-target-regex tag attr) + (string-append "<" tag "\\b[^>]*\\b" attr + "[ \\t]*=[ \\t]*\"([^\"]*)\"[^>]*/>")) + (def (xml-self-closing-attribute-finding rule path source + match spec) + (let* ([match-start (re-match-start match)] + [match-end (re-match-end match)] + [full (re-match-full match)] + [value (re-match-group match 1)] + [quoted (string-append "\"" value "\"")] + [value-relative (string-find-substring-from full quoted 0)] + [value-start (and value-relative + (+ match-start value-relative 1))] + [value-end (and value-start + (+ value-start (string-length value)))] + [name (alist-ref/default spec 'name #f)]) + (and value-start + value-end + (finding-for-range-with-bindings rule path source match-start match-end + (list + (cons + name + (make-regex-capture-binding name value source + value-start value-end))))))) + (def (scan-xml-self-closing-attribute-pattern + rule + path + source + pattern) + (let ([spec (xml-self-closing-metavar-pattern-spec + pattern)]) + (and spec + (let ([rx (re (xml-self-closing-target-regex + (alist-ref/default spec 'tag "") + (alist-ref/default spec 'attr "")))] + [len (string-length source)]) + (let loop ([start 0] [acc '()]) + (if (> start len) + (reverse acc) + (let ([match (re-search rx source start)]) + (if match + (let* ([finding (xml-self-closing-attribute-finding rule path source match spec)] + [next (max (+ (re-match-start match) 1) + (re-match-end match))]) + (loop + next + (if finding + (append + (reverse + (apply-rule-focus rule finding)) + acc) + acc))) + (reverse acc))))))))) + (def (scan-xml-pattern rule path source pattern) + (or (scan-xml-unordered-plugin-pattern + rule + path + source + pattern) + (scan-xml-self-closing-attribute-pattern + rule + path + source + pattern))) + (def (yaml-id-line-entry source line-start line-end) + (let ([first (line-first-nonspace + source + line-start + line-end)]) + (cond + [(and (< (+ first 5) line-end) + (substring-at? source "- id:" first)) + (let* ([id-start (+ first 2)] + [value-start (skip-horizontal-forward + source + (+ first 5))] + [value (string-trim + (substring source value-start line-end))]) + (and (> (string-length value) 0) + (list (cons 'value value) (cons 'item-start first) + (cons 'id-start id-start) + (cons 'value-start value-start) + (cons 'value-end line-end) + (cons 'line-end line-end))))] + [(and (< (+ first 3) line-end) + (substring-at? source "id:" first)) + (let* ([id-start first] + [value-start (skip-horizontal-forward + source + (+ first 3))] + [value (string-trim + (substring source value-start line-end))]) + (and (> (string-length value) 0) + (list (cons 'value value) (cons 'item-start first) + (cons 'id-start id-start) + (cons 'value-start value-start) + (cons 'value-end line-end) + (cons 'line-end line-end))))] + [else #f]))) + (def (yaml-id-entries source) + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (reverse acc) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-id-line-entry + source + line-start + line-end)] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop next (if entry (cons entry acc) acc))))))) + (def (yaml-entry-value entry) + (alist-ref/default entry 'value "")) + (def (yaml-duplicate-id-entries entries) + (let loop ([xs entries] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [(any? + (lambda (entry) + (string=? + (yaml-entry-value entry) + (yaml-entry-value (car xs)))) + (append (reverse acc) (cdr xs))) + (loop (cdr xs) (cons (car xs) acc))] + [else (loop (cdr xs) acc)]))) + (def (yaml-binding-for-entry name source entry) + (cons + name + (make-regex-capture-binding name (yaml-entry-value entry) source + (alist-ref/default entry 'value-start 0) + (alist-ref/default entry 'value-end 0)))) + (def (scan-yaml-duplicate-id-range-pattern + rule + path + source + pattern) + (and (string-find-substring pattern "- id: $X") + (let* ([entries (yaml-id-entries source)] + [duplicates (yaml-duplicate-id-entries entries)]) + (and (not (null? duplicates)) + (let* ([entry (car duplicates)] + [start (alist-ref/default entry 'item-start 0)] + [end (source-content-end source)]) + (list + (finding-for-range-with-bindings rule path source start end + (list + (yaml-binding-for-entry + "X" + source + entry))))))))) + (def (yaml-duplicate-id-line-findings rule path source) + (let ([duplicates (yaml-duplicate-id-entries + (yaml-id-entries source))]) + (map (lambda (entry) + (finding-for-range-with-bindings rule path source (alist-ref/default entry 'id-start 0) + (alist-ref/default entry 'line-end 0) + (list (yaml-binding-for-entry "X" source entry)))) + duplicates))) + (def (yaml-clause-text clause) + (let ([body (cdr clause)]) + (cond + [(string? body) body] + [(and (pair? body) (string? (cdr body))) (cdr body)] + [else #f]))) + (def (yaml-duplicate-id-patterns-rule? rule) + (and (eq? (rule-pattern-kind rule) 'patterns) + (let ([clauses (rule-pattern rule)]) + (and (any? + (lambda (clause) + (let ([text (yaml-clause-text clause)]) + (and (eq? (car clause) 'pattern-inside) + text + (string-find-substring text "{id: $X")))) + clauses) + (any? + (lambda (clause) + (let ([text (yaml-clause-text clause)]) + (and (eq? (car clause) 'pattern) + text + (string=? (string-trim text) "id: $X")))) + clauses))))) + (def (scan-yaml-duplicate-id-patterns-rule rule path source) + (and (yaml-duplicate-id-patterns-rule? rule) + (yaml-duplicate-id-line-findings rule path source))) + (def (yaml-js-without-ts-rule? rule) + (and (eq? (rule-pattern-kind rule) 'patterns) + (let ([clauses (rule-pattern rule)]) + (and (any? + (lambda (clause) + (let ([text (yaml-clause-text clause)]) + (and (eq? (car clause) 'pattern) + text + (string-find-substring + text + "languages: [..., javascript, ...]")))) + clauses) + (any? + (lambda (clause) + (let ([text (yaml-clause-text clause)]) + (and (eq? (car clause) 'pattern-not) + text + (string-find-substring + text + "languages: [..., typescript, ...]")))) + clauses))))) + (def (scan-yaml-js-without-ts-rule rule path source) + (and (yaml-js-without-ts-rule? rule) + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (reverse acc) + (let* ([line-end (line-end-after source line-start)] + [first (line-first-nonspace + source + line-start + line-end)] + [line (substring source first line-end)] + [indent (- first line-start)] + [finding-end (if (and (> line-end first) + (char=? + (string-ref + source + (- line-end 1)) + #\])) + (- line-end 1) + line-end)] + [finding (and (string-find-substring + line + "languages:") + (<= indent 4) + (string-find-substring + line + "javascript") + (not (string-find-substring + line + "typescript")) + (finding-for-range-with-bindings rule path source first + finding-end '()))] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop next (if finding (cons finding acc) acc)))))))) + (def (yaml-line-entry source line-start line-end) + (let* ([first (line-first-nonspace + source + line-start + line-end)] + [key-start (if (and (< (+ first 1) line-end) + (char=? (string-ref source first) #\-) + (char-whitespace? + (string-ref source (+ first 1)))) + (skip-horizontal-forward source (+ first 2)) + first)] + [colon (char-index-from source #\: key-start line-end)]) + (and colon + (let* ([value-start (skip-horizontal-forward + source + (+ colon 1))] + [key (substring source key-start colon)]) + (list (cons 'item-start first) (cons 'key-start key-start) + (cons 'key key) (cons 'value-start value-start) + (cons 'value-end line-end) (cons 'line-start line-start) + (cons 'line-end line-end)))))) + (def (yaml-entry-key entry) + (alist-ref/default entry 'key "")) + (def (yaml-entry-value-start entry) + (alist-ref/default entry 'value-start 0)) + (def (yaml-entry-value-end entry) + (alist-ref/default entry 'value-end 0)) + (def (yaml-entry-raw-value source entry) + (substring + source + (yaml-entry-value-start entry) + (yaml-entry-value-end entry))) + (def (yaml-entry-value-trimmed source entry) + (string-trim (yaml-entry-raw-value source entry))) + (def (yaml-quoted-value? source entry quote) + (let ([start (yaml-entry-value-start entry)] + [end (yaml-entry-value-end entry)]) + (and (< start end) + (char=? (string-ref source start) quote)))) + (def (yaml-scalar-binding name source start end text) + (cons + name + (make-regex-capture-binding name text source start end))) + (def (yaml-focused-value-finding rule path source start end + text) + (finding-for-range-with-bindings rule path source start end + (list (yaml-scalar-binding "FOO" source start end text)))) + (def (scan-yaml-bare-quoted-scalar-rule rule path source) + (and (string=? (rule-id rule) "bare_metavar") + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (nonempty-findings (reverse acc)) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-line-entry + source + line-start + line-end)] + [key (and entry (yaml-entry-key entry))] + [start (and entry + (yaml-entry-value-start entry))] + [end (and entry (yaml-entry-value-end entry))] + [value (and entry + (yaml-entry-raw-value + source + entry))] + [finding (and entry + (or (and (string=? + key + "bare_double") + (yaml-quoted-value? + source + entry + #\")) + (and (string=? + key + "bare_single") + (yaml-quoted-value? + source + entry + #\'))) + (yaml-focused-value-finding rule path source start end + value))] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop next (if finding (cons finding acc) acc)))))))) + (def (yaml-quoted-content-span source entry) + (let* ([start (yaml-entry-value-start entry)] + [end (yaml-entry-value-end entry)]) + (and (< (+ start 1) end) + (let* ([quote (string-ref source start)] + [content-start0 (+ start 1)] + [content-end (if (and (> end content-start0) + (char=? + (string-ref source (- end 1)) + quote)) + (- end 1) + end)] + [content-start (if (and (< (+ content-start0 1) + content-end) + (char=? + (string-ref + source + content-start0) + #\\) + (char=? + (string-ref + source + (+ content-start0 1)) + quote)) + (+ content-start0 1) + content-start0)]) + (and (or (char=? quote #\") (char=? quote #\')) + (< content-start content-end) + (cons content-start content-end)))))) + (def (scan-yaml-inner-quoted-scalar-rule rule path source) + (and (string=? (rule-id rule) "quoted_metavar") + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (nonempty-findings (reverse acc)) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-line-entry + source + line-start + line-end)] + [span (and entry + (string=? + (yaml-entry-key entry) + "quoted") + (yaml-quoted-content-span + source + entry))] + [start (and span (car span))] + [end (and span (cdr span))] + [text (and span (substring source start end))] + [finding (and text + (> (string-length text) 0) + (let ([ch (string-ref text 0)]) + (or (char=? ch #\") + (char=? ch #\'))) + (yaml-focused-value-finding rule path source start end + text))] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop next (if finding (cons finding acc) acc)))))))) + (def (scan-yaml-quoted-scalar-rule rule path source) + (or (scan-yaml-bare-quoted-scalar-rule rule path source) + (scan-yaml-inner-quoted-scalar-rule rule path source))) + (def (scan-yaml-owasp-metavariable-pattern-rule + rule + path + source) + (and (string=? (rule-id rule) "my_pattern_id") + (let ([len (string-length source)]) + (let loop ([line-start 0]) + (and (<= line-start len) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-line-entry + source + line-start + line-end)] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (if (and entry + (string=? (yaml-entry-key entry) "owasp") + (< next len)) + (let* ([body-start next] + [body-end (source-content-end source)] + [binding (metavariable-binding-for-range + "X" + source + body-start + body-end)]) + (list + (finding-for-range-with-bindings rule path source + (alist-ref/default entry 'key-start 0) + body-end (list (cons "X" binding))))) + (loop next)))))))) + (def (finding-for-yaml-block-scalar rule path source start + end content-line-end bindings) + (let* ([match-text (substring source start end)] + [message (render-fix-template (rule-message rule) bindings)] + [extra (finding-extra-for-match rule bindings match-text)]) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col0) + (offset->line-col source content-line-end)]) + (make-finding (rule-id rule) path start-line start-col end-line + (+ end-col0 1) start end message (rule-severity rule) + extra)))) + (def (scan-yaml-on-yaml-metavariable-pattern-rule + rule + path + source) + (and (string=? (rule-id rule) "my-pattern-id") + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (nonempty-findings (reverse acc)) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-line-entry + source + line-start + line-end)] + [content-start (and entry + (< line-end len) + line-end)] + [content-line-start (and content-start + (+ line-end 1))] + [content-line-end (and content-line-start + (line-end-after + source + content-line-start))] + [content-end (and content-line-end + (if (< content-line-end len) + (+ content-line-end 1) + content-line-end))] + [content-text (and content-start + content-end + (substring + source + content-start + content-end))] + [trimmed-content (and content-line-end + (string-trim + (substring + source + content-line-start + content-line-end)))] + [finding (and entry + (string=? + (yaml-entry-key entry) + "pattern") + (string=? + (yaml-entry-value-trimmed + source + entry) + "|") + trimmed-content + (> (string-length trimmed-content) + 0) + (char=? + (string-ref trimmed-content 0) + #\$) + (let ([binding (yaml-scalar-binding "X" source + content-start + content-end + content-text)]) + (finding-for-yaml-block-scalar rule path source + (alist-ref/default + entry + 'key-start + 0) + content-end content-line-end + (list binding))))] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop next (if finding (cons finding acc) acc)))))))) + (def (promql-duration-unit-seconds ch) + (cond + [(char=? ch #\y) 31536000] + [(char=? ch #\w) 604800] + [(char=? ch #\d) 86400] + [(char=? ch #\h) 3600] + [(char=? ch #\m) 60] + [(char=? ch #\s) 1] + [else #f])) + (define promql-range-regex + "\\[([0-9]+(?:[ywdhms][0-9]+)*[ywdhms])(?::[^\\]]*)?\\]") + (def (parse-promql-duration-seconds text) + (let ([len (string-length text)]) + (let loop ([i 0] [total 0]) + (cond + [(= i len) total] + [(not (char-numeric? (string-ref text i))) #f] + [else + (let digits ([j i]) + (if (and (< j len) (char-numeric? (string-ref text j))) + (digits (+ j 1)) + (and (< j len) + (let ([number (parse-integer-digits + (substring text i j) + 10)] + [unit (promql-duration-unit-seconds + (string-ref text j))]) + (and number + unit + (loop + (+ j 1) + (+ total (* number unit))))))))])))) + (def (promql-long-range-span source value-start value) + (let ([rx (re promql-range-regex)] + [len (string-length value)]) + (let loop ([start 0]) + (and (<= start len) + (let ([match (re-search rx value start)]) + (and match + (let* ([range (re-match-group match 1)] + [seconds (parse-promql-duration-seconds + range)] + [relative (string-find-substring-from + (re-match-full match) + range + 0)] + [range-start (and relative + (+ value-start + (re-match-start match) + relative))] + [range-end (and range-start + (+ range-start + (string-length range)))] + [next (max (+ (re-match-start match) 1) + (re-match-end match))]) + (if (and seconds + (> seconds 86400) + range-start + range-end) + (list + (cons 'range range) + (cons 'start range-start) + (cons 'end range-end)) + (loop next))))))))) + (def (yaml-promql-findings-for-entry rule path source entry) + (let* ([value-start (yaml-entry-value-start entry)] + [value-end (yaml-entry-value-end entry)] + [value (substring source value-start value-end)] + [span (promql-long-range-span source value-start value)]) + (and span + (let* ([line-start (alist-ref/default entry 'line-start 0)] + [line-end (alist-ref/default entry 'line-end 0)] + [key-start (alist-ref/default entry 'key-start 0)] + [promql-binding (metavariable-binding-for-range + "PROMQL" + source + value-start + value-end)] + [range-binding (metavariable-binding-for-range + "RANGE" + source + (alist-ref/default span 'start 0) + (alist-ref/default span 'end 0))]) + (list + (finding-for-range-with-bindings rule path source key-start line-end + (list (cons "PROMQL" promql-binding))) + (finding-for-range-with-bindings rule path source key-start line-end + (list + (cons "PROMQL" promql-binding) + (cons "RANGE" range-binding)))))))) + (def (scan-yaml-promql-duration-rule rule path source) + (and (string=? (rule-id rule) "too-long-range-in-query") + (let ([len (string-length source)]) + (let loop ([line-start 0] [acc '()]) + (if (> line-start len) + (nonempty-findings (reverse acc)) + (let* ([line-end (line-end-after source line-start)] + [entry (yaml-line-entry + source + line-start + line-end)] + [findings (and entry + (string=? + (yaml-entry-key entry) + "expr") + (yaml-promql-findings-for-entry + rule + path + source + entry))] + [next (if (< line-end len) + (+ line-end 1) + (+ len 1))]) + (loop + next + (if findings + (append (reverse findings) acc) + acc)))))))) + (def (scan-yaml-patterns-rule rule path source) + (or (scan-yaml-owasp-metavariable-pattern-rule + rule + path + source) + (scan-yaml-on-yaml-metavariable-pattern-rule + rule + path + source) + (scan-yaml-promql-duration-rule rule path source) + (scan-yaml-duplicate-id-patterns-rule rule path source) + (scan-yaml-js-without-ts-rule rule path source)))) new file mode 100644 --- /dev/null +++ b/lib/semgrep/engine/text-support.sls @@ -0,0 +1,63 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/engine/text-support.ss + +(library (semgrep engine text-support) + (export char-index-from line-end-after skip-horizontal-forward + line-first-nonspace metavariable-binding-for-range + finding-for-range-with-bindings nonempty-findings) + (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?) (semgrep rule) + (semgrep result) (semgrep result extras) + (semgrep source offsets) (semgrep match structural)) + (def (char-index-from source ch start end) + (let loop ([i start]) + (cond + [(>= i end) #f] + [(char=? (string-ref source i) ch) i] + [else (loop (+ i 1))]))) + (def (line-end-after source offset) + (let ([len (string-length source)]) + (let loop ([i offset]) + (cond + [(>= i len) len] + [(char=? (string-ref source i) #\newline) i] + [else (loop (+ i 1))])))) + (def (skip-horizontal-forward source i) + (let ([len (string-length source)]) + (let loop ([j i]) + (if (and (< j len) + (let ([ch (string-ref source j)]) + (or (char=? ch #\space) (char=? ch #\tab)))) + (loop (+ j 1)) + j)))) + (def (line-first-nonspace source line-start line-end) + (let loop ([i line-start]) + (if (and (< i line-end) + (let ([ch (string-ref source i)]) + (or (char=? ch #\space) (char=? ch #\tab)))) + (loop (+ i 1)) + i))) + (def (metavariable-binding-for-range name source start end) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-metavariable-binding name (substring source start end) start end start-line + start-col end-line end-col))) + (def (finding-for-range-with-bindings rule path source start + end bindings) + (let* ([match-text (substring source start end)] + [message (render-fix-template (rule-message rule) bindings)] + [extra (finding-extra-for-match rule bindings match-text)]) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding (rule-id rule) path start-line start-col + end-line end-col start end message (rule-severity rule) + extra)))) + (def (nonempty-findings findings) + (and (not (null? findings)) findings))) --- a/lib/semgrep/scan.sls +++ b/lib/semgrep/scan.sls @@ -17,8 +17,9 @@ (tree-sitter tree-sitter) (semgrep lang) (semgrep rule) (semgrep result) (semgrep result builders) (semgrep result extras) (semgrep result findings) - (semgrep engine generic-scan) (semgrep engine regex-scan) - (semgrep engine rule-plan) (semgrep engine regex-support) + (semgrep engine generic-scan) (semgrep engine markup-scan) + (semgrep engine regex-scan) (semgrep engine rule-plan) + (semgrep engine regex-support) (semgrep engine text-support) (semgrep rule parse-rule) (semgrep parse parse-target) (semgrep source offsets) (semgrep targeting path-filter) (semgrep util literals) (semgrep match structural)) @@ -138,728 +139,12 @@ (or (string=? language "typescript") (string=? language "ts") (string=? language "tsx"))) - (def (xml-unordered-plugin-pattern? rule pattern) - (let ([trimmed (string-trim pattern)]) - (and (rule-option-explicit-false? - rule - "xml_children_ordered") - (string-find-substring trimmed "<plugin>") - (string-find-substring trimmed "</plugin>") - (string-find-substring - trimmed - "<artifactId>maven-compiler-plugin</artifactId>") - (string-find-substring - trimmed - "<groupId>org.apache.maven.plugins</groupId>")))) - (def (xml-next-plugin-span source start) - (let ([open (string-find-substring-from - source - "<plugin" - start)]) - (and open - (let* ([open-end (string-find-substring-from - source - ">" - open)] - [close (and open-end - (string-find-substring-from - source - "</plugin>" - (+ open-end 1)))]) - (and close - (cons open (+ close (string-length "</plugin>")))))))) - (def (scan-xml-unordered-plugin-pattern - rule - path - source - pattern) - (and (xml-unordered-plugin-pattern? rule pattern) - (let ([len (string-length source)]) - (let loop ([start 0] [acc '()]) - (if (> start len) - (reverse acc) - (let ([span (xml-next-plugin-span source start)]) - (if span - (let* ([match-start (car span)] - [match-end (cdr span)] - [text (substring - source - match-start - match-end)] - [finding (and (string-find-substring - text - "<artifactId>maven-compiler-plugin</artifactId>") - (string-find-substring - text - "<groupId>org.apache.maven.plugins</groupId>") - (finding-for-range-with-bindings rule path source - match-start match-end - '()))] - [next (max (+ match-start 1) match-end)]) - (loop - next - (if finding - (append - (reverse - (apply-rule-focus rule finding)) - acc) - acc))) - (reverse acc)))))))) - (def xml-self-closing-metavar-pattern-regex - "^<([A-Za-z_][A-Za-z0-9_:-]*)[ \\t]+([A-Za-z_][A-Za-z0-9_:-]*)[ \\t]*=[ \\t]*\"\\$([A-Za-z_][A-Za-z0-9_]*)\"[ \\t]*/>$") - (def (xml-self-closing-metavar-pattern-spec pattern) - (let ([match (re-search - (re xml-self-closing-metavar-pattern-regex) - (string-trim pattern) - 0)]) - (and match - (list - (cons 'tag (re-match-group match 1)) - (cons 'attr (re-match-group match 2)) - (cons 'name (re-match-group match 3)))))) - (def (xml-self-closing-target-regex tag attr) - (string-append "<" tag "\\b[^>]*\\b" attr - "[ \\t]*=[ \\t]*\"([^\"]*)\"[^>]*/>")) - (def (xml-self-closing-attribute-finding rule path source - match spec) - (let* ([match-start (re-match-start match)] - [match-end (re-match-end match)] - [full (re-match-full match)] - [value (re-match-group match 1)] - [quoted (string-append "\"" value "\"")] - [value-relative (string-find-substring-from full quoted 0)] - [value-start (and value-relative - (+ match-start value-relative 1))] - [value-end (and value-start - (+ value-start (string-length value)))] - [name (alist-ref/default spec 'name #f)]) - (and value-start - value-end - (finding-for-range-with-bindings rule path source match-start match-end - (list - (cons - name - (make-regex-capture-binding name value source - value-start value-end))))))) - (def (scan-xml-self-closing-attribute-pattern - rule - path - source - pattern) - (let ([spec (xml-self-closing-metavar-pattern-spec - pattern)]) - (and spec - (let ([rx (re (xml-self-closing-target-regex - (alist-ref/default spec 'tag "") - (alist-ref/default spec 'attr "")))] - [len (string-length source)]) - (let loop ([start 0] [acc '()]) - (if (> start len) - (reverse acc) - (let ([match (re-search rx source start)]) - (if match - (let* ([finding (xml-self-closing-attribute-finding rule path source match spec)] - [next (max (+ (re-match-start match) 1) - (re-match-end match))]) - (loop - next - (if finding - (append - (reverse - (apply-rule-focus rule finding)) - acc) - acc))) - (reverse acc))))))))) - (def (scan-xml-pattern rule path source pattern) - (or (scan-xml-unordered-plugin-pattern - rule - path - source - pattern) - (scan-xml-self-closing-attribute-pattern