fix: segment source so import-path renames skip string literals and comments (#31)
ober
f08cd07453e3973c0d0f7e585ced0e7fa6f8714c
--- a/convert.ss +++ b/convert.ss @@ -3,16 +3,19 @@ ;;; ;;; jerboa-emacs and gerbil-emacs share the same Gerbil surface syntax; porting a ;;; feature is mostly renaming import module paths and pointing Jerboa's -;;; "chez-powers" stdlib surface at :jerboa-compat. This applies those renames -;;; textually (preserving comments/formatting) and reports residual :jerboa-* -;;; references that need a human (e.g. libraries not yet ported to Gerbil). +;;; "chez-powers" stdlib surface at :jerboa-compat. This applies those renames to +;;; CODE regions only — string literals and comments are preserved verbatim, so a +;;; ":jerboa-*" inside a string or comment is never rewritten (preserving +;;; comments/formatting) — and reports residual :jerboa-* references that need a +;;; human (e.g. libraries not yet ported to Gerbil). ;;; ;;; gxi convert.ss INPUT.ss [-o OUTPUT.ss] # default: write to stdout ;;; gxi convert.ss --help # print usage ;;; ;;; Library use: (import :jerboa-gerbil/convert) then (convert-string text). -(export convert-string convert-file! +rename-rules+ main) +(export convert-string convert-file! safe-output-path check-rename-rules! + +rename-rules+ +max-input-bytes+ main) (import :std/srfi/13 :std/misc/ports :std/format) @@ -25,6 +28,22 @@ ("aws" ":jerboa-aws/" ":gerbil-aws/") ("emacs" ":jerboa-emacs/" ":gemacs/"))) +;; Guard against rule cascades: if one rule's OUTPUT substring-matches another +;; rule's INPUT, sequential application could rewrite a freshly-produced token +;; again. Fail fast at load rather than silently double-rewriting. +(def (check-rename-rules! rules) + (for-each + (lambda (ri) + (for-each + (lambda (rj) + (unless (eq? ri rj) + (when (string-contains (caddr ri) (cadr rj)) + (error "jerboa-gerbil: rename cascade: rule output matches another rule's input" + (car ri) (caddr ri) (car rj) (cadr rj))))) + rules)) + rules)) +(check-rename-rules! +rename-rules+) + ;; literal (non-regex) count + replace, with an optional start offset (def (count-sub sub s) (let (n (string-length sub)) @@ -40,29 +59,255 @@ (loop (+ i ol) (cons new (cons (substring s start i) acc))) (string-concatenate (reverse (cons (substring s start (string-length s)) acc)))))))) +;; --- source segmentation ------------------------------------------------- +;; Split source into ordered segments, each (code? . text). Only code segments +;; are rewritable; string literals and comments (line, nested block, and #; +;; datum comments) are kept verbatim so renames never touch their contents. + +(def (skip-string text i len) + (let loop ((j (+ i 1))) + (cond + ((>= j len) len) + ((char=? (string-ref text j) #\\) (loop (if (< (+ j 1) len) (+ j 2) len))) + ((char=? (string-ref text j) #\") (+ j 1)) + (else (loop (+ j 1)))))) + +(def (skip-line-comment text i len) + (let loop ((j i)) + (cond + ((>= j len) len) + ((char=? (string-ref text j) #\newline) j) + (else (loop (+ j 1)))))) + +;; #| ... |# block comments nest. +(def (skip-block-comment text i len) + (let loop ((j (+ i 2)) (depth 1)) + (cond + ((>= j len) len) + ((and (< (+ j 1) len) (char=? (string-ref text j) #\#) (char=? (string-ref text (+ j 1)) #\|)) + (loop (+ j 2) (+ depth 1))) + ((and (< (+ j 1) len) (char=? (string-ref text j) #\|) (char=? (string-ref text (+ j 1)) #\#)) + (let (d (- depth 1)) (if (= d 0) (+ j 2) (loop (+ j 2) d)))) + (else (loop (+ j 1) depth))))) + +;; #\<char> — skip so #\; or #\| is not mistaken for a comment delimiter. +(def (skip-char-literal text i len) + (let (j (+ i 2)) + (cond + ((>= j len) len) + ((let (c (string-ref text j)) (or (char-alphabetic? c) (char-numeric? c))) + (let loop ((k j)) + (if (and (< k len) (let (c (string-ref text k)) (or (char-alphabetic? c) (char-numeric? c)))) + (loop (+ k 1)) k))) + (else (+ j 1))))) + +(def (skip-ws text i len) + (let loop ((j i)) + (if (and (< j len) (char-whitespace? (string-ref text j))) (loop (+ j 1)) j))) + +(def (skip-atom text i len) + (let loop ((j i)) + (cond + ((>= j len) len) + ((let (c (string-ref text j)) + (or (char-whitespace? c) (char=? c #\() (char=? c #\)) (char=? c #\[) (char=? c #\]) + (char=? c #\{) (char=? c #\}) (char=? c #\") (char=? c #\;))) + j) + (else (loop (+ j 1)))))) + +;; Skip a balanced (...) / [...] / {...} form, honoring nested strings/comments. +(def (skip-balanced text i len) + (let* ((open (string-ref text i)) + (close (cond ((char=? open #\() #\)) ((char=? open #\[) #\]) ((char=? open #\{) #\}) (else #\))))) + (let loop ((j (+ i 1)) (depth 1)) + (cond + ((>= j len) len) + ((and (char=? (string-ref text j) #\#) (< (+ j 1) len) (char=? (string-ref text (+ j 1)) #\;)) + (loop (skip-datum-comment text j len) depth)) + ((and (char=? (string-ref text j) #\#) (< (+ j 1) len) (char=? (string-ref text (+ j 1)) #\\)) + (loop (skip-char-literal text j len) depth)) + ((and (char=? (string-ref text j) #\#) (< (+ j 1) len) (char=? (string-ref text (+ j 1)) #\|)) + (loop (skip-block-comment text j len) depth)) + ((char=? (string-ref text j) #\;) (loop (skip-line-comment text j len) depth)) + ((char=? (string-ref text j) #\") (loop (skip-string text j len) depth)) + ((let (c (string-ref text j)) (or (char=? c #\() (char=? c #\[) (char=? c #\{))) + (loop (+ j 1) (+ depth 1))) + ((char=? (string-ref text j) close) (if (= depth 1) (+ j 1) (loop (+ j 1) (- depth 1)))) + ((let (c (string-ref text j)) (or (char=? c #\)) (char=? c #\]) (char=? c #\}))) (+ j 1)) + (else (loop (+ j 1) depth)))))) + +(def (skip-one-datum text i len) + (let (i (skip-ws text i len)) + (cond + ((>= i len) len) + ((let (c (string-ref text i)) (or (char=? c #\() (char=? c #\[) (char=? c #\{))) + (skip-balanced text i len)) + ((char=? (string-ref text i) #\") (skip-string text i len)) + ((and (char=? (string-ref text i) #\#) (< (+ i 1) len) + (let (d (string-ref text (+ i 1))) (or (char=? d #\() (char=? d #\[) (char=? d #\{)))) + (skip-balanced text (+ i 1) len)) + ((and (char=? (string-ref text i) #\#) (< (+ i 1) len) (char=? (string-ref text (+ i 1)) #\;)) + (skip-one-datum text (skip-datum-comment text i len) len)) + (else (skip-atom text i len))))) + +;; #; comments the next datum; stacked #;#; comment that many datums. +(def (skip-datum-comment text i len) + (let loop-prefix ((j i) (n 0)) + (cond + ((and (< (+ j 1) len) (char=? (string-ref text j) #\#) (char=? (string-ref text (+ j 1)) #\;)) + (loop-prefix (+ j 2) (+ n 1))) + ((and (< j len) (char-whitespace? (string-ref text j))) (loop-prefix (+ j 1) n)) + (else + (let loop-datums ((k j) (m n)) + (if (<= m 0) k (loop-datums (skip-one-datum text k len) (- m 1)))))))) + +(def (cons-code segs text start end) + (if (> end start) (cons (cons #t (substring text start end)) segs) segs)) + +(def (segment-source text) + (let (len (string-length text)) + (let loop ((i 0) (code-start 0) (segs '())) + (if (>= i len) + (reverse (cons-code segs text code-start len)) + (let (c (string-ref text i)) + (cond + ((and (char=? c #\#) (< (+ i 1) len) (char=? (string-ref text (+ i 1)) #\\)) + (loop (skip-char-literal text i len) code-start segs)) + ((and (char=? c #\#) (< (+ i 1) len) (char=? (string-ref text (+ i 1)) #\|)) + (let (j (skip-block-comment text i len)) + (loop j j (cons (cons #f (substring text i j)) (cons-code segs text code-start i))))) + ((and (char=? c #\#) (< (+ i 1) len) (char=? (string-ref text (+ i 1)) #\;)) + (let (j (skip-datum-comment text i len)) + (loop j j (cons (cons #f (substring text i j)) (cons-code segs text code-start i))))) + ((char=? c #\;) + (let (j (skip-line-comment text i len)) + (loop j j (cons (cons #f (substring text i j)) (cons-code segs text code-start i))))) + ((char=? c #\") + (let (j (skip-string text i len)) + (loop j j (cons (cons #f (substring text i j)) (cons-code segs text code-start i))))) + (else (loop (+ i 1) code-start segs)))))))) + +(def (apply-rule segs old new) + (let loop ((segs segs) (acc '()) (total 0)) + (if (null? segs) + (values (reverse acc) total) + (let (s (car segs)) + (if (car s) + (let (c (count-sub old (cdr s))) + (loop (cdr segs) + (cons (cons #t (if (> c 0) (replace-all (cdr s) old new) (cdr s))) acc) + (+ total c))) + (loop (cdr segs) (cons s acc) total)))))) + +(def (reassemble segs) + (string-concatenate (map cdr segs))) + +;; residual :jerboa-* refs counted over CODE only (string/comment content is not +;; a real reference); the intended :jerboa-compat/ target is excluded precisely. +(def (code-residual segs) + (let loop ((segs segs) (n 0)) + (if (null? segs) n + (loop (cdr segs) + (if (caar segs) + (+ n (- (count-sub ":jerboa-" (cdar segs)) + (count-sub ":jerboa-compat/" (cdar segs)))) + n))))) + ;; convert-string : text -> (values new-text report residual-count) ;; report is a list of (rule-name . count); residual-count is the number of -;; ":jerboa-" tokens still present after the renames (should be 0). +;; ":jerboa-" tokens still present in code after the renames (should be 0). (def (convert-string text) - (let loop ((rules +rename-rules+) (s text) (report '())) + (let loop ((rules +rename-rules+) (segs (segment-source text)) (report '())) (if (null? rules) - ;; residual = leftover :jerboa-* refs, excluding our intended :jerboa-compat/ target. - ;; Match the package prefix ":jerboa-compat/" precisely (note the slash) so a - ;; hypothetical ":jerboa-compatibility" is still counted as residual. - (values s (reverse report) (- (count-sub ":jerboa-" s) (count-sub ":jerboa-compat/" s))) - (let* ((rule (car rules)) - (name (car rule)) (old (cadr rule)) (new (caddr rule)) - (c (count-sub old s))) - (loop (cdr rules) - (if (> c 0) (replace-all s old new) s) - (cons (cons name c) report)))))) - -(def (convert-file! in (out #f)) - (let-values (((txt report residual) (convert-string (read-file-string in)))) - (if out - (call-with-output-file out (lambda (p) (display txt p))) - (display txt)) - (values report residual))) + (values (reassemble segs) (reverse report) (code-residual segs)) + (let* ((rule (car rules)) (name (car rule)) (old (cadr rule)) (new (caddr rule))) + (let-values (((segs2 c) (apply-rule segs old new))) + (loop (cdr rules) segs2 (cons (cons name c) report))))))) + +;; --- safe file output ---------------------------------------------------- + +;; Refuse inputs larger than this to avoid unbounded read-file-string OOM. +(def +max-input-bytes+ (* 64 1024 1024)) + +(def (strip-trailing-sep p) + (let (q (path-strip-trailing-directory-separator p)) + (if (string=? q "") "/" q))) + +(def (canonical-or p) + (with-catch (lambda (e) p) (lambda () (strip-trailing-sep (path-normalize p))))) + +(def (path-components p) + (filter (lambda (c) (not (or (= (string-length c) 0) (string=? c ".")))) + (string-split-char p #\/))) + +(def (string-split-char s c) + (let (len (string-length s)) + (let loop ((i 0) (start 0) (acc '())) + (cond + ((>= i len) (reverse (cons (substring s start len) acc))) + ((char=? (string-ref s i) c) (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))) + (else (loop (+ i 1) start acc)))))) + +;; lexically resolve "." and ".." in an absolute path (no filesystem access) +(def (normalize-abs p) + (let loop ((cs (path-components p)) (stack '())) + (cond + ((null? cs) + (let (stack (reverse stack)) + (if (null? stack) "/" + (string-concatenate (map (lambda (c) (string-append "/" c)) stack))))) + ((string=? (car cs) "..") (loop (cdr cs) (if (null? stack) '() (cdr stack)))) + (else (loop (cdr cs) (cons (car cs) stack)))))) + +(def (absolute-path out root) + (normalize-abs (if (and (> (string-length out) 0) (char=? (string-ref out 0) #\/)) + out + (string-append root "/" out)))) + +(def (path-within? cand root) + (or (string=? cand root) + (let (prefix (string-append root "/")) + (and (>= (string-length cand) (string-length prefix)) + (string=? (substring cand 0 (string-length prefix)) prefix))))) + +(def (symlink? p) + (with-catch (lambda (e) #f) + (lambda () (eq? (file-info-type (file-info p #f)) 'symbolic-link)))) + +;; Confine OUT under ROOT (default: cwd) and reject symlink escapes. Returns the +;; safe absolute path to write, or raises. Resolves ".." lexically (so ../ cannot +;; climb out), refuses a symlinked final target, and refuses any symlinked +;; intermediate directory whose real path lands outside ROOT. +(def (safe-output-path out (root (current-directory))) + (let* ((root (canonical-or root)) + (cand (absolute-path out root))) + (unless (path-within? cand root) + (error "jerboa-gerbil: output path escapes confinement root" out root)) + (let loop ((prefix root) + (cs (path-components (substring cand (string-length root) (string-length cand))))) + (when (pair? cs) + (let (next (string-append prefix "/" (car cs))) + (when (pair? (cdr cs)) + (when (symlink? next) + (let (resolved (canonical-or next)) + (unless (path-within? resolved root) + (error "jerboa-gerbil: output escapes confinement via symlinked directory" + next resolved root))))) + (loop next (cdr cs))))) + (when (symlink? cand) + (error "jerboa-gerbil: refusing to write through a symlink" cand)) + cand)) + +(def (convert-file! in (out #f) (root (current-directory)) (max-bytes +max-input-bytes+)) + (let (sz (with-catch (lambda (e) 0) (lambda () (file-info-size (file-info in #t))))) + (when (> sz max-bytes) + (error "jerboa-gerbil: input file exceeds size limit" in sz max-bytes))) + (let (safe-out (and out (safe-output-path out root))) + (let-values (((txt report residual) (convert-string (read-file-string in)))) + (if safe-out + (call-with-output-file safe-out (lambda (p) (display txt p))) + (display txt)) + (values report residual)))) (def +usage+ "usage: gxi convert.ss INPUT.ss [-o OUTPUT.ss] # default: write to stdout --- a/test/convert-test.ss +++ b/test/convert-test.ss @@ -3,7 +3,10 @@ ;;; ;;; Run via `make test` (or: GERBIL_LOADPATH=<parent-of-package> gxi test/convert-test.ss). -(import :std/srfi/13 (only-in :jerboa-gerbil/convert convert-string)) +(import :std/srfi/13 :std/misc/ports + (only-in :jerboa-gerbil/convert + convert-string convert-file! safe-output-path check-rename-rules! + +rename-rules+)) (def failures (box 0)) @@ -48,6 +51,110 @@ (check ":jerboa-compatibility counted as residual (precise match)" (= 1 residual))) +;; --- #31: renames must not touch string literals or comments -------------- + +;; a string literal is NOT rewritten +(let-values (((txt report residual) + (convert-string "(display \":jerboa-emacs/foo\")\n"))) + (check "string literal preserved verbatim" + (string-contains txt ":jerboa-emacs/foo")) + (check "string literal does not fire the emacs rule" + (= 0 (cdr (assoc "emacs" report)))) + (check "string literal content is not residual" + (= 0 residual))) + +;; a real import beside a string: import rewritten, string preserved +(let-values (((txt report residual) + (convert-string "(import :jerboa-emacs/bar)\n(display \":jerboa-emacs/foo\")\n"))) + (check "real import rewritten beside a string" (string-contains txt ":gemacs/bar")) + (check "sibling string preserved" (string-contains txt ":jerboa-emacs/foo")) + (check "no residual when only the string holds :jerboa-" (= 0 residual))) + +;; a line comment is NOT rewritten +(let-values (((txt report residual) + (convert-string ";; see :jerboa-emacs/baz\n(import :jerboa-emacs/qux)\n"))) + (check "line comment preserved" (string-contains txt ":jerboa-emacs/baz")) + (check "code after line comment rewritten" (string-contains txt ":gemacs/qux")) + (check "line comment content is not residual" (= 0 residual))) + +;; a block comment is NOT rewritten +(let-values (((txt report residual) + (convert-string "#| :jerboa-emacs/blk |# (import :jerboa-emacs/q2)\n"))) + (check "block comment preserved" (string-contains txt ":jerboa-emacs/blk")) + (check "code after block comment rewritten" (string-contains txt ":gemacs/q2"))) + +;; a #; datum comment is NOT rewritten +(let-values (((txt report residual) + (convert-string "#; (import :jerboa-emacs/datum) (import :jerboa-emacs/real)\n"))) + (check "datum comment preserved" (string-contains txt ":jerboa-emacs/datum")) + (check "code after datum comment rewritten" (string-contains txt ":gemacs/real"))) + +;; --- #3: load-time cascade guard ------------------------------------------ + +(check "cascade guard accepts the real rule set" + (with-catch (lambda (e) #f) (lambda () (check-rename-rules! +rename-rules+) #t))) +(check "cascade guard rejects a cascading rule set" + (with-catch (lambda (e) #t) + (lambda () (check-rename-rules! '(("a" ":foo/" ":bar/") ("b" ":bar/" ":baz/"))) #f))) + +;; --- #2 + #4: safe file output (confinement, symlinks, size guard) -------- + +(def tmp-base + (let (b (getenv "TMPDIR" "/tmp")) + (if (and (> (string-length b) 0) (char=? (string-ref b (- (string-length b) 1)) #\/)) + b (string-append b "/")))) +(def tmp-root (string-append tmp-base "jerboa-gerbil-convert-test-" (number->string (##os-getpid)))) +(def outside-dir (string-append tmp-base "jerboa-gerbil-outside-" (number->string (##os-getpid)))) +(create-directory tmp-root) +(create-directory outside-dir) + +(def in-path (string-append tmp-root "/in.ss")) +(call-with-output-file in-path + (lambda (p) (display "(import :jerboa-emacs/foo)\n(display \":jerboa-emacs/str\")\n" p))) + +;; positive: writing inside the root succeeds and is correct +(let-values (((report residual) (convert-file! in-path "ok.ss" tmp-root))) + (let (out-txt (read-file-string (string-append tmp-root "/ok.ss"))) + (check "convert-file! writes within the root" (file-exists? (string-append tmp-root "/ok.ss"))) + (check "written output is rewritten" (string-contains out-txt ":gemacs/foo")) + (check "written output preserves the string literal" (string-contains out-txt ":jerboa-emacs/str")))) + +;; ../ traversal is rejected and creates nothing outside the root +(check "safe-output-path rejects ../ traversal" + (with-catch (lambda (e) #t) (lambda () (safe-output-path "../escape.ss" tmp-root) #f))) +(check "convert-file! rejects ../ traversal" + (with-catch (lambda (e) #t) (lambda () (convert-file! in-path "../escape.ss" tmp-root) #f))) +(check "../ traversal created no file outside the root" + (not (file-exists? (string-append tmp-base "escape.ss")))) + +;; a symlinked intermediate directory escaping the root is rejected +(create-symbolic-link outside-dir (string-append tmp-root "/evil")) +(check "convert-file! rejects a symlinked-directory escape" + (with-catch (lambda (e) #t) (lambda () (convert-file! in-path "evil/x.ss" tmp-root) #f))) + +;; a symlinked final target is refused and its target is not clobbered +(def outside-file (string-append outside-dir "/target.ss")) +(call-with-output-file outside-file (lambda (p) (display "sentinel" p))) +(create-symbolic-link outside-file (string-append tmp-root "/link.ss")) +(check "convert-file! refuses a symlinked final target" + (with-catch (lambda (e) #t) (lambda () (convert-file! in-path "link.ss" tmp-root) #f))) +(check "symlink target was not clobbered" + (string=? "sentinel" (read-file-string outside-file))) + +;; #4: oversized input is refused before reading +(check "convert-file! enforces the input size limit" + (with-catch (lambda (e) #t) (lambda () (convert-file! in-path #f tmp-root 1) #f))) + +;; best-effort cleanup +(for-each (lambda (p) (with-catch (lambda (e) #f) (lambda () (delete-file p)))) + (list in-path + (string-append tmp-root "/ok.ss") + (string-append tmp-root "/evil") + (string-append tmp-root "/link.ss") + outside-file)) +(with-catch (lambda (e) #f) (lambda () (delete-directory tmp-root))) +(with-catch (lambda (e) #f) (lambda () (delete-directory outside-dir))) + (let (n (unbox failures)) (if (> n 0) (begin (displayln n " failure(s)") (exit 1))