diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 55bd9361..2dc5a47d 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -179,7 +179,7 @@ definition below depends on one, it says so. | **D-15** | Division by zero in `/` `MOD` `/MOD` `*/` `*/MOD` `M/MOD` (ruled 2026-10-04). | **Guarded: the word reports it and the line ends.** Each of these words tests its divisor before anything else. If it is zero the word prints v3's message, its own name and `: Division by zero`, takes its operands off the stack as v3 does, ends any definition that was open, prints ` ERROR` and returns to the prompt, from however deep; its caller is not returned to. `M/MOD` says so too, where v3 printed ` ERROR` alone. Source in `v4/capsule/forth.v4`; executed on the golden model's host node (2026-10-04), including transcripts of the v3 binary. `Q./` keeps D-11 (saturate and flag). `UM/MOD` and `SM/REM` are internal and unguarded: their callers have checked. What a mesh node, with no console, does on a zero divisor comes with the mesh (step 2); §4's definitions, which the mesh-node tests execute, still leave it unspecified. | | **D-16** | Stack overflow and underflow; `DEPTH`, `PICK`, `ROLL` (ruled 2026-10-04; revises D-2). | **Guarded: a stack fault.** Each stack counts what it holds. Before every opcode the node checks that the stacks hold what the opcode takes — including a `T` or `S` it only reads — and have room for what it leaves. If not, the opcode does nothing and the node faults exactly as for a bad address (D-14), to that kind's handler: `Stack overflow`, `Stack underflow`, `Return stack overflow`, `Return stack underflow`, then ` ERROR` and the prompt. **Every fault, D-14's included, empties both stacks**: the handler does not return, and what a word stopped part-way has left on the data stack is of no use to its caller. (v3 keeps what the failing word had not taken, and names the word: `DROP: Stack underflow`.) The fault handler is a table of five words, one per kind, each a jump (`(FAULTS)` in `v4/capsule/quit.v4`). Two registers (§7) are all a programme sees of the stacks: `DSTACK-DEPTH` and `RSTACK-DEPTH` read as the depth, and a store to one empties that stack. There is still no stack pointer and no address for a stack cell, so `SP@` and `SP!` stay retired; `.S` waits for number output to reach the capsule. The sizes were unchanged by this ruling, 10 and 9 (D-17 then deepens the host node's): one more value, or one more level of call, is now an error message where it used to be silent corruption. Executed on the golden model (2026-10-04): `tests/test_exec.c` for every opcode at every depth of both stacks, `tests/test_host_quit.c` from the prompt. | | **D-17** | Stack sizes on the host node (2026-10-04, following D-16). | **32 values and 32 return entries on the host node; a mesh node keeps the F18's 10 and 9.** Once the stacks are counted (D-16) their size is a parameter of the node, like its memory, and the host node is the one that runs the interpreter and the compiler underneath the user's programme: at 10 and 9 the prompt left a programme about six values, and `/` could be used only four words deep. The mechanism is the same at both sizes — top registers over a ring — and so is every word's definition. v3's stacks are deeper still. In the golden model the sizes are `V4_DATA_RING` and `V4_RET_RING` (`stack.h`), set for the host-node tests in `v4/Makefile`. | -| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 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`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. | +| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 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`, 16 `Not a word`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. | | **D-19** | Block storage on the golden model (2026-10-05). | **Four memory-mapped registers on the host node, until the mesh carries the storage service.** `BLOCK-NUMBER`, `BLOCK-ADDRESS` (the word address of 256 cells), `BLOCK-COMMAND` (a store of 1 reads the block into those cells, 2 writes it from them) and `BLOCK-STATUS` (0 when the command worked, −1 for a block the device has not got or cells not all in memory). A block is 1024 bytes: 256 cells, four bytes to a cell, the first byte lowest, at either cell width. This is the console's arrangement (§7) applied to storage; like it, it is the model's stand-in and not the mesh protocol, which §5.11 still leaves to the device node. | **Consequences of D-2 that every definition must respect.** The data stack holds 10 items and the @@ -760,7 +760,7 @@ call would bury what it works on. A **compile-only** word may not be executed by `v4/capsule/forth.v4` holds the first words of the vocabulary flagged this way (`DUP`, `+`, `>R`, `I`, `LEAVE`, `@`, the in-line variables and so on). -**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`, `COLD`, `DEFER`), then the two files of FORTH source the node compiles itself, `editor.fth` and `tools.fth` (`SEE`); `blocks.v4` (mass storage and `LOAD`), `log.v4` (logging), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top. +**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`, `COLD`, `DEFER`), then the two files of FORTH source the node compiles itself, `editor.fth`, `tools.fth` (`SEE`) and `ACL.fth` (the access control policy); `blocks.v4` (mass storage and `LOAD`), `log.v4` (logging), `acl.v4` (access control), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top. **The stacks and the compiler.** The interpreter and compiler run on the same stacks as the user's words, with the user's values beneath them. The capsule was written for stacks of ten cells and nine @@ -876,11 +876,37 @@ index should use them; they cost one instruction per iteration. ### 5.20 Word-level ACL +On the host node, as v3 has it at its prompt (2026-10-05). Source in `v4/capsule/acl.v4` (the fields), +`compile.v4` (the check) and `ACL.fth` (the policy, FORTH source, which is v3's `capsules/ACL.4th`). +Executed on the golden model's host node against transcripts of the v3 binary. Between nodes, access control +is still the router's and Hera's (§6); nothing here decides that. + +**The fields.** Each entry's flags cell (§5.13) also holds: bit 5 *denied*, bit 6 *pinned*, 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. v3's TTL is 32 bits; its own policy never sets more than 65535, which is the most 16 bits +hold. + +**The check.** `INTERPRET` runs it on every word it is about to execute or compile: if the TTL is 0 the word +is rechecked, otherwise the TTL is counted down; then a denied word is refused with v3's line — +`WARN: ACL: denied 'xxx'` — the data stack emptied and the line ended. The recheck is the word whose address +is in the variable `ACL-HOOK`; with none there, the word is allowed and given the longest TTL. `ACL.fth` puts +its `ACL-RECHECK` there (v3 finds it by name each time). + +**Where this is weaker than v3.** v3's inner interpreter checks every execution, inside definitions too. v4 +code is native: a compiled call goes straight to its word, and no opcode asks permission. 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 when it runs. Closing that needs +the check in the node itself (the `call` opcode), which is a hardware decision and is not taken here. + | Word | Fate | Notes | | --- | --- | --- | -| `ACL-MODE@` `ACL-MODE!` `ACL-TTL@` `ACL-TTL!` `ACL-ALLOW@` `ACL-ALLOW!` `ACL-PINNED?` `ACL-PIN` `ACL-INHERIT` `ACL-INIT-PRIMITIVES` | HERA | Hera holds the ACL table. In the fabric, per-message ACL checks happen in the router (§6). | -| `ACL-HEAT@` | MM | | -| `ACL-WORD-ID` | CC | | +| `ACL-MODE@` `ACL-MODE!` `ACL-TTL@` `ACL-TTL!` `ACL-ALLOW@` `ACL-ALLOW!` `ACL-PINNED?` `ACL-PIN` | CAP | As v3, on an xt. The `!` words do nothing to a pinned word. `ACL-TTL!` takes a negative count as 0 and one above 65535 as 65535; `ACL-MODE!` keeps the low byte. An xt of 0 is D-18's code 16, `Not a word`. | +| `ACL-INHERIT` | CAP | `( src dst -- )`, as v3: `dst` takes `src`'s mode, is unpinned, allowed, TTL 0. The one word that unpins. | +| `ACL-INIT-PRIMITIVES` | CAP | As v3: every word that is not pinned, in every vocabulary, back to TTL mode, TTL 0, allowed. | +| `ACL-HEAT@` | MM | `( xt -- heat )`. The node's heat counters are not readable from a programme yet (D-6): 0, so `ACL.fth` gives every word its base TTL of 256. | +| `ACL-WORD-ID` | CC | `( xt -- n )`: a number for the word that never changes. Here that is its address. | +| `ACL-HOOK` | CAP | Variable: the xt of the recheck word, or 0. Not in v3. | +| `ACL-STRICT` `ACL-TTL-MODE` `ACL-TTL-COMPUTE` `ACL-RECHECK` `ACL-BOOT` `ACL-ENTRY` `HERMES-CHANNEL-OPEN?` and the constants | CC | `ACL.fth`: v3's policy file, word for word but for `ACL-BOOT`, which pins only the words v4 has (`EXEC` and `BYE` are not on this node) and sets `ACL-HOOK`. Loading the file runs `ACL-BOOT`; a system that does not load it has no access control. `COLD` removes it. | ### 5.21 Physics: benchmark and diagnostics diff --git a/v4/capsule/ACL.fth b/v4/capsule/ACL.fth new file mode 100644 index 00000000..da1a55a1 --- /dev/null +++ b/v4/capsule/ACL.fth @@ -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 diff --git a/v4/capsule/acl.v4 b/v4/capsule/acl.v4 new file mode 100644 index 00000000..1f685001 --- /dev/null +++ b/v4/capsule/acl.v4 @@ -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) ; diff --git a/v4/capsule/compile.v4 b/v4/capsule/compile.v4 index d7e972eb..a00e6255 100644 --- a/v4/capsule/compile.v4 +++ b/v4/capsule/compile.v4 @@ -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 diff --git a/v4/capsule/core.v4 b/v4/capsule/core.v4 index 23d26bdb..4fc67003 100644 --- a/v4/capsule/core.v4 +++ b/v4/capsule/core.v4 @@ -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 diff --git a/v4/capsule/quit.v4 b/v4/capsule/quit.v4 index 356a2810..5ca68534 100644 --- a/v4/capsule/quit.v4 +++ b/v4/capsule/quit.v4 @@ -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 diff --git a/v4/capsule/system.v4 b/v4/capsule/system.v4 index 49320937..38165340 100644 --- a/v4/capsule/system.v4 +++ b/v4/capsule/system.v4 @@ -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 diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index f316589c..e3da8dd6 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -64,6 +64,7 @@ #define SRC (BVARS + 8) #define SRC_HOOK (BVARS + 9) #define STORAGE_REG (BVARS + 10) +#define ACL_HOOK (BUF0_W - 6) /* the xt of the access control recheck word, or 0 */ #define LOG_LEVEL (BUF0_W - 5) /* the level at or below which a message is printed */ #define BOOT_CELLS (BVARS + 14) /* (BOOT): DP and LATEST as the loader left them, 2 cells */ #define BUF0_W (BVARS - 2 * 256) /* the two block buffers, 256 cells each */ @@ -132,6 +133,7 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned v4_text_constant(tx, "(B)", BVARS); v4_text_constant(tx, "(BOOT)", BOOT_CELLS); v4_text_constant(tx, "(LOG-LEVEL)", LOG_LEVEL); + v4_text_constant(tx, "(ACL-HOOK)", ACL_HOOK); v4_text_constant(tx, "SCR", SCR); v4_text_constant(tx, "BLK", BLK); v4_text_constant(tx, "(SRC)", SRC); diff --git a/v4/tests/test_host_quit.c b/v4/tests/test_host_quit.c index 834a1cb4..5117aca6 100644 --- a/v4/tests/test_host_quit.c +++ b/v4/tests/test_host_quit.c @@ -102,6 +102,8 @@ static void boot_with(unsigned depth) n.mem[BOOT_CELLS + 1] = capsule_latest; n.mem[FENCE] = DICT_W; n.mem[LOG_LEVEL] = 2; + n.mem[ACL_HOOK] = 0; + for (v4_cell xt = capsule_latest; xt != 0; xt = n.mem[xt - 1]) n.mem[xt - 3] &= 31; /* the capsule's words: no access control fields set */ n.mem[CONTEXT] = LATEST; n.mem[CURRENT] = LATEST; n.mem[VOC_LINK] = 0; @@ -165,7 +167,11 @@ static int load_source(const char *name) size_t len = strlen(line); num++; if (len == 0 || line[len - 1] != '\n' || len > 80) { printf(" %s line %u: too long\n", name, num); fclose(f); return 0; } - if (strcmp(say(line), " ok\nok> ") != 0) { printf(" %s line %u: %s", name, num, line); printf(" -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; } + (void)say(line); + /* every line is accepted: whatever it printed, it ended with " ok" and never with ERROR */ + if (strlen(out) < 9 || strcmp(out + strlen(out) - 9, "\n ok\nok> ") != 0 || strstr(out, " ERROR\n")) { + if (strcmp(out, " ok\nok> ") != 0) { printf(" %s line %u: %s", name, num, line); printf(" -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; } + } } fclose(f); return n.mem[STATE] == 0; @@ -381,6 +387,29 @@ static const transcript script[] = { { "Q.0 Q.LOG 65 EMIT\n-1 Q.FROM-INT Q.LOG\n", "Argument out of range\n ERROR\nok> Argument out of range\n ERROR\nok> ", 0 }, { "7 PAD -1 DUMP 65 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "PAD 0 DUMP\n", " ok\nok> ", 1 }, + /* acl.v4: the fields of an entry, and the check, as v3 */ + { ": FOO 65 EMIT ; ' FOO ACL-MODE@ . ' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ .\n' FOO ACL-PINNED? .\n", "0 0 -1 ok\nok> 0 ok\nok> ", 1 }, + { ": FOO 65 EMIT ; 1 ' FOO ACL-MODE! 77 ' FOO ACL-TTL! ' FOO ACL-MODE@ .\n' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n", "1 ok\nok> 77 A76 ok\nok> ", 1 }, + { ": FOO 65 EMIT ; ' FOO ACL-PIN ' FOO ACL-PINNED? . 5 ' FOO ACL-TTL!\n0 ' FOO ACL-ALLOW! 1 ' FOO ACL-MODE!\n' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ . ' FOO ACL-MODE@ .\n", + "-1 ok\nok> ok\nok> 0 -1 0 ok\nok> ", 1 }, + { ": A 1 ; : B 2 ; 1 ' A ACL-MODE! ' A ACL-PIN ' B ACL-PIN ' A ' B ACL-INHERIT\n' B ACL-MODE@ . ' B ACL-PINNED? . ' B ACL-TTL@ . ' B ACL-ALLOW@ .\n", + " ok\nok> 1 0 0 -1 ok\nok> ", 1 }, + { "-5 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 3 ' DUP ACL-MODE! ' DUP ACL-MODE@ .\n", "0 3 ok\nok> ", 1 }, + { "' DUP ACL-TTL@ . ' DUP ACL-MODE@ . ' DUP ACL-ALLOW@ . ' DUP ACL-PINNED? .\n", "0 0 -1 0 ok\nok> ", 1 }, + { ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! 1 2 FOO 66 EMIT\n.S ' FOO ACL-TTL@ .\n", + "\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> <0> \n4 ok\nok> ", 1 }, + /* v4's own: the TTL is sixteen bits; a denied word cannot be compiled; with no policy a recheck allows */ + { ": BAZ 67 EMIT ; 0 ' BAZ ACL-ALLOW! BAZ ' BAZ ACL-TTL@ . ' BAZ ACL-ALLOW@ .\n", "C65535 -1 ok\nok> ", 0 }, + { ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! : BAR FOO ; 66 EMIT\nBAR\n' FOO ACL-TTL@ .\n", + "\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> UNKNOWN WORD: 'BAR'\n ERROR\nok> 4 ok\nok> ", 0 }, + { ": FOO 65 EMIT ; : BAR FOO ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! BAR\n", "A ok\nok> ", 0 }, + { "99999 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 65535 ' DUP ACL-TTL! ' DUP ACL-TTL@ .\n", "65535 65535 ok\nok> ", 0 }, + { "258 ' DUP ACL-MODE! ' DUP ACL-MODE@ . 0 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ .\n7 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ . ' DUP ACL-TTL@ .\n", "2 0 ok\nok> -1 0 ok\nok> ", 0 }, + { "7 0 ACL-MODE@ 65 EMIT\n0 ACL-PIN\n1 0 ACL-TTL!\n.S\n", "Not a word\n ERROR\nok> Not a word\n ERROR\nok> Not a word\n ERROR\nok> <2> 7 1 \n ok\nok> ", 0 }, + { ": W1 ; ' W1 ACL-WORD-ID ' W1 = . ' W1 ACL-HEAT@ .\n", "-1 0 ok\nok> ", 0 }, + { ": IM 65 EMIT ; IMMEDIATE 3 ' IM ACL-TTL! 0 ' IM ACL-ALLOW! : U IM ;\n", "\033[33mWARN: \033[0mACL: denied 'IM'\n ERROR\nok> ", 0 }, + { ": P1 ; : P2 ; VOCABULARY VV VV DEFINITIONS : P3 ; FORTH DEFINITIONS\n9 ' P1 ACL-TTL! 1 ' P2 ACL-MODE! ' P2 ACL-PIN VV 9 ' P3 ACL-TTL!\nACL-INIT-PRIMITIVES ' P1 ACL-TTL@ . ' P2 ACL-MODE@ . ' P3 ACL-TTL@ . FORTH\n", + " ok\nok> ok\nok> 0 1 0 ok\nok> ", 0 }, /* log.v4: v3's lines, colours and all, without its time of day */ { "LOG-LEVEL@ . LOG-ERROR . LOG-WARN . LOG-INFO . LOG-TEST . LOG-DEBUG .\n", "2 0 1 2 3 4 ok\nok> ", 1 }, @@ -578,8 +607,8 @@ int main(void) printf("v4 host prompt tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS); { - static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4", "log.v4" }; - CHECK(host_load(&tx, &n, files, 13), "the capsule assembles"); + static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4", "log.v4", "acl.v4" }; + CHECK(host_load(&tx, &n, files, 14), "the capsule assembles"); } CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx)); CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space"); @@ -1100,6 +1129,28 @@ int main(void) CHECK(is(say("SEE NOSUCH\n"), "SEE: not found\n ok\nok> ") && is(say("SEE\n"), "SEE: not found\n ok\nok> "), "a word that is not there"); CHECK(is(say("(.\")\n"), "(.\"): compile-only\n ERROR\nok> ") && is(say("(S\")\n"), "(S\"): compile-only\n ERROR\nok> "), "the string run-time words have names but cannot be run from the prompt"); + /* ---- access control with its policy loaded: ACL.fth, FORTH source ---- */ + boot_bare(); + CHECK(load_source("ACL.fth"), "ACL.fth compiles, every line of it"); + CHECK(strstr(out, "\033[32mINFO: \033[0mACL: active\n") == out && n.mem[ACL_HOOK] != 0, "and its last line switches access control on"); + CHECK(is(say(": FOO 65 EMIT ; FOO ' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n"), "A256 A255 ok\nok> "), "a word's first use is rechecked and earns it a TTL, which is then counted down"); + CHECK(is(say(": SFOO 66 EMIT ; ' SFOO ACL-STRICT SFOO SFOO ' SFOO ACL-TTL@ .\n"), "BB0 ok\nok> ") && is(say("' SFOO ACL-MODE@ .\n"), "1 ok\nok> "), + "a strict word is rechecked every time: its TTL stays 0"); + CHECK(is(say("' SFOO ACL-TTL-MODE SFOO ' SFOO ACL-TTL@ . ' SFOO ACL-MODE@ .\n"), "B256 0 ok\nok> "), "and can be put back in TTL mode"); + CHECK(is(say("' ACL-RECHECK ACL-PINNED? . ' ACL-BOOT ACL-PINNED? .\n"), "-1 -1 ok\nok> ") && is(say("' ACL-INIT-PRIMITIVES ACL-PINNED? .\n"), "-1 ok\nok> "), + "the policy's own words are pinned"); + CHECK(is(say("0 ' ACL-RECHECK ACL-ALLOW! ' ACL-RECHECK ACL-STRICT ' ACL-RECHECK ACL-ALLOW@ .\n"), "-1 ok\nok> ") + && is(say("' ACL-RECHECK ACL-MODE@ . FOO\n"), "0 A ok\nok> "), "so they cannot be denied or changed"); + CHECK(is(say("0 ' FOO ACL-ALLOW! 67 EMIT FOO 68 EMIT\n"), "C\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> "), "a denied word is refused while its TTL lasts"); + CHECK(is(say("0 ' FOO ACL-TTL! FOO\n"), "A ok\nok> "), "and when its TTL runs out the policy is asked again: this one allows"); + CHECK(is(say(": NOFOO DUP ['] FOO = IF 0 SWAP ACL-ALLOW! ELSE ACL-RECHECK THEN ;\n"), " ok\nok> ") + && is(say("' NOFOO ACL-HOOK ! 0 ' FOO ACL-TTL!\n"), " ok\nok> "), "a policy that denies one word"); + CHECK(is(say("69 EMIT FOO\n"), "E\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ") && is(say("SFOO : G FOO ;\n"), "B\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ") + && is(say("1 2 + . SFOO\n"), "3 B ok\nok> "), "that word is refused, interpreted or compiled, and nothing else is"); + CHECK(is(say("1 2 HERMES-CHANNEL-OPEN? . ACL-CA-KEY-LO . ' DUP ACL-ENTRY ' DUP = .\n"), "1 0 -1 ok\nok> "), "the rest of v3's policy file is there"); + CHECK(is(say("COLD\n"), "FORTH-79 Cold Start\nSystem initialized.\n ok\nok> ") && n.mem[ACL_HOOK] == 0 && is(say("ACL-BOOT\n"), "UNKNOWN WORD: 'ACL-BOOT'\n ERROR\nok> "), + "COLD takes the policy away with everything else that was loaded"); + /* ---- the small system words ---- */ boot_bare(); CHECK(is(say("79-STANDARD .S\n"), "<0> \n ok\nok> "), "79-STANDARD is satisfied, and says nothing");