safe-chains 0.220.0

use crate::verdict::{SafetyLevel, Verdict};
use crate::parse::{Token, WordSet};

static SAFE_PERL_WORDS: WordSet = WordSet::new(&[
    "ARGV", "BEGIN", "END", "STDERR", "STDIN", "STDOUT",
    "abs", "and", "atan2",
    "chomp", "chop", "chr", "close", "cmp", "cos",
    "defined", "delete", "die",
    "each", "else", "elsif", "eof", "eq", "exists", "exp",
    "for", "foreach",
    "ge", "grep", "gt",
    "hex",
    "if", "int",
    "join",
    "keys",
    "last", "lc", "lcfirst", "le", "length", "local", "log", "lt",
    "map", "my",
    "ne", "next", "no", "not",
    "oct", "or", "ord", "our",
    "pack", "pop", "pos", "print", "printf", "push",
    "qq", "qr", "qw",
    "ref", "return", "reverse", "rindex",
    "say", "scalar", "shift", "sin", "sort", "splice", "split", "sprintf", "sqrt", "substr",
    "tell", "tr",
    "uc", "ucfirst", "undef", "unless", "unpack", "unshift", "until",
    "values",
    "wantarray", "warn", "while",
]);

fn closing_delimiter(open: u8) -> u8 {
    match open {
        b'(' => b')',
        b'[' => b']',
        b'{' => b'}',
        b'<' => b'>',
        _ => open,
    }
}

fn is_paired_delimiter(b: u8) -> bool {
    matches!(b, b'(' | b'[' | b'{' | b'<')
}

fn skip_delimited(bytes: &[u8], start: usize) -> Option<usize> {
    if start >= bytes.len() {
        return None;
    }
    let open = bytes[start];
    let close = closing_delimiter(open);
    let paired = is_paired_delimiter(open);
    let mut depth = 1u32;
    let mut i = start + 1;
    while i < bytes.len() {
        if bytes[i] == b'\\' {
            i += 2;
            continue;
        }
        if paired {
            if bytes[i] == open {
                depth += 1;
            } else if bytes[i] == close {
                depth -= 1;
                if depth == 0 {
                    return Some(i + 1);
                }
            }
        } else if bytes[i] == close {
            return Some(i + 1);
        }
        i += 1;
    }
    None
}

fn skip_regex_body(bytes: &[u8], start: usize, sections: usize) -> Option<(usize, &[u8])> {
    if start >= bytes.len() {
        return None;
    }
    let delim = bytes[start];
    let mut pos = start;

    if is_paired_delimiter(delim) {
        for _ in 0..sections {
            if pos >= bytes.len() {
                return None;
            }
            pos = skip_delimited(bytes, pos)?;
        }
    } else {
        pos += 1;
        for _ in 0..sections {
            loop {
                if pos >= bytes.len() {
                    return None;
                }
                if bytes[pos] == b'\\' {
                    pos += 2;
                    continue;
                }
                if bytes[pos] == delim {
                    pos += 1;
                    break;
                }
                pos += 1;
            }
        }
    }
    let flags_start = pos;
    while pos < bytes.len() && bytes[pos].is_ascii_alphabetic() {
        pos += 1;
    }
    Some((pos, &bytes[flags_start..pos]))
}

fn at_word_boundary(bytes: &[u8], i: usize) -> bool {
    i == 0 || !(bytes[i - 1].is_ascii_alphanumeric() || bytes[i - 1] == b'_')
}

fn strip_regex_content(code: &str) -> String {
    let bytes = code.as_bytes();
    let mut result = Vec::with_capacity(bytes.len());
    let mut i = 0;

    while i < bytes.len() {
        if bytes[i] == b's'
            && at_word_boundary(bytes, i)
            && i + 1 < bytes.len()
            && !bytes[i + 1].is_ascii_alphanumeric()
            && bytes[i + 1] != b'_'
            && let Some((end, _)) = skip_regex_body(bytes, i + 1, 2)
        {
            result.push(b's');
            i = end;
            continue;
        }

        if (bytes[i] == b'm' || bytes[i] == b'y')
            && at_word_boundary(bytes, i)
            && i + 1 < bytes.len()
            && !bytes[i + 1].is_ascii_alphanumeric()
            && bytes[i + 1] != b'_'
            && let Some((end, _)) = skip_regex_body(bytes, i + 1, if bytes[i] == b'y' { 2 } else { 1 })
        {
            result.push(bytes[i]);
            i = end;
            continue;
        }

        if i + 1 < bytes.len()
            && bytes[i] == b't'
            && at_word_boundary(bytes, i)
            && bytes[i + 1] == b'r'
            && i + 2 < bytes.len()
            && !bytes[i + 2].is_ascii_alphanumeric()
            && bytes[i + 2] != b'_'
            && let Some((end, _)) = skip_regex_body(bytes, i + 2, 2)
        {
            result.extend_from_slice(b"tr");
            i = end;
            continue;
        }

        if bytes[i] == b'/' && is_regex_context(&result) {
            let start = i + 1;
            let mut j = start;
            while j < bytes.len() {
                if bytes[j] == b'\\' {
                    j += 2;
                    continue;
                }
                if bytes[j] == b'/' {
                    j += 1;
                    while j < bytes.len() && bytes[j].is_ascii_alphabetic() {
                        j += 1;
                    }
                    i = j;
                    break;
                }
                j += 1;
            }
            if i != j {
                i = bytes.len();
            }
            continue;
        }

        result.push(bytes[i]);
        i += 1;
    }

    String::from_utf8(result).unwrap_or_default()
}

fn is_regex_context(preceding: &[u8]) -> bool {
    let end = match preceding.iter().rposition(|b| !b.is_ascii_whitespace()) {
        Some(pos) => pos,
        None => return true,
    };
    let last = preceding[end];
    if matches!(last, b'~' | b'(' | b',' | b';' | b'!' | b'&' | b'|' | b'?' | b':' | b'=' | b'{') {
        return true;
    }
    if last.is_ascii_alphabetic() || last == b'_' {
        let start = preceding[..=end]
            .iter()
            .rposition(|b| !b.is_ascii_alphanumeric() && *b != b'_')
            .map(|p| p + 1)
            .unwrap_or(0);
        let word = std::str::from_utf8(&preceding[start..=end]).unwrap_or("");
        return matches!(
            word,
            "if" | "unless" | "while" | "until" | "and" | "or" | "not" | "for" | "foreach" | "return"
        );
    }
    false
}

fn has_substitution_eval(code: &str) -> bool {
    let bytes = code.as_bytes();
    let mut i = 0;
    while i < bytes.len() {
        if bytes[i] == b's'
            && at_word_boundary(bytes, i)
            && i + 1 < bytes.len()
            && !bytes[i + 1].is_ascii_alphanumeric()
            && bytes[i + 1] != b'_'
            && let Some((_, flags)) = skip_regex_body(bytes, i + 1, 2)
            && flags.contains(&b'e')
        {
            return true;
        }
        i += 1;
    }
    false
}

/// Perl double-quoted strings INTERPOLATE code — `@{[ EXPR ]}`, `${\ EXPR }`, `${ EXPR }`,
/// `@{ EXPR }`, and array/hash SUBSCRIPTS (`$a[ EXPR ]`, `$h{ EXPR }`) all evaluate EXPR at
/// runtime. Naively dropping the whole quoted string (the old `content_outside_double_quotes`)
/// hid `print "@{[system(...)]}"`. This keeps interpolated EXPRESSION content for the allowlist
/// walk while dropping inert literal text and simple value interpolation (`$name`/`@name`), so
/// `"system is down"` stays safe but `"@{[system(...)]}"` is analyzed and denied. Single-quoted
/// perl strings do not interpolate and are left as-is (a keyword inside them just over-denies).
fn strip_inert_string_text(code: &str) -> String {
    let bytes = code.as_bytes();
    let mut out: Vec<u8> = Vec::with_capacity(bytes.len());
    let mut i = 0;
    while i < bytes.len() {
        if bytes[i] != b'"' {
            out.push(bytes[i]);
            i += 1;
            continue;
        }
        out.push(b' '); // opening quote
        i += 1;
        while i < bytes.len() {
            match bytes[i] {
                b'\\' => {
                    out.push(b' '); // an escaped char is inert
                    i = (i + 2).min(bytes.len());
                }
                b'"' => {
                    i += 1;
                    break;
                }
                b'$' | b'@' => {
                    out.push(b' ');
                    i += 1;
                    if bytes.get(i) == Some(&b'{') {
                        // block interpolation `${…}` / `@{…}`: keep the inner expression
                        if let Some(end) = skip_delimited(bytes, i) {
                            out.extend_from_slice(&bytes[i + 1..end - 1]);
                            i = end;
                        } else {
                            // Unbalanced (malformed) — copy the remainder for the walk and STOP,
                            // rather than `i += 1` and re-scanning per `{` (O(n²) on `"@{@{@{…"`).
                            out.extend_from_slice(&bytes[i..]);
                            i = bytes.len();
                        }
                    } else {
                        // `$name` / `@name`: the value read is inert — skip the name…
                        while i < bytes.len()
                            && (bytes[i] == b'_' || bytes[i] == b':' || bytes[i].is_ascii_alphanumeric())
                        {
                            i += 1;
                        }
                        // …but an array/hash SUBSCRIPT is EVALUATED — keep its content.
                        while matches!(bytes.get(i), Some(b'[') | Some(b'{')) {
                            match skip_delimited(bytes, i) {
                                Some(end) => {
                                    out.extend_from_slice(&bytes[i + 1..end - 1]);
                                    i = end;
                                }
                                // Unbalanced — copy the rest and STOP (avoids O(n²) on `"$a[$a[…"`).
                                None => {
                                    out.extend_from_slice(&bytes[i..]);
                                    i = bytes.len();
                                    break;
                                }
                            }
                        }
                    }
                }
                _ => {
                    out.push(b' '); // inert literal char
                    i += 1;
                }
            }
        }
    }
    String::from_utf8(out).unwrap_or_default()
}

pub(crate) fn perl_code_is_safe(token: &Token) -> bool {
    let no_strings = strip_inert_string_text(token.as_str());
    if no_strings.contains('`') {
        return false;
    }
    if has_substitution_eval(&no_strings) {
        return false;
    }
    let stripped = strip_regex_content(&no_strings);
    let bytes = stripped.as_bytes();
    let mut i = 0;
    while i < bytes.len() {
        if bytes[i] == b'$' || bytes[i] == b'@' || bytes[i] == b'%' {
            i += 1;
            if i < bytes.len() && (bytes[i] == b'_' || bytes[i].is_ascii_alphabetic()) {
                while i < bytes.len() && (bytes[i] == b'_' || bytes[i].is_ascii_alphanumeric()) {
                    i += 1;
                }
            }
            continue;
        }
        if bytes[i] == b'_' || bytes[i].is_ascii_alphabetic() {
            let start = i;
            while i < bytes.len() && (bytes[i] == b'_' || bytes[i].is_ascii_alphanumeric()) {
                i += 1;
            }
            let word = &stripped[start..i];
            if word.len() > 1 && !SAFE_PERL_WORDS.contains(word) {
                return false;
            }
            continue;
        }
        i += 1;
    }
    true
}

/// What a `perl` invocation asks for, once its flag grammar is walked: whether every `-e`/`-E`
/// one-liner passed the identifier gate, whether `-i` turns the operands into in-place rewrites,
/// and which operands are the FILES. The engine (`resolve_perl`) gates those files by locus; this
/// scan only reports them, because "which token is a file" is perl-grammar knowledge and "may this
/// path be read/written" is engine knowledge.
pub(crate) struct PerlScan {
    /// Where the code came from and whether it could be read.
    pub code: PerlCode,
    /// `-i[SUFFIX]` — the file operands are rewritten in place rather than read.
    pub in_place: bool,
    /// Operands left after the flag walk. With `-e` these are input files; without it the first
    /// would be a SCRIPT file, which [`PerlCode::Opaque`] already refuses.
    pub files: Vec<String>,
}

/// What perl was asked to run.
#[derive(PartialEq, Eq)]
pub(crate) enum PerlCode {
    /// `--version` / `--help` and friends — reports on perl itself, running nothing.
    None,
    /// A `-e`/`-E` one-liner was present AND every one passed [`perl_code_is_safe`].
    Inspectable,
    /// No readable one-liner: either the code is a script FILE operand, or it used identifiers
    /// outside the modeled vocabulary. Both are arbitrary execution.
    Opaque,
}

/// Walk `perl`'s flag grammar. `None` when a token shape isn't modeled, so the caller worst-cases
/// rather than guessing which operands were files.
pub(crate) fn scan_perl(tokens: &[Token]) -> Option<PerlScan> {
    let mut scan = PerlScan { code: PerlCode::Opaque, in_place: false, files: Vec::new() };
    if tokens.len() == 2 && tokens[1].is_one_of(&["--version", "--help", "-v", "-V"]) {
        scan.code = PerlCode::None;
        return Some(scan);
    }

    let mut has_code = false;
    let mut code_all_safe = true;
    let mut flags_done = false;
    let mut i = 1;
    while i < tokens.len() {
        let token = &tokens[i];
        if flags_done || !token.starts_with("-") || *token == "-" {
            scan.files.push(token.as_str().to_string());
            i += 1;
            continue;
        }
        if *token == "--" {
            flags_done = true;
            i += 1;
            continue;
        }
        if token.starts_with("--") {
            i += 1;
            continue;
        }
        let flags = &token.as_str()[1..];
        // `-Mmodule` / `-Idir` glued, and their split forms, consume a value rather than an operand.
        if flags.len() > 1 && matches!(flags.as_bytes()[0], b'M' | b'm' | b'I') {
            i += 1;
            continue;
        }
        if *token == "-M" || *token == "-m" || *token == "-I" {
            i += 2;
            continue;
        }
        // Scan the cluster LEFT TO RIGHT, because both `-e` and `-i` swallow the rest of it and
        // which one wins is decided by which comes first. `-eprint` is `-e` with the code `print`;
        // `-i.bake` is `-i` with the backup suffix `.bake`; `-pie` is `-p -i` with the suffix `e`,
        // which is why it carries no code and cannot be an in-place edit of an inspected one-liner.
        // Reading the cluster as a set instead made `-i.bake` unparseable and `-eprint` opaque.
        let mut consumed_next = false;
        for (at, c) in flags.char_indices() {
            match c {
                'e' | 'E' => {
                    has_code = true;
                    let glued = &flags[at + 1..];
                    let code = if glued.is_empty() {
                        consumed_next = true;
                        tokens.get(i + 1).cloned()
                    } else {
                        Some(Token::from_raw(glued.to_string()))
                    };
                    match code {
                        Some(code) if perl_code_is_safe(&code) => {}
                        _ => code_all_safe = false,
                    }
                    break;
                }
                'i' => {
                    scan.in_place = true;
                    break;
                }
                _ => {}
            }
        }
        i += 1 + usize::from(consumed_next);
    }
    if has_code && code_all_safe {
        scan.code = PerlCode::Inspectable;
    }
    Some(scan)
}

/// The LEGACY verdict, kept at its historical answer: code-gated, `-i` refused outright, operands
/// unexamined. It is dead for `perl` itself — `commands/perl/perl.toml` declares a behavior, so
/// `engine_verdict(…).unwrap_or(legacy)` always resolves through the hook — and it stays frozen
/// precisely so the never-looser corpus gate has a stable floor to compare the engine against.
/// The engine is the one that reads operands, because it is the layer that owns locus.
pub fn is_safe_perl(tokens: &[Token]) -> bool {
    match scan_perl(tokens) {
        Some(scan) => match scan.code {
            PerlCode::None => true,
            PerlCode::Inspectable => !scan.in_place,
            PerlCode::Opaque => false,
        },
        None => false,
    }
}

pub(crate) fn dispatch(cmd: &str, tokens: &[Token]) -> Option<Verdict> {
    match cmd {
        "perl" => Some(if is_safe_perl(tokens) { Verdict::Allowed(SafetyLevel::Inert) } else { Verdict::Denied }),
        _ => None,
    }
}


#[cfg(test)]
mod tests {
    use crate::is_safe_command;

    fn check(cmd: &str) -> bool {
        is_safe_command(cmd)
    }

    safe! {
        perl_version: "perl --version",
        perl_help: "perl --help",
        perl_v: "perl -v",
        perl_big_v: "perl -V",
        perl_print_hello: "perl -e 'print \"hello\\n\"'",
        perl_say: "perl -E 'say \"hello\"'",
        perl_ne_grep: "perl -ne 'print if /pattern/' file.txt",
        perl_pe_substitute: "perl -pe 's/foo/bar/g' file.txt",
        perl_lane_field: "perl -lane 'print $F[0]' file.txt",
        perl_chomp_split_join: "perl -ne 'chomp; print join(\",\", split(/\\t/)), \"\\n\"'",
        perl_tr_transliterate: "perl -pe 'tr/a-z/A-Z/' file.txt",
        perl_begin_end_count: "perl -ne 'BEGIN{$n=0} $n++; END{print $n}'",
        perl_ne_word_pattern: "perl -ne 'print if /\\berror\\b/' log.txt",
        perl_my_variable: "perl -e 'my $x = 1; print $x'",
        perl_keys_values: "perl -e 'my %h; print keys %h'",
        perl_string_containing_system: "perl -e 'print \"system is down\\n\"'",
        perl_substitute_alternate_delim: "perl -pe 's{error_count}{warning_count}g' file.txt",
        perl_match_with_if: "perl -ne 'print if /TODO/' file.txt",
        perl_match_after_unless: "perl -ne 'print unless /^#/' file.txt",
        perl_module_flag: "perl -MList::Util -e 'print length \"test\"'",
        perl_include_flag: "perl -Ilib -e 'print \"ok\\n\"'",
        perl_inplace_worktree: "perl -i -pe 's/foo/bar/' file.txt",
        perl_inplace_backup_worktree: "perl -i.bak -pe 's/foo/bar/' file.txt",
        perl_inplace_pi_worktree: "perl -pi -e 's/foo/bar/' ./app/x.rb",
        // `-i` swallows the REST of its cluster as the backup suffix, so a suffix that happens to
        // contain an `e` is still just a suffix. Reading the cluster as a set of letters instead
        // made this unparseable.
        perl_inplace_suffix_containing_e: "perl -i.bake -pe 's/foo/bar/' file.txt",
        perl_inplace_suffix_orig: "perl -i.orig -pe 's/foo/bar/' file.txt",
        // `-e` likewise swallows the rest of its cluster, so glued code is the same request as
        // separated code and must classify the same way.
        perl_glued_code: "perl -eprint file.txt",
        perl_glued_code_with_p: "perl -peprint file.txt",
    }

    denied! {
        perl_script_file_denied: "perl script.pl",
        perl_no_e_flag_denied: "perl -n file.txt",
        perl_inplace_system_denied: "perl -i -pe 's/foo/bar/' /etc/hosts",
        perl_inplace_home_denied: "perl -i.bak -pe 's/foo/bar/' ~/.bashrc",
        perl_read_secret_denied: "perl -pe 's/foo/bar/' ~/.ssh/id_rsa",
        perl_read_system_denied: "perl -ne 'print' /etc/shadow",
        // Glued code goes through the same identifier gate as separated code.
        perl_glued_code_unsafe_denied: "perl -esystem(\"rm\") file.txt",
        // `-pie` is `-p -i` with the backup SUFFIX `e`, not `-p -i -e`. So it carries no
        // inspectable one-liner at all, and the token after it is a file rather than code.
        perl_pie_inplace_denied: "perl -pie 's/foo/bar/' file.txt",
        perl_system_denied: "perl -e 'system(\"rm -rf /\")'",
        perl_exec_denied: "perl -e 'exec(\"bad\")'",
        perl_backtick_denied: "perl -e 'print `ls`'",
        perl_qx_denied: "perl -e 'qx(ls)'",
        perl_eval_denied: "perl -e 'eval(\"bad code\")'",
        perl_open_denied: "perl -e 'open(FH, \">file\")'",
        perl_unlink_denied: "perl -e 'unlink(\"file\")'",
        perl_rename_denied: "perl -e 'rename(\"a\", \"b\")'",
        perl_mkdir_denied: "perl -e 'mkdir(\"dir\")'",
        perl_rmdir_denied: "perl -e 'rmdir(\"dir\")'",
        perl_chmod_denied: "perl -e 'chmod(0755, \"file\")'",
        perl_truncate_denied: "perl -e 'truncate(\"file\", 0)'",
        perl_substitution_eval_denied: "perl -pe 's/foo/bar/e' file.txt",
        perl_substitution_eval_global_denied: "perl -pe 's/foo/bar/ge' file.txt",
        perl_use_denied: "perl -e 'use POSIX'",
        perl_require_denied: "perl -e 'require POSIX'",
        perl_fork_denied: "perl -e 'fork()'",
        perl_socket_denied: "perl -e 'socket(S, 2, 1, 0)'",
        perl_system_trailing_help_denied: "perl -e 'system(\"rm\")' --help",
        perl_system_trailing_version_denied: "perl -e 'system(\"rm\")' --version",
        // Double-quote INTERPOLATION executes code — the string-stripping bypass class.
        perl_interp_arrayref_system: "perl -e 'print \"@{[system(q(id))]}\"'",
        perl_interp_scalarref_system: "perl -e 'print \"${\\ system(q(id))}\"'",
        perl_interp_backtick: "perl -e 'print \"@{[`id`]}\"'",
        perl_interp_hash_subscript: "perl -e 'print \"$h{`id`}\"'",
        perl_interp_array_subscript: "perl -e 'print \"$a[`id`]\"'",
    }
}