rajamesandClaude Opus 5.5
c1bbcaaba4
- Each entry's flags cell also holds v3's four fields: denied, pinned, mode and a 16-bit TTL. - compile.v4: INTERPRET checks every word it is about to execute or compile -- recheck at TTL 0, else count down; a denied word is refused with v3's line, the stack emptied and the line ended. - capsule/acl.v4: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@ ACL-WORD-ID, and ACL-HOOK. - capsule/ACL.fth: v3's ACL.4th as FORTH source the node compiles; loading it switches access control on. - v3 checks every execution, inside definitions too. v4's code is native, so it checks a word when it is compiled as well as when interpreted; a call compiled while the word was allowed is not checked again. DECOMPOSITION.md 5.20 says so. - ACL-HEAT@ is 0 until heat is readable (D-6). - tests/test_host_quit.c: seven transcripts of the v3 binary; the policy file loaded and exercised; COLD. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
84 lines
3.1 KiB
Plaintext
84 lines
3.1 KiB
Plaintext
\ acl.v4 -- word-level access control: the fields of an entry.
|
|
\
|
|
\ DECOMPOSITION.md 5.20, as v3: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
|
|
\ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
|
|
\ ACL-WORD-ID. These are all the capsule does itself; the policy -- what is
|
|
\ strict, how long a TTL is, what is pinned -- is FORTH source, ACL.fth, as
|
|
\ it is ACL.4th in v3. The fields and the check are described in
|
|
\ compile.v4. Rests on compile.v4, quit.v4 and system.v4.
|
|
\
|
|
\ An xt of 0 is an error (code 16, "Not a word"). A pinned word's fields are
|
|
\ not changed by the ! words: they do nothing, as in v3.
|
|
\
|
|
\ Constants the loader supplies:
|
|
\ (ACL-HOOK) word address of the variable: the xt of the recheck word, or 0
|
|
|
|
\ ( xt -- xt ) refuse 0
|
|
: (ACL-XT) if NULL ; NULL: drop NODE-ERROR b! 16 !b 0 ;
|
|
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
|
|
: (PINNED) -3 + a! @ 64 and ;
|
|
|
|
header ACL-HOOK inline : ACL-HOOK' (ACL-HOOK) ;
|
|
|
|
header ACL-MODE@
|
|
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
|
|
header ACL-TTL@
|
|
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
|
|
header ACL-ALLOW@
|
|
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
|
|
header ACL-PINNED?
|
|
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
|
|
header ACL-PIN
|
|
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
|
|
|
|
header ACL-MODE!
|
|
: ACL-MODE! ( mode xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop 255 and 8* @ -65281 and + ! ;
|
|
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
|
|
header ACL-TTL!
|
|
: ACL-TTL! ( n xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop
|
|
-if POS drop 0 jump SET
|
|
POS: dup -65536 and if SMALL drop drop 65535 jump SET
|
|
SMALL: drop
|
|
SET: 8* 8* @ 65535 and + ! ;
|
|
header ACL-ALLOW!
|
|
: ACL-ALLOW! ( flag xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop if DENY drop @ -33 and ! ;
|
|
DENY: drop @ 32 OR ! ;
|
|
|
|
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
|
|
\ is 0 and it is allowed. This is the one word that unpins.
|
|
header ACL-INHERIT
|
|
: ACL-INHERIT
|
|
(ACL-XT) SWAP (ACL-XT) \ dst src
|
|
-3 + a! @ $FF00 and \ dst mode
|
|
SWAP -3 + a! @ 255 and -97 and + ! ; \ the five flags, nothing else
|
|
|
|
\ ( xt -- ) every entry from xt back that is not pinned: TTL mode, TTL 0,
|
|
\ allowed
|
|
: (ACL-INIT)
|
|
L: if DONE
|
|
dup (PINNED) if FREE drop jump NXT
|
|
FREE: drop @ 31 and !
|
|
NXT: -1 + a! @ jump L
|
|
DONE: drop ;
|
|
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
|
|
header ACL-INIT-PRIMITIVES
|
|
: ACL-INIT-PRIMITIVES
|
|
(LATEST) a! @ (ACL-INIT)
|
|
VOC-LINK a! @
|
|
V: if DONE dup a! @ (ACL-INIT) 1 + a! @ jump V
|
|
DONE: drop ;
|
|
|
|
\ ( xt -- heat ) how often the word has been used. The node's heat
|
|
\ counters are not readable from a programme yet (D-6): 0.
|
|
header ACL-HEAT@
|
|
: ACL-HEAT@ (ACL-XT) drop 0 ;
|
|
\ ( xt -- n ) a number for the word that never changes: its address
|
|
header ACL-WORD-ID
|
|
: ACL-WORD-ID (ACL-XT) ;
|