NAME

MCP::Client::Policy::Floor - the danger floor: a fixed, auditable set of rules for the operations that are dangerous no matter who asked

DESCRIPTION

The danger floor is a permission posture no preset relaxes: the handful of operations that destroy work, hand over the machine, or let the agent edit its own permissions. It is deliberately a plain rule list plus a few named predicates — never a classifier — so it can be read, tested and reasoned about line by line.

Two pieces plug into a MCP::Client::Policy:

• danger-floor(...) returns the rules, in the ordinary MCP::Client::Policy::Rules schema. Prepend them to a policy's rules (they are just data). Most are expressible as command/args matches; the few that need to look at what a command targets carry a check.

• floor-checks(...) returns the checks map those check rules name — the target analysis for rm, and the shell-redirect analysis for writes to protected files. These are code, passed to the policy as checks.

The split

Almost everything asks (grantable, but the prompt is shown in red because each rule carries severity => 'danger' and a note saying why). Only two things are a hard deny that even the bypass preset cannot waive: a recursive delete of the filesystem root or your home directory, and a write to the agent's own policy/config. Everything else — force-pushes, reset --hard, sudo, curl | sh, shutdown, dd — is a red ask.

What the floor leaves to the sandbox

The write checks are lexical and best-effort: they resolve ~, ~user and .., and read both redirection targets and path arguments (so tee, cp and sed -i are caught as well as >). Three shapes they deliberately do not catch, because the target is not knowable lexically, are left to the OS sandbox layer (which makes $SADNA_HOME read-only): a redirect to an unreadable variable (> $CFG), a purely relative path (no working directory to measure from), and a glob whose expansion is unknown (> ~/.sadna/conf* — the literal prefix is under the config dir, but the decomposer drops the whole word once any part of it expands). The floor is the approval layer; the sandbox is the containment layer, and the two are meant to be composed.

Every spelling of a path

The floor only ever denies or asks, so where a path could be read two ways it takes both, and a target that matches on either reading is caught. On every host — the strings are what is compared, not the disk — it understands:

• drive paths with either separator (C:\Users\me, c:/users/ME), UNC shares (\\server\share\x, //server/share/x), Git Bash's /c/… for drive C, and a drive-less \x or /x on the home's drive;

• an admin share as the drive it is, whatever the host is called: \\localhost\C$\Users\me, \\127.0.0.1\c$\… and the machine's own name are all C:\Users\me;

• the paths that skip Windows' own normalisation: \\?\C:\…, \\.\C:\…, //?/C:/… and \\?\UNC\server\share\… are the drive or share they name, and a \\?\Volume{…} or \\?\GLOBALROOT\… path, whose volume the floor cannot place, is taken to be on any volume;

• names as NTFS reads them: case-folded, a trailing dot or space dropped, an alternate-data-stream suffix ignored, and an 8.3 short name (SADNA~1, ME~1) matched against every long name it could have been given;

• a backslash in a path with no Windows volume both ways — as the separator it is on Windows and as the filename character it is on POSIX — so /home/me/.sadna/agents/x\..\..\..\..\evil.md is still a write inside .sadna.

A home is often spelt more than one way on Windows (%USERPROFILE%, %HOMEDRIVE%%HOMEPATH%, a Git Bash HOME), so home may be a list, and every spelling in it is protected.

What the floor does not chase is an alias somebody made: a symbolic link, a junction, a subst or mapped drive, a share pointing somewhere other than a drive root. Those are the OS sandbox's to contain, as the shapes above are.

SYNOPSIS

use MCP::Client::Policy;
use MCP::Client::Policy::Floor;

my $home  = %*ENV<HOME>;
my $sadna = "$home/.sadna";

my $policy = MCP::Client::Policy.new(
    :$provider,
    rules  => [ |danger-floor(:$home, sadna-home => $sadna), |@my-rules ],
    checks => floor-checks(:$home, sadna-home => $sadna),
);

• segments compare case-folded -- the shell's targets are the LOCAL # filesystem, case-insensitive on macOS and Windows; # =item a segment compares as NTFS reads it: a trailing dot or space dropped # (`.sadna.` IS `.sadna`), an alternate-data-stream suffix ignored # (`config.json:x` writes into `config.json`), and an 8.3 short name taken # for any long name it could have been given (`SADNA~1` for `.sadna`); # =item on a Windows drive, two more spellings of the same place count: the # MSYS/Git Bash `/c/Users/me` for `C:\Users\me`, and a drive-less `/Users/me` # or `\Users\me`, which Windows resolves on the current drive; # =item a volume the floor could not place (`*`: a `\\?\Volume{…}` or a # `\\?\GLOBALROOT\…` path) may be any volume. my sub same-place-under(%dir, %in --> Bool:D) { for (%in, |windows-spellings(%in, %dir)) -> %p { next unless same-volume(%p<volume>, %dir<volume>); my @d = %dir<segs>.list; my @p = %p<segs>.list; return True if @p.elems >= @d.elems && segments-match(@d, @p.head(@d.elems)); } False; }

• an admin share -- `\\host\C$\x`, any host, since the floor cannot tell # this machine's names from another's -- is drive C too; # =item `\\?\` and `\\.\` (either slash) skip Win32's normalisation: before a # drive or `UNC\host\share` they are that drive or share, and before a # `Volume{…}` GUID or any other device name (`GLOBALROOT\Device\…`) the # volume is `*` -- and, since the floor cannot tell how much of a device # name the volume takes, every split of it is a reading. Win32 hands such a # path over without collapsing its `..`, so the uncollapsed reading is kept # too. # # :posix reads the token as POSIX does: only `/` separates, and nothing names a # Windows volume. my sub read-path(Str:D $token, $home, Bool :$posix --> List:D) { my $sep = $posix ?? rx{ '/' } !! SEP; my Str $home-base = ($home ~~ Str:D && $home.chars) ?? $home.split(SEP).grep(*.chars).tail !! Str; my Str $user-home = $home-base.defined ?? '~' ~ $home-base !! Str; my sub sep-at(Int:D $at --> Bool:D) { $token.chars > $at && so $token.substr($at, 1) ~~ $sep }