feat(v4.0.0): word-level access control at the prompt, as v3

- 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>
2026-10-05 11:58:43 -04:00
parent 384a6c1cd2
commit c1bbcaaba4
9 changed files with 275 additions and 14 deletions
@@ -0,0 +1,57 @@
+\ ACL.fth -- word-level access control: the policy.
+\
+\ This is v3's capsules/ACL.4th, as FORTH source the node compiles itself.
+\ The capsule supplies the fields of an entry and the check (acl.v4,
+\ compile.v4); what is strict, how long a TTL lasts and what is pinned is
+\ decided here.  Loading this file switches access control on: its last
+\ line runs ACL-BOOT.  A system that does not load it has none.
+\
+\ The xt these words take is what FIND and ['] give: the word's code.
+
+FORTH DEFINITIONS
+
+1 CONSTANT ACL-STRICT-MODE
+0 CONSTANT ACL-TTL-MODE-VAL
+\ the TTL of a cold word, tuned 2026-06-15 on v3
+256 CONSTANT ACL-BASE-TTL
+65535 CONSTANT ACL-MAX-TTL
+
+\ ( xt -- xt )  for symmetry: the xt is the entry
+: ACL-ENTRY ;
+
+: ACL-STRICT ( xt -- )
+  DUP ACL-PINNED? IF DROP EXIT THEN  ACL-STRICT-MODE SWAP ACL-MODE! ;
+: ACL-TTL-MODE ( xt -- )
+  DUP ACL-PINNED? IF DROP EXIT THEN  ACL-TTL-MODE-VAL SWAP ACL-MODE! ;
+
+\ ( xt -- ttl )  a hotter word earns a longer TTL: heat/4 + 256, at most 65535
+: ACL-TTL-COMPUTE  ACL-HEAT@ 4 / ACL-BASE-TTL + ACL-MAX-TTL MIN ;
+
+\ ( xt -- )  what the check runs when a word's TTL is 0.
+\ STRICT: allow, and leave the TTL 0 so that every use comes back here.
+\ TTL: compute a TTL from the word's heat; allow.
+: ACL-RECHECK
+  DUP ACL-PINNED? IF DROP EXIT THEN
+  DUP ACL-MODE@ ACL-STRICT-MODE = IF
+    1 OVER ACL-ALLOW!  0 OVER ACL-TTL!  DROP EXIT
+  THEN
+  DUP ACL-TTL-COMPUTE OVER ACL-TTL!  1 SWAP ACL-ALLOW! ;
+
+\ the system CA's public key; placeholders, as in v3
+0 CONSTANT ACL-CA-KEY-LO
+0 CONSTANT ACL-CA-KEY-HI
+
+\ ( req-hi req-lo -- allow? )  the fabric asks this word whether a channel
+\ may be opened.  The default approves every request; a policy edits this.
+: HERMES-CHANNEL-OPEN?  2DROP 1 ;
+
+\ ( -- )  default fields on every word; the words that enforce the policy
+\ pinned; the recheck switched on
+: ACL-BOOT
+  ACL-INIT-PRIMITIVES
+  ['] ACL-RECHECK ACL-PIN  ['] ACL-INIT-PRIMITIVES ACL-PIN
+  ['] ACL-RECHECK ACL-HOOK !
+  LOG-INFO" ACL: active" ;
+' ACL-BOOT ACL-PIN
+
+ACL-BOOT
@@ -0,0 +1,83 @@
+\ 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) ;
@@ -99,6 +99,47 @@ macro ROT   push SWAP pop SWAP   endmacro
  dup -3 + a! @ 8 and if CALL  drop jump (INLINE,)
  CALL: drop jump (CALL,)

+\ ---- access control (5.20) -------------------------------------------------------
+\ Each entry's flags cell also holds its access control fields:
+\   bit 5 (32)      denied: the word may not be used
+\   bit 6 (64)      pinned: the fields cannot be changed
+\   bits 8 .. 15    the mode: 0 TTL, 1 STRICT
+\   bits 16 .. 31   the TTL, a count of uses left before the next recheck
+\ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0.
+\
+\ (ACL?) is run by INTERPRET for every word it is about to execute or
+\ compile.  As v3: if the TTL is 0 the word is rechecked, otherwise the TTL
+\ is counted down; then a denied word is refused.  The recheck is the word
+\ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded --
+\ and with none there the word is allowed and given the longest TTL.
+\
+\ v3 checks every execution, inside definitions too.  v4 code is native: a
+\ compiled call goes straight to its word.  So v4 checks a word when it is
+\ compiled as well as when it is interpreted -- a denied word cannot be
+\ built into anything new -- but a call compiled while the word was allowed
+\ is not checked again.
+
+\ ( xt -- )   recheck
+: (ACL-RECHECK)
+  (ACL-HOOK) a! @ if NONE  push ex           \ call it with the xt
+  ;
+  NONE: drop  -3 + a! @  65535 and -33 and  $FFFF0000 + ! ;
+
+\ ( xt -- xt )   as above; a denied word ends the line
+: (ACL?)
+  dup -3 + a! @                              \ xt flags
+  dup $FFFF0000 and if ZERO
+    drop  -65536 + !  jump TEST              \ one use fewer
+  ZERO: drop drop  dup (ACL-RECHECK)
+  TEST: dup -3 + a! @ 32 and if OK
+  drop drop
+  $33335B1B (EMIT4) $6D (EMIT4)  $4E524157 (EMIT4) $203A (EMIT4)  $6D305B1B (EMIT4)                 \ v3's line: WARN: in yellow
+  $3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4)
+  (.WORD)  39 EMIT CR
+  DSTACK-DEPTH b! a !b                       \ as v3, the stack is emptied
+  pop drop  jump (ABANDON)
+  OK: drop ;
+
 \ ( -- )   print the word WORD has just left
 : (.WORD)   WBUF COUNT jump TYPE

@@ -147,13 +188,13 @@ header INTERPRET
     dup -3 + a! @                           \ xt flags
     STATE a! @ if INTERP
       drop  1 and if COMP                   \ compiling: immediate words still run
-       drop EXECUTE  jump L
-       COMP: drop (COMPILE,)  jump L
+       drop (ACL?) EXECUTE  jump L
+       COMP: drop (ACL?) (COMPILE,)  jump L
     INTERP: drop  16 and if RUN
       drop drop  (.WORD)                    \ ": compile-only"
       $6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR
       jump (ABANDON)
-       RUN: drop EXECUTE  jump L
+       RUN: drop (ACL?) EXECUTE  jump L
  NUM: drop  (NUM?) if BAD
       drop
       STATE a! @ if KEEP  drop (LIT,)  jump L
@@ -17,7 +17,7 @@
 \    9 Shift count out of range      10 Protected word
 \   11 Division by zero (Q./)        12 Argument out of range
 \   13 Block out of range            14 No block is being loaded
-\   15 Deferred word not set
+\   15 Deferred word not set         16 Not a word
 \   -1 the word has printed its own message

 macro SWAP   over push push drop pop pop   endmacro
@@ -99,7 +99,7 @@ header ABORT
  POS: -1 + if M1  -1 + if M2  -1 + if M3  -1 + if M4
       -1 + if M5  -1 + if M6  -1 + if M7  -1 + if M8  -1 + if M9
       -1 + if M10  -1 + if M11  -1 + if M12  -1 + if M13  -1 + if M14
-       -1 + if M15
+       -1 + if M15  -1 + if M16
       drop  2 jump (REPL)
  M1: drop  $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR  2 jump (REPL)
  M2: drop  $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR  2 jump (REPL)
@@ -116,6 +116,7 @@ header ABORT
  M13: drop  $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR  2 jump (REPL)
  M14: drop  $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR  2 jump (REPL)
  M15: drop  $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR  2 jump (REPL)
+  M16: drop  $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR  2 jump (REPL)

 \ The table the loader gives the node: six words, one for each kind of
 \ fault in the node's order, each a jump.  A jump fills its word, so they
@@ -141,7 +141,7 @@ header COLD
  (BOOT)+1 a! @  (LATEST) a! !
  (BOOT) a! @ 2/ 2/  FENCE a! !
  (LATEST) CONTEXT a! !  (LATEST) CURRENT a! !  0 VOC-LINK a! !
-  10 BASE a! !  0 SCR a! !  2 (LOG-LEVEL) a! !  EMPTY-BUFFERS
+  10 BASE a! !  0 SCR a! !  2 (LOG-LEVEL) a! !  0 (ACL-HOOK) a! !  EMPTY-BUFFERS
  $54524F46 (EMIT4) $39372D48 (EMIT4) $6C6F4320 (EMIT4) $74532064 (EMIT4) $747261 (EMIT4) CR
  $74737953 (EMIT4) $69206D65 (EMIT4) $6974696E (EMIT4) $7A696C61 (EMIT4) $2E6465 (EMIT4) CR
  jump ABORT