Compare commits

..

4 Commits

Author SHA1 Message Date
8b5191c8bf Phase 1+2: DRule regular chains + compileAction returns [Value]
- compileAction now returns Maybe [Value] (single-element lists for all
  existing verdicts); armToRuleValues updated accordingly
- programToValue emits one regular chain declaration per DRule (no
  hook/type/prio/policy fields), placed after policy chains
- CompileEnv promoted to a record (Env) carrying envDecls and a stub
  envCtMarks field (populated in Phase 4)
- All callers of compileAction threaded through new Env type
2026-05-04 21:50:42 -07:00
e584d9ac2d examples: update router.fwl to new grammar (portforward/masquerade, compact hook syntax) 2026-05-04 21:15:27 -07:00
6d96e2d159 crazy mega refactor 2026-05-04 03:16:40 -07:00
55c1d347e6 doc: update grammar spec and AGENTS.md for v2 design decisions
- policyDecl: replace verbose on{hook,table,priority} block with
  compact `hook <Hook> [priority <P>]` syntax; table is inferred
  from hook, priority defaults to canonical value for that hook
- Add portforwardDecl and masqueradeDecl top-level declarations
- Add implicit injection rules for stateful/loopback/ndp to
  compiler behaviour section (MVP; importable builtins deferred)
- Remove nat_prerouting / nat_postrouting from canonical policy
  example (replaced by portforward/masquerade declarations)
- Update reserved keywords: add portforward, masquerade, hook (was
  already reserved), priority (was already reserved); remove table
  as a reserved word since it no longer appears in policyDecl
- AGENTS.md: update architecture notes, reserved-words rule, and
  boundaries to reflect new declarations and compiler synthesis
2026-05-04 02:15:58 -07:00
14 changed files with 1224 additions and 765 deletions

105
AGENTS.md
View File

@@ -10,9 +10,9 @@ Stack: GHC 9.10.3, Cabal, Parsec 3.x, Aeson 2.x, Tasty/HUnit for tests.
```bash ```bash
cabal build # build everything cabal build # build everything
cabal test # run all test suites cabal test # run all test suites
cabal run fwlc -- check examples/router.fwl # parse + type-check a source file cabal run fwlc -- check examples/simple-router.fwl # parse + type-check a source file
cabal run fwlc -- compile examples/router.fwl # emit nftables JSON to stdout cabal run fwlc -- compile examples/simple-router.fwl # emit nftables JSON to stdout
cabal run fwlc -- pretty examples/router.fwl # pretty-print the parsed AST cabal run fwlc -- pretty examples/simple-router.fwl # pretty-print the parsed AST
``` ```
Run tests before marking any task complete. The test suite is `cabal test`. Run tests before marking any task complete. The test suite is `cabal test`.
@@ -25,22 +25,24 @@ Run tests before marking any task complete. The test suite is `cabal test`.
fwl/ fwl/
├── AGENTS.md ├── AGENTS.md
├── doc/ ├── doc/
│ ├── proposal.md initial design document and exploration │ ├── proposal.md <- initial design document and exploration
│ ├── fwl_grammar.md authoritative grammar reference; keep in sync with Parser.hs │ ├── fwl_grammar.md <- authoritative grammar reference; keep in sync with Parser.hs
│ └── ref/ │ └── ref/
│ ├── ruleset.nft example nftables ruleset │ ├── ruleset.nft <- example nftables ruleset
│ └── ruleset.json the same example nftables ruleset in json format │ └── ruleset.json <- the same example nftables ruleset in json format
├── examples/ ├── examples/
── router.fwl canonical example; must parse and compile cleanly ── simple-router.fwl <- canonical simple example; must parse and compile cleanly
│ ├── simple-router.nft <- compiled nftables text output of simple-router.fwl
│ └── router.fwl <- full router example with WireGuard detection
├── src/FWL/ ├── src/FWL/
│ ├── AST.hs all data types; source of truth for the AST │ ├── AST.hs <- all data types; source of truth for the AST
│ ├── Lexer.hs Parsec TokenParser, reservedNames, reservedOpNames │ ├── Lexer.hs <- Parsec TokenParser, reservedNames, reservedOpNames
│ ├── Parser.hs top-level parser, all sub-parsers │ ├── Parser.hs <- top-level parser, all sub-parsers
│ ├── Pretty.hs AST FWL source (round-trip printer) │ ├── Pretty.hs <- AST -> FWL source (round-trip printer)
│ ├── TypeCheck.hs effect row checker, exhaustiveness, CIDR intervals │ ├── TypeCheck.hs <- effect row checker, exhaustiveness, CIDR intervals
│ ├── Interpret.hs evaluator + effect dispatch │ ├── Interpret.hs <- evaluator + effect dispatch
│ ├── Compile.hs AST nftables JSON (Aeson Value) │ ├── Compile.hs <- AST -> nftables JSON (Aeson Value)
│ └── Util.hs shared helpers │ └── Util.hs <- shared helpers
└── test/ └── test/
├── Main.hs ├── Main.hs
├── ParserTests.hs ├── ParserTests.hs
@@ -48,7 +50,7 @@ fwl/
└── CompileTests.hs └── CompileTests.hs
``` ```
The grammar document at `docs/grammar.md` must stay in sync with `Parser.hs` and `Lexer.hs`. The grammar document at `doc/fwl_grammar.md` must stay in sync with `Parser.hs` and `Lexer.hs`.
When changing the parser, update the grammar doc in the same commit. When changing the parser, update the grammar doc in the same commit.
--- ---
@@ -59,15 +61,29 @@ The pipeline is strictly linear with no back-edges:
``` ```
source text source text
Lexer (Text.Parsec.Token) -> Lexer (Text.Parsec.Token)
Parser [Decl] (AST.hs) -> Parser -> [Decl] (AST.hs)
TypeCheck TypedDecl -> TypeCheck -> TypedDecl
Compile Aeson Value (nftables JSON) -> Compile -> Aeson Value (nftables JSON)
``` ```
The interpreter (`Interpret.hs`) runs the policy against a mock packet environment The interpreter (`Interpret.hs`) runs the policy against a mock packet environment
and is separate from the compiler. It uses the same typed AST. and is separate from the compiler. It uses the same typed AST.
### Compiler Synthesis
These constructs are synthesised by `Compile.hs` and do not appear directly in the
nftables output as user-written rules:
| FWL construct | Synthesised nftables output |
|----------------------|-----------------------------|
| `portforward` decl | A named `map`, a `nat hook prerouting priority dstnat` chain with `fib daddr type local` guard and `dnat ip to ... map` rewrite, and a `ct status dnat accept` rule injected into every `Forward` chain in the file. |
| `masquerade` decl | A `nat hook postrouting priority srcnat` chain with `ip saddr @set masquerade` rule. |
| Filter hook policy | `ct state { established, related } accept` (stateful), `iifname "lo" accept` (loopback), and `meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept` (NDP) are prepended automatically to every `Input`, `Forward`, and `Output` chain before user-written rules. |
These injections are intentional and documented in `doc/fwl_grammar.md`. Do not remove
them without updating the grammar document and all affected tests.
--- ---
## Reserved Words Rule ## Reserved Words Rule
@@ -84,6 +100,42 @@ and expression positions without causing parse errors.
If you add a new keyword: add it to both `reservedNames` in `Lexer.hs` If you add a new keyword: add it to both `reservedNames` in `Lexer.hs`
AND use `reserved "word"` in `Parser.hs`. Never add a word to only one place. AND use `reserved "word"` in `Parser.hs`. Never add a word to only one place.
**Current reserved keywords:**
```
config interface zone import from
let in pattern flow rule policy on
case of if then else do perform
within as dynamic cidr4 cidr6
hook priority
portforward masquerade
WAN LAN WireGuard
Input Forward Output Prerouting Postrouting
Filter NAT Mangle DstNat SrcNat
Raw ConnTrack
true false
```
> `table` is **not** a reserved keyword — it was removed when `policyDecl` switched
> from the verbose `on { hook = ..., table = ..., priority = ... }` syntax to the
> compact `hook <Hook> [priority <P>]` form.
---
## Policy Hook Syntax
The `on { hook = ..., table = ..., priority = ... }` block is gone.
Policies now use:
```fwl
policy name : Frame hook Input = { ... };
-- or with a non-default priority:
policy name : Frame hook Prerouting priority Mangle = { ... };
```
The table is inferred from the hook; the priority defaults to the canonical
value for that hook. See `doc/fwl_grammar.md`*Policy Declaration* for the
full hook-to-table-to-priority mapping.
--- ---
## IP Address Representation ## IP Address Representation
@@ -132,6 +184,8 @@ never a string. Do not use the old `priorityStr` function (deleted).
not `literal` — the base `literal` parser does not handle `:N` syntax. not `literal` — the base `literal` parser does not handle `:N` syntax.
- `Frame` and `FlowPattern` are NOT in `reservedNames`; they appear as type - `Frame` and `FlowPattern` are NOT in `reservedNames`; they appear as type
names and must be accepted by `identifier`. names and must be accepted by `identifier`.
- `portforward` and `masquerade` are in `reservedNames`; their parsers
(`portforwardDeclP`, `masqueradeDeclP`) must use `reserved` for these words.
--- ---
@@ -143,6 +197,8 @@ never a string. Do not use the old `priorityStr` function (deleted).
`LIPv4 (a,b,c,d)` tuple constructors. `LIPv4 (a,b,c,d)` tuple constructors.
- Priority assertions use `Priority n` directly, e.g. `Priority 0`, `Priority (-100)`. - Priority assertions use `Priority n` directly, e.g. `Priority 0`, `Priority (-100)`.
- All parse tests must compile and pass before any PR is merged. - All parse tests must compile and pass before any PR is merged.
- `CompileTests.hs` must include tests for `portforward` and `masquerade` synthesis
(synthesised chain names, injected `ct status dnat accept`, injected stateful/loopback/ndp rules).
--- ---
@@ -151,16 +207,19 @@ never a string. Do not use the old `priorityStr` function (deleted).
### ✅ Safe to do without asking ### ✅ Safe to do without asking
- Read any file, list directories - Read any file, list directories
- Run `cabal build`, `cabal test`, `cabal run fwlc` - Run `cabal build`, `cabal test`, `cabal run fwlc`
- Edit `src/`, `test/`, `examples/`, `docs/` - Edit `src/`, `test/`, `examples/`, `doc/`
- Add new test cases to existing test files - Add new test cases to existing test files
### ⚠️ Ask first ### ⚠️ Ask first
- Add or remove Cabal dependencies (`fwl.cabal`) - Add or remove Cabal dependencies (`fwl.cabal`)
- Rename or delete source modules - Rename or delete source modules
- Change the nftables JSON schema emitted by `Compile.hs` - Change the nftables JSON schema emitted by `Compile.hs`
- Modify `examples/router.fwl` in ways that change its semantics - Modify `examples/simple-router.fwl` or `examples/router.fwl` in ways that change their semantics
- Add new compiler-injected rules (stateful, loopback, ndp, or new ones)
### 🚫 Never ### 🚫 Never
- Add semantic value names (`Allow`, `Drop`, `Log`, etc.) to `reservedNames` - Add semantic value names (`Allow`, `Drop`, `Log`, etc.) to `reservedNames`
- Add `table` to `reservedNames` — it is not a keyword in the current grammar
- Break the `cabal test` suite - Break the `cabal test` suite
- Emit nftables `"prio"` as a string — it must always be an integer - Emit nftables `"prio"` as a string — it must always be an integer
- Remove the implicit stateful/loopback/ndp injections from filter-hook chain compilation without updating the grammar doc and all tests

View File

@@ -1,7 +1,7 @@
# FWL Grammar Specification # FWL Grammar Specification
> **Version:** MVP > **Version:** MVP
> **Last updated:** May 2026 > **Last updated:** May 2026
> This document is the authoritative grammar reference for the Firewall Language (FWL). > This document is the authoritative grammar reference for the Firewall Language (FWL).
> It supersedes the syntax examples in `proposal.md` and reflects the current parser implementation. > It supersedes the syntax examples in `proposal.md` and reflects the current parser implementation.
@@ -14,6 +14,8 @@
- **Types are explicit** — top-level declarations carry full type annotations in the MVP. - **Types are explicit** — top-level declarations carry full type annotations in the MVP.
- **Patterns vs. guards are strictly separated** — structural decomposition happens in patterns; boolean predicates over bound names happen in guards. - **Patterns vs. guards are strictly separated** — structural decomposition happens in patterns; boolean predicates over bound names happen in guards.
- **IP addresses are integers** — IPv4 is a 32-bit value; IPv6 is a 128-bit value. Named priority constants (`Filter`, `SrcNat`, etc.) lower to their canonical integer values at parse time. - **IP addresses are integers** — IPv4 is a 32-bit value; IPv6 is a 128-bit value. Named priority constants (`Filter`, `SrcNat`, etc.) lower to their canonical integer values at parse time.
- **High-level NAT declarations hide nftables mechanics** — `portforward` and `masquerade` compile to their respective prerouting/postrouting chains automatically. Users never write NAT hook policies directly for these common patterns.
- **Common filter boilerplate is compiler-injected** — stateful (established/related accept), loopback accept, and link-local NDP accept are automatically prepended to all filter-hook policies by the compiler. Future work: make these importable builtins that can be overridden.
--- ---
@@ -29,6 +31,8 @@ decl ::= interfaceDecl
| patternDecl | patternDecl
| flowDecl | flowDecl
| ruleDecl | ruleDecl
| portforwardDecl
| masqueradeDecl
| policyDecl | policyDecl
``` ```
@@ -60,23 +64,104 @@ flowExpr ::= ident
| ident "." ident "within" duration | ident "." ident "within" duration
ruleDecl ::= "rule" ident ":" type "=" lambdaExpr ";" ruleDecl ::= "rule" ident ":" type "=" lambdaExpr ";"
```
### Port-Forward Declaration
`portforward` declares an IPv4 DNAT rule. The compiler synthesises:
1. A named map set from the inline `Map<...>` literal.
2. A `nat hook prerouting priority dstnat` chain with `fib daddr type local` guard and `dnat ip to` rewrite.
3. A `ct status dnat accept` rule injected into every `Forward` policy in the same file.
```ebnf
portforwardDecl ::= "portforward" ident
"on" ident
"via" type "=" mapLit ";"
```
**Example:**
```fwl
portforward wan_forwards
on wan
via Map<(Protocol, Port), (IPv4, Port)> = {
(tcp, :8080) -> (10.0.0.10, :80)
};
```
### Masquerade Declaration
`masquerade` declares source NAT (masquerade) for outbound traffic. The compiler synthesises a `nat hook postrouting priority srcnat` chain.
```ebnf
masqueradeDecl ::= "masquerade" ident
"on" ident
"src" ident ";"
```
**Example:**
```fwl
masquerade wan_snat
on wan
src rfc1918;
```
The `src` field must name a `Set<IPv4>` bound with `let`.
### Policy Declaration
The `on` block is replaced by a compact `hook` clause. The table is inferred from the hook; the priority defaults to the canonical value for that hook and may be overridden.
```ebnf
policyDecl ::= "policy" ident ":" type policyDecl ::= "policy" ident ":" type
"on" "{" "hook" hook ( "priority" priority )?
"hook" "=" hook ","
"table" "=" tableName ","
"priority" "=" priority
"}"
"=" armBlock ";" "=" armBlock ";"
``` ```
### Policy Metadata | Hook | Inferred table | Default priority |
|---------------|---------------|------------------|
| `Input` | `filter` | `Filter` (0) |
| `Forward` | `filter` | `Filter` (0) |
| `Output` | `filter` | `Filter` (0) |
| `Prerouting` | `nat` | `DstNat` (-100) |
| `Postrouting` | `nat` | `SrcNat` (100) |
**Implicit compiler injections for filter-hook policies:**
The compiler automatically prepends the following rules to every `Input`, `Forward`, and `Output` policy, before the user-written arms. These do not appear in the FWL source.
| Rule | nftables equivalent | Suppressed by |
|--------------|-------------------------------------------------------------|---------------|
| `stateful` | `ct state { established, related } accept` | *(future: `no-stateful` annotation)* |
| `loopback` | `iifname "lo" accept` | *(future: `no-loopback` annotation)* |
| `ndp` | `meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept` | *(future: `no-ndp` annotation)* |
The intended full design is for these to be importable builtins (see `proposal.md`); compiler injection is an MVP simplification.
The `ct status dnat accept` rule is also injected into every `Forward` policy when at least one `portforward` declaration exists in the file.
**Note:** Because `portforward` and `masquerade` synthesise the NAT chains, explicit `Prerouting` and `Postrouting` policies are not needed for these common patterns. A user-written `Prerouting` or `Postrouting` policy is still valid for advanced NAT cases not covered by the declarative forms.
**Example:**
```fwl
-- No priority override needed; defaults to Filter (0)
policy input : Frame hook Input = {
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport in open_ports -> Allow;
| _ -> Drop;
};
-- Non-default priority example
policy mangle_pre : Frame hook Prerouting priority Mangle = {
| _ -> Continue;
};
```
```ebnf ```ebnf
hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting" hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting"
tableName ::= "Filter" | "NAT" | ident
-- Priority is always an integer in nftables JSON. -- Priority is always an integer in nftables JSON.
-- Named constants are resolved at parse time: -- Named constants are resolved at parse time:
-- Raw = -300, ConnTrack = -200, Mangle = -150, -- Raw = -300, ConnTrack = -200, Mangle = -150,
@@ -127,7 +212,7 @@ stmt ::= "let" ident "=" expr
infixExpr ::= prefixExpr { infixOp prefixExpr } infixExpr ::= prefixExpr { infixOp prefixExpr }
infixOp ::= "&&" | "||" | "==" | "!=" | "<" | "<=" | ">" | ">=" infixOp ::= "&&" | "||" | "==" | "!=" | "<" | "<=" | ">" | ">="
| "++" | ">>" | ">>=" | "" | "in" | "++" | ">>" | ">>=" | "\u2208" | "in"
prefixExpr ::= "!" prefixExpr | appExpr prefixExpr ::= "!" prefixExpr | appExpr
@@ -136,7 +221,7 @@ appExpr ::= atom { atom }
atom ::= performExpr atom ::= performExpr
| mapLit -- { expr -> expr, ... } tried before setLit | mapLit -- { expr -> expr, ... } tried before setLit
| setLit -- { expr, ... } | setLit -- { expr, ... }
| tupleLit -- ( expr, expr, ... ) requires 2 | tupleLit -- ( expr, expr, ... ) requires >= 2
| "(" expr ")" | "(" expr ")"
| literal | literal
| portLit -- :22 :8080 | portLit -- :22 :8080
@@ -161,7 +246,7 @@ qualName ::= ident { "." ident }
```ebnf ```ebnf
pat ::= wildcardPat -- _ pat ::= wildcardPat -- _
| framePat -- Frame(...) | framePat -- Frame(...)
| tuplePat -- (p, p, ...) requires 2 | tuplePat -- (p, p, ...) requires >= 2
| bytesPat -- [ byteElem* ] | bytesPat -- [ byteElem* ]
| recordPat -- Ctor { field = lit, ... } | recordPat -- Ctor { field = lit, ... }
| namedOrCtorPat -- Ctor(p,...) or bare identifier | namedOrCtorPat -- Ctor(p,...) or bare identifier
@@ -175,7 +260,7 @@ frameArgs ::= pathPat "," pat -- with explicit path
pathPat ::= endpointPat? ( "->" endpointPat? )? pathPat ::= endpointPat? ( "->" endpointPat? )?
endpointPat ::= "_" endpointPat ::= "_"
| ident "in" ident -- iif in lan_zone | ident "in" ident -- iif in lan_zone
| ident "" ident | ident "\u2208" ident
| ident | ident
tuplePat ::= "(" pat "," pat { "," pat } ")" tuplePat ::= "(" pat "," pat { "," pat } ")"
@@ -188,7 +273,7 @@ byteElem ::= hexByte -- 0xff
recordPat ::= ident "{" fieldPat { "," fieldPat } "}" recordPat ::= ident "{" fieldPat { "," fieldPat } "}"
fieldPat ::= ident "=" fieldLit -- exact match fieldPat ::= ident "=" fieldLit -- exact match
| ident "in" expr -- membership | ident "in" expr -- membership
| ident "" expr | ident "\u2208" expr
| ident "as" ident -- bind with alias | ident "as" ident -- bind with alias
| ident -- bind to same name | ident -- bind to same name
@@ -222,7 +307,7 @@ literal ::= ipOrCidrLit
portLit ::= ":" nat -- :22, :8080, :51944 portLit ::= ":" nat -- :22, :8080, :51944
ipOrCidrLit ::= ipLit ( "/" nat )? -- optional prefix CIDR ipOrCidrLit ::= ipLit ( "/" nat )? -- optional prefix -> CIDR
ipLit ::= ipv6Lit | ipv4Lit ipLit ::= ipv6Lit | ipv4Lit
@@ -271,11 +356,12 @@ CIDR host-bit validation: `(addr .&. hostMask) == 0` where `hostMask = (1 << (bi
Only these words are reserved (i.e. `identifier` will reject them): Only these words are reserved (i.e. `identifier` will reject them):
``` ```
config table interface zone import from config interface zone import from
let in pattern flow rule policy on let in pattern flow rule policy on
case of if then else do perform case of if then else do perform
within as dynamic cidr4 cidr6 within as dynamic cidr4 cidr6
hook priority hook priority
portforward masquerade
WAN LAN WireGuard WAN LAN WireGuard
Input Forward Output Prerouting Postrouting Input Forward Output Prerouting Postrouting
Filter NAT Mangle DstNat SrcNat Filter NAT Mangle DstNat SrcNat
@@ -283,6 +369,9 @@ Raw ConnTrack
true false true false
``` ```
> **Note:** `table` is no longer a reserved keyword — it was only used inside the old
> `on { hook = ..., table = ..., priority = ... }` block, which is removed.
The following are **not** reserved and parse as plain identifiers in all positions The following are **not** reserved and parse as plain identifiers in all positions
(type names, constructors, action values, effect labels): (type names, constructors, action values, effect labels):
@@ -291,7 +380,7 @@ Frame FlowPattern
Allow Drop Continue Masquerade DNAT DNATMap Allow Drop Continue Masquerade DNAT DNATMap
Log Info Warn Error Log Info Warn Error
Matched Unmatched Matched Unmatched
Action Packet IP Port Protocol Action Packet IP IPv4 IPv6 Port Protocol
CIDRSet Map Bytes CIDRSet Map Bytes
``` ```
@@ -320,7 +409,7 @@ From lowest to highest binding:
| Level | Operators | Associativity | | Level | Operators | Associativity |
|-------|------------------------|---------------| |-------|------------------------|---------------|
| 1 | `if then else` | — | | 1 | `if ... then ... else` | — |
| 2 | `\|\|` | left | | 2 | `\|\|` | left |
| 3 | `&&` | left | | 3 | `&&` | left |
| 4 | `==` `!=` | none | | 4 | `==` `!=` | none |
@@ -344,6 +433,23 @@ interface wg0 : WireGuard {};
zone lan_zone = { lan, wg0 }; zone lan_zone = { lan, wg0 };
``` ```
### Port-forward and masquerade declarations
```fwl
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
portforward wan_forwards
on wan
via Map<(Protocol, Port), (IPv4, Port)> = {
(tcp, :8080) -> (10.0.0.10, :80),
(tcp, :2222) -> (10.0.0.11, :22)
};
masquerade wan_snat
on wan
src rfc1918;
```
### Map literal ### Map literal
```fwl ```fwl
@@ -382,18 +488,28 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
}; };
``` ```
### Policy ### Policy (new compact hook syntax)
```fwl ```fwl
policy input : Frame -- stateful, loopback, and ndp are injected automatically by the compiler.
on { hook = Input, table = Filter, priority = Filter } = -- No need to write them in the arm list.
{ policy input : Frame hook Input = {
| _ if ct.state in { Established, Related } -> Allow; | Frame(_, IPv4(_, TCP(tcp, _)))
| Frame(lo, _) -> Allow; if tcp.dport in open_ports -> Allow;
| Frame(_, Ether(_, IPv4(_, TCP(tcp, _)))) | Frame(_, IPv4(_, UDP(udp, _)))
if tcp.dport == :22 -> Allow; if udp.dport == :51944 -> Allow;
| Frame(_, Ether(_, IPv4(_, UDP(udp, _)))) | _ -> Drop;
if udp.dport == :51944 -> Allow; };
| _ -> Drop;
}; policy forward : Frame hook Forward = {
-- ct status dnat accept is injected automatically when portforward decls exist.
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _)))
if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow;
| _ -> Drop;
};
``` ```
### Simple router (full example)
See `examples/simple-router.fwl` for the complete canonical simple router example.

View File

@@ -9,10 +9,7 @@ zone lan_zone = { lan, wg0 };
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 }; let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
let forwards : Map<(Protocol, Port), (IP, Port)> = { let open_ports : Set<Port> = { :22 };
(tcp, :8080) -> (10.17.1.10, :80),
(tcp, :2222) -> (10.17.1.11, :22)
};
-- WireGuard handshake detection (compiles to ct mark state machine) -- WireGuard handshake detection (compiles to ct mark state machine)
pattern WGInitiation : (UDPHeader, Bytes) = pattern WGInitiation : (UDPHeader, Bytes) =
@@ -40,56 +37,32 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
| _ -> Continue; | _ -> Continue;
}; };
-- Port-forward map: incoming proto+port -> internal addr+port
portforward wan_forwards
on wan
via Map<(Protocol, Port), (IPv4, Port)> = {
(tcp, :8080) -> (10.17.1.10, :80),
(tcp, :2222) -> (10.17.1.11, :22)
};
-- Masquerade outbound traffic from RFC1918 sources
masquerade wan_snat
on wan
src rfc1918;
-- Inbound to router -- Inbound to router
policy input : Frame policy input : Frame hook Input = {
on { hook = Input, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| Frame(lo, _) -> Allow;
| Frame(_, IPv6(ip6, ICMPv6(_, _)))
if ip6.src in fe80::/10 -> Allow;
| Frame(_, IPv4(_, TCP(tcp, _))) | Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport == :22 -> Allow; if tcp.dport in open_ports -> Allow;
| Frame(_, IPv4(_, UDP(udp, _))) | Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow; if udp.dport == :51944 -> Allow;
| _ -> Drop; | _ -> Drop;
}; };
-- Forwarded traffic -- Forwarded traffic
policy forward : Frame policy forward : Frame hook Forward = {
on { hook = Forward, table = Filter, priority = Filter } | frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame);
= { | Frame(iif in lan_zone -> wan, _) -> Allow;
| _ if ct.state in { Established, Related } -> Allow; | Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame); | _ -> Drop;
| _ if ct.status == DNAT -> Allow; };
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| Frame(wan -> lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _)))
if (ip.protocol, th.dport) in forwards -> Allow;
| _ -> Drop;
};
-- Outbound from router
policy output : Frame
on { hook = Output, table = Filter, priority = Filter }
= {
| _ -> Allow;
};
-- NAT
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap((ip.protocol, th.dport), forwards)
else Allow;
| _ -> Allow;
};
policy nat_postrouting : Frame
on { hook = Postrouting, table = NAT, priority = SrcNat }
= {
| Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade;
| _ -> Allow;
};

View File

@@ -1,69 +1,37 @@
interface wan : WAN { dynamic; }; interface wan : WAN { dynamic; };
interface lan : LAN { cidr4 = { 10.0.0.0/24 }; }; interface lan : LAN { cidr4 = { 10.0.0.0/24 }; };
zone lan_zone = { lan }; zone lan_zone = { lan };
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 }; let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
-- Single IPv4 port forward: tcp:8080 -> 10.0.0.10:80
let forwards : Map<(Protocol, Port), (IP, Port)> = {
(tcp, :8080) -> (10.0.0.10, :80)
};
-- Open inbound ports on the router itself
let open_ports : Set<Port> = { :22 }; let open_ports : Set<Port> = { :22 };
-- IPv6 forwarded destination: tcp . 2001:db8::1 . 22000 let forwards_v6 : Set<(Protocol, IPv6, Port)> = {
let forwards_v6 : Set<(Protocol, IP, Port)> = { (tcp, 2001:db8::1, :22000)
(tcp, 2001:db8::1, :22000)
}; };
policy input : Frame portforward wan_forwards
on { hook = Input, table = Filter, priority = Filter } on wan
= { via Map<(Protocol, Port), (IPv4, Port)> = {
| _ if ct.state in { Established, Related } -> Allow; (tcp, :8080) -> (10.0.0.10, :80)
| Frame(lo, _) -> Allow; };
| Frame(_, IPv6(ip6, ICMPv6(_, _)))
if ip6.src in fe80::/10 -> Allow; masquerade wan_snat
on wan
src rfc1918;
policy input : Frame hook Input = {
| Frame(_, IPv4(_, TCP(tcp, _))) | Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport in open_ports -> Allow; if tcp.dport in open_ports -> Allow;
| Frame(_, IPv4(_, UDP(udp, _))) | Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow; if udp.dport == :51944 -> Allow;
| _ -> Drop; | _ -> Drop;
}; };
policy forward : Frame policy forward : Frame hook Forward = {
on { hook = Forward, table = Filter, priority = Filter } | Frame(iif in lan_zone -> wan, _) -> Allow;
= {
| _ if ct.state in { Established, Related } -> Allow;
| _ if ct.status == DNAT -> Allow;
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(wan -> iif in lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _)))
if (ip.protocol, th.dport) in forwards -> Allow;
| Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _))) | Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _)))
if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow; if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow;
| _ -> Drop; | _ -> Drop;
}; };
policy output : Frame
on { hook = Output, table = Filter, priority = Filter }
= {
| _ -> Allow;
};
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap((ip.protocol, th.dport), forwards)
else Allow;
| _ -> Allow;
};
policy nat_postrouting : Frame
on { hook = Postrouting, table = NAT, priority = SrcNat }
= {
| Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade;
| _ -> Allow;
};

View File

@@ -33,22 +33,11 @@
"type": "filter" "type": "filter"
} }
}, },
{
"chain": {
"family": "inet",
"hook": "output",
"name": "output",
"policy": "accept",
"prio": 0,
"table": "fwl",
"type": "filter"
}
},
{ {
"chain": { "chain": {
"family": "inet", "family": "inet",
"hook": "prerouting", "hook": "prerouting",
"name": "nat_prerouting", "name": "wan_forwards_prerouting",
"policy": "accept", "policy": "accept",
"prio": -100, "prio": -100,
"table": "fwl", "table": "fwl",
@@ -59,41 +48,13 @@
"chain": { "chain": {
"family": "inet", "family": "inet",
"hook": "postrouting", "hook": "postrouting",
"name": "nat_postrouting", "name": "wan_snat_postrouting",
"policy": "accept", "policy": "accept",
"prio": 100, "prio": 100,
"table": "fwl", "table": "fwl",
"type": "nat" "type": "nat"
} }
}, },
{
"set": {
"elem": [
{
"prefix": {
"addr": "10.0.0.0",
"len": 8
}
},
{
"prefix": {
"addr": "172.16.0.0",
"len": 12
}
},
{
"prefix": {
"addr": "192.168.0.0",
"len": 16
}
}
],
"family": "inet",
"name": "rfc1918",
"table": "fwl",
"type": "ipv4_addr"
}
},
{ {
"map": { "map": {
"elem": [ "elem": [
@@ -117,7 +78,7 @@
"ipv4_addr", "ipv4_addr",
"inet_service" "inet_service"
], ],
"name": "forwards", "name": "wan_forwards",
"table": "fwl", "table": "fwl",
"type": [ "type": [
"inet_proto", "inet_proto",
@@ -125,6 +86,37 @@
] ]
} }
}, },
{
"set": {
"elem": [
{
"prefix": {
"addr": "10.0.0.0",
"len": 8
}
},
{
"prefix": {
"addr": "172.16.0.0",
"len": 12
}
},
{
"prefix": {
"addr": "192.168.0.0",
"len": 16
}
}
],
"family": "inet",
"flags": [
"interval"
],
"name": "rfc1918",
"table": "fwl",
"type": "ipv4_addr"
}
},
{ {
"set": { "set": {
"elem": [ "elem": [
@@ -152,7 +144,7 @@
"table": "fwl", "table": "fwl",
"type": [ "type": [
"inet_proto", "inet_proto",
"ipv4_addr", "ipv6_addr",
"inet_service" "inet_service"
] ]
} }
@@ -168,11 +160,13 @@
"key": "state" "key": "state"
} }
}, },
"op": "in", "op": "==",
"right": [ "right": {
"established", "set": [
"related" "established",
] "related"
]
}
} }
}, },
{ {
@@ -210,17 +204,6 @@
"rule": { "rule": {
"chain": "input", "chain": "input",
"expr": [ "expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv6"
}
},
{ {
"match": { "match": {
"left": { "left": {
@@ -244,7 +227,7 @@
"op": "==", "op": "==",
"right": { "right": {
"prefix": { "prefix": {
"addr": "fe80:0:0:0:0:0:0:0", "addr": "fe80::",
"len": 10 "len": 10
} }
} }
@@ -373,11 +356,13 @@
"key": "state" "key": "state"
} }
}, },
"op": "in", "op": "==",
"right": [ "right": {
"established", "set": [
"related" "established",
] "related"
]
}
} }
}, },
{ {
@@ -399,7 +384,7 @@
"key": "status" "key": "status"
} }
}, },
"op": "==", "op": "in",
"right": "dnat" "right": "dnat"
} }
}, },
@@ -449,170 +434,6 @@
"table": "fwl" "table": "fwl"
} }
}, },
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "iifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "in",
"right": {
"set": [
"lan"
]
}
}
},
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"match": {
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "iifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "in",
"right": {
"set": [
"lan"
]
}
}
},
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "udp"
}
},
{
"match": {
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{ {
"rule": { "rule": {
"chain": "forward", "chain": "forward",
@@ -670,9 +491,8 @@
"left": { "left": {
"concat": [ "concat": [
{ {
"payload": { "meta": {
"field": "protocol", "key": "l4proto"
"protocol": "ip6"
} }
}, },
{ {
@@ -758,9 +578,8 @@
"left": { "left": {
"concat": [ "concat": [
{ {
"payload": { "meta": {
"field": "protocol", "key": "l4proto"
"protocol": "ip6"
} }
}, },
{ {
@@ -803,19 +622,7 @@
}, },
{ {
"rule": { "rule": {
"chain": "output", "chain": "wan_forwards_prerouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [ "expr": [
{ {
"match": { "match": {
@@ -835,46 +642,53 @@
"key": "l4proto" "key": "l4proto"
} }
}, },
"op": "==", "op": "in",
"right": "tcp" "right": {
} "set": [
}, "tcp",
{ "udp"
"accept": null ]
} }
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
} }
}, },
{ {
"match": { "match": {
"left": { "left": {
"meta": { "fib": {
"key": "l4proto" "flags": [
"daddr"
],
"result": "type"
} }
}, },
"op": "==", "op": "==",
"right": "udp" "right": "local"
} }
}, },
{ {
"accept": null "dnat": {
"addr": {
"map": {
"data": "@wan_forwards",
"key": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
}
}
},
"family": "ip"
}
} }
], ],
"family": "inet", "family": "inet",
@@ -883,19 +697,7 @@
}, },
{ {
"rule": { "rule": {
"chain": "nat_prerouting", "chain": "wan_snat_postrouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_postrouting",
"expr": [ "expr": [
{ {
"match": { "match": {
@@ -908,17 +710,6 @@
"right": "wan" "right": "wan"
} }
}, },
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{ {
"match": { "match": {
"left": { "left": {
@@ -938,18 +729,6 @@
"family": "inet", "family": "inet",
"table": "fwl" "table": "fwl"
} }
},
{
"rule": {
"chain": "nat_postrouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
} }
] ]
} }

View File

@@ -22,14 +22,18 @@ defaultConfig = Config { configTable = "fwl" }
-- ─── Declarations ─────────────────────────────────────────────────────────── -- ─── Declarations ───────────────────────────────────────────────────────────
data Decl data Decl
= DInterface Name IfaceKind [IfaceProp] = DInterface Name IfaceKind [IfaceProp]
| DZone Name [Name] | DZone Name [Name]
| DImport Name Type FilePath | DImport Name Type FilePath
| DLet Name Type Expr | DLet Name Type Expr
| DPattern Name Type Pat | DPattern Name Type Pat
| DFlow Name FlowExpr | DFlow Name FlowExpr
| DRule Name Type Expr | DRule Name Type Expr
| DPolicy Name Type PolicyMeta ArmBlock | DPolicy Name Type PolicyMeta ArmBlock
| DPortForward Name Name Type [(Expr, Expr)]
-- ^ decl-name interface-name map-type map-entries
| DMasquerade Name Name Name
-- ^ decl-name interface-name src-set-name
deriving (Show) deriving (Show)
data PolicyMeta = PolicyMeta data PolicyMeta = PolicyMeta

View File

@@ -50,6 +50,8 @@ buildEnv = foldl' addDecl Map.empty
addDecl m (DFlow n _) = Map.insert n KFlow m addDecl m (DFlow n _) = Map.insert n KFlow m
addDecl m (DRule n _ _) = Map.insert n KRule m addDecl m (DRule n _ _) = Map.insert n KRule m
addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m
addDecl m (DPortForward n _ _ _) = Map.insert n KLet m
addDecl m (DMasquerade n _ _) = Map.insert n KLet m
findDups :: [Decl] -> [CheckError] findDups :: [Decl] -> [CheckError]
findDups decls = go [] Set.empty decls findDups decls = go [] Set.empty decls
@@ -70,6 +72,8 @@ declName (DPattern n _ _) = n
declName (DFlow n _) = n declName (DFlow n _) = n
declName (DRule n _ _) = n declName (DRule n _ _) = n
declName (DPolicy n _ _ _) = n declName (DPolicy n _ _ _) = n
declName (DPortForward n _ _ _) = n
declName (DMasquerade n _ _) = n
declKindStr :: Decl -> String declKindStr :: Decl -> String
declKindStr (DInterface _ _ _) = "interface" declKindStr (DInterface _ _ _) = "interface"
@@ -80,6 +84,8 @@ declKindStr (DPattern _ _ _) = "pattern"
declKindStr (DFlow _ _) = "flow" declKindStr (DFlow _ _) = "flow"
declKindStr (DRule _ _ _) = "rule" declKindStr (DRule _ _ _) = "rule"
declKindStr (DPolicy _ _ _ _) = "policy" declKindStr (DPolicy _ _ _ _) = "policy"
declKindStr (DPortForward _ _ _ _) = "portforward"
declKindStr (DMasquerade _ _ _) = "masquerade"
-- ─── Name resolution ───────────────────────────────────────────────────────── -- ─── Name resolution ─────────────────────────────────────────────────────────
@@ -90,6 +96,12 @@ checkDecl env (DFlow _ fe) = checkFlow env fe
checkDecl env (DRule _ _ e) = checkExpr env e checkDecl env (DRule _ _ e) = checkExpr env e
checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab
checkDecl env (DLet _ _ e) = checkExpr env e checkDecl env (DLet _ _ e) = checkExpr env e
checkDecl env (DPortForward _ iface _ entries) =
checkName env "interface" iface ++
concatMap (\(k,v) -> checkExpr env k ++ checkExpr env v) entries
checkDecl env (DMasquerade _ iface srcSet) =
checkName env "interface" iface ++
checkName env "set" srcSet
checkDecl _ _ = [] checkDecl _ _ = []
checkName :: Env -> String -> String -> [CheckError] checkName :: Env -> String -> String -> [CheckError]

View File

@@ -3,6 +3,11 @@
All policies (Filter and NAT) go into one table named by Config. All policies (Filter and NAT) go into one table named by Config.
Layer stripping: Frame patterns that omit Ether compile identically Layer stripping: Frame patterns that omit Ether compile identically
to those that include it. to those that include it.
Phase 1: DRule declarations compile to regular (no-hook) chains.
Phase 2: compileAction returns Maybe [Value] to support multi-step arms.
Phase 3: Log.emit -> {"log": ...} effect statement.
Phase 4: DFlow declarations -> ct mark state machines (_track chains).
-} -}
module FWL.Compile module FWL.Compile
( compileProgram ( compileProgram
@@ -11,6 +16,8 @@ module FWL.Compile
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Word (Word32)
import Numeric (showHex)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Aeson ((.=), Value(..), object, toJSON) import Data.Aeson ((.=), Value(..), object, toJSON)
import qualified Data.Aeson as A import qualified Data.Aeson as A
@@ -29,26 +36,364 @@ compileToJson = encodePretty . programToValue
compileProgram :: Program -> Value compileProgram :: Program -> Value
compileProgram = programToValue compileProgram = programToValue
-- ─── Compile environment ─────────────────────────────────────────────────────
-- | Per-compile environment threaded through all helpers.
data Env = Env
{ envDecls :: Map.Map String Decl
-- ^ all top-level declarations, keyed by name
, envCtMarks :: Map.Map String (Word32, Word32)
-- ^ flow-name -> (inProgress mark, confirmed mark)
-- populated in Phase 4; empty for Phases 1-3
}
buildEnv :: [Decl] -> Env
buildEnv decls = Env
{ envDecls = Map.fromList [ (declNameOf d, d) | d <- decls ]
, envCtMarks = Map.empty
}
where
declNameOf (DInterface n _ _) = n
declNameOf (DZone n _) = n
declNameOf (DPattern n _ _) = n
declNameOf (DFlow n _) = n
declNameOf (DRule n _ _) = n
declNameOf (DPolicy n _ _ _) = n
declNameOf (DLet n _ _) = n
declNameOf (DImport n _ _) = n
declNameOf (DPortForward n _ _ _) = n
declNameOf (DMasquerade n _ _) = n
-- ─── Top-level program ───────────────────────────────────────────────────────
programToValue :: Program -> Value programToValue :: Program -> Value
programToValue (Program cfg decls) = programToValue (Program cfg decls) =
object [ "nftables" .= toJSON object [ "nftables" .= toJSON
(metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ] (metainfo : tableObj : allObjects) ]
where where
env = buildEnv decls -- Phase 4: allocate ct marks for all DFlow declarations
tbl = configTable cfg ctMarks = allocateCtMarks cfg decls
env = (buildEnv decls) { envCtMarks = ctMarks }
tbl = configTable cfg
metainfo = object [ "metainfo" .= object metainfo = object [ "metainfo" .= object
[ "json_schema_version" .= (1 :: Int) ] ] [ "json_schema_version" .= (1 :: Int) ] ]
tableObj = object [ "table" .= tableValue tbl ] tableObj = object [ "table" .= tableValue tbl ]
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ] policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies portfwds = [ d | d@(DPortForward {}) <- decls ]
ruleObjs = concatMap masqs = [ d | d@(DMasquerade {}) <- decls ]
(\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) rules = [ (n, e) | DRule n _ e <- decls ] -- Phase 1
policies flows = [ (n, fe) | DFlow n fe <- decls ] -- Phase 4
hasPortFwd = not (null portfwds)
-- ── Chain declarations ──────────────────────────────────────────────
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
masqChainObjs = concatMap (masqChainValue tbl) masqs
-- Phase 1: one regular chain per DRule
ruleChainObjs = map (\(n, _) -> regularChainValue tbl n) rules
-- Phase 4: one _track chain per DFlow + optional ct timeout objects
flowChainObjs = concatMap (flowTrackChainValue tbl ctMarks) flows
flowTimeoutObjs = concatMap (flowTimeoutValue tbl) flows
-- ── Rules ───────────────────────────────────────────────────────────
policyRuleObjs = concatMap
(\(n, pm, ab) ->
injectFilterRules env tbl n pm hasPortFwd ++
concatMap (armToRuleValues env tbl n) ab)
policies
-- Phase 1: compile the lambda body of each DRule into its chain
ruleRuleObjs = concatMap (\(n, e) -> ruleBodyToValues env tbl n e) rules
pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
-- Phase 4: synthesise _track chain rules
flowTrackRules = concatMap (flowTrackRuleValues tbl ctMarks) flows
-- Sets / maps from let-bindings
letDecls = [ (n, t, e) | DLet n t e <- decls ]
mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls
-- Synthesised maps from portforward decls
pfMapObjs = concatMap (portfwdMapValue tbl) portfwds
allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs
++ ruleChainObjs -- Phase 1
++ flowTimeoutObjs ++ flowChainObjs -- Phase 4
++ pfMapObjs ++ mapObjs
++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs
++ ruleRuleObjs -- Phase 1
++ flowTrackRules -- Phase 4
-- ─── Phase 1: Regular chain declarations ─────────────────────────────────────
-- | Emit a *regular* chain (no type/hook/prio/policy) for a DRule.
regularChainValue :: String -> Name -> Value
regularChainValue tbl n = object
[ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
]
]
-- | Compile the body of a DRule (a lambda / case expression) into rules
-- belonging to the rule's own chain.
ruleBodyToValues :: Env -> String -> Name -> Expr -> [Value]
ruleBodyToValues env tbl chain expr =
case expr of
ELam _ body -> ruleBodyToValues env tbl chain body
ECase _ ab -> concatMap (armToRuleValues env tbl chain) ab
_ -> [] -- bare expressions are not yet compilable here
-- ─── Phase 4: ct mark allocation ─────────────────────────────────────────────
-- | Allocate (inProgress, confirmed) ct mark pairs for every DFlow decl.
-- Marks are in the range [prefix+1, prefix+2n] where prefix = 0xfee10000
-- (or the value from config { ct_mark_prefix = 0x????; }).
allocateCtMarks :: Config -> [Decl] -> Map.Map String (Word32, Word32)
allocateCtMarks cfg decls =
Map.fromList (zipWith mk flowNames [0..])
where
flowNames = [ n | DFlow n _ <- decls ]
base :: Word32
base = fromIntegral (configCtMarkPrefix cfg) `shiftL32` 16
mk n (i :: Word32) = (n, (base + 2*i + 1, base + 2*i + 2))
-- Portable left-shift for Word32 (avoids importing Data.Bits at top level)
shiftL32 :: Word32 -> Int -> Word32
shiftL32 w n = w * (2 ^ n)
-- ─── Phase 4: _track chain + rules ───────────────────────────────────────────
-- | Emit the regular _track chain declaration for a DFlow.
flowTrackChainValue :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackChainValue tbl _ctMarks (n, _) =
[ regularChainValue tbl (n ++ "_track") ]
-- | Emit the ct timeout object for a DFlow that has a `within` clause.
flowTimeoutValue :: String -> (Name, FlowExpr) -> [Value]
flowTimeoutValue tbl (n, fe) =
case withinDuration fe of
Nothing -> []
Just (secs, _) ->
[ object
[ "ct timeout" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_timeout")
, "protocol" .= ("udp" :: String)
, "state" .= object
[ "untracked" .= (show secs ++ "s" :: String) ]
]
]
]
where
withinDuration (FSeq _ _ (Just d)) = Just d
withinDuration (FSeq a b Nothing) =
case withinDuration a of
Just d -> Just d
Nothing -> withinDuration b
withinDuration _ = Nothing
-- | Synthesise the two tracking rules inside the _track chain.
-- Rule 1: ct mark 0 + init-pattern-match -> set mark to inProgress, return
-- Rule 2: ct mark inProgress + resp-match -> set mark to confirmed, return
flowTrackRuleValues :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackRuleValues tbl ctMarks (n, fe) =
case Map.lookup n ctMarks of
Nothing -> []
Just (inProg, confirmed) ->
let chain = n ++ "_track"
(initAtom, respAtom) = flowAtoms fe
rule1 = ruleValue tbl chain $
[ ctMarkMatch "==" 0 ] ++
atomMatchExprs initAtom ++
[ ctMangleExpr inProg
, object ["return" .= Null]
]
rule2 = ruleValue tbl chain $
[ ctMarkMatch "==" inProg ] ++
atomMatchExprs respAtom ++
[ ctMangleExpr confirmed
, object ["return" .= Null]
]
in [rule1, rule2]
-- | Extract (init, response) atoms from a FlowExpr.
flowAtoms :: FlowExpr -> (Name, Name)
flowAtoms (FAtom n) = (n, n)
flowAtoms (FSeq (FAtom a) b _)= let (_, r) = flowAtoms b in (a, r)
flowAtoms (FSeq a _ _) = let (i, _) = flowAtoms a in (i, i)
-- | Pattern-match expressions for a known flow atom.
-- WGInitiation -> meta l4proto udp + @th,0,8 == 0x01
-- WGResponse -> meta l4proto udp + @th,0,8 == 0x02
atomMatchExprs :: Name -> [Value]
atomMatchExprs "WGInitiation" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 1
]
atomMatchExprs "WGResponse" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 2
]
atomMatchExprs _ = [] -- unknown atom: no-op (comment only in real impl)
-- | Match on @th,<offset>,<len> (raw transport-header bits).
rawBitsMatch :: Int -> Int -> Int -> Value
rawBitsMatch offset len val = matchExpr "=="
(object ["payload" .= object
[ "base" .= ("transport" :: String)
, "offset" .= offset
, "len" .= len
]])
(toJSON val)
-- | Match ct mark with operator and numeric value.
ctMarkMatch :: String -> Word32 -> Value
ctMarkMatch op val = matchExpr op
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON val)
-- | Mangle (set) ct mark to a value.
ctMangleExpr :: Word32 -> Value
ctMangleExpr val = object
[ "mangle" .= object
[ "key" .= object ["ct" .= object ["key" .= ("mark" :: String)]]
, "value" .= toJSON val
]
]
-- ─── Implicit filter-hook rule injection ─────────────────────────────────────
-- | Prepend implicit rules for filter-hook chains (Input/Forward/Output).
injectFilterRules :: Env -> String -> Name -> PolicyMeta -> Bool -> [Value]
injectFilterRules env tbl chain pm hasPortFwd =
case pmHook pm of
HInput -> [statefulRule, loopbackRule, ndpRule]
HForward -> statefulRule : if hasPortFwd then [ctDnatRule] else []
HOutput -> [statefulRule]
_ -> []
where
statefulRule = ruleValue tbl chain
[ matchExpr "==" (object ["ct" .= object ["key" .= ("state" :: String)]])
(setVal [A.String "established", A.String "related"])
, object ["accept" .= Null]
]
loopbackRule = ruleValue tbl chain
[ matchMeta "iifname" "lo"
, object ["accept" .= Null]
]
ndpRule = ruleValue tbl chain
[ matchPayload "ip6" "nexthdr" "ipv6-icmp"
, matchExpr "==" (payloadVal "ip6" "saddr")
(object ["prefix" .= object ["addr" .= A.String "fe80::", "len" .= (10 :: Int)]])
, object ["accept" .= Null]
]
ctDnatRule = ruleValue tbl chain
[ matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]])
(A.String "dnat")
, object ["accept" .= Null]
]
_ = env -- silence unused warning
ruleValue :: String -> String -> [Value] -> Value
ruleValue tbl chain exprs = object
[ "rule" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "chain" .= chain
, "expr" .= toJSON exprs
]
]
-- ─── DPortForward compilation ─────────────────────────────────────────────────
portfwdMapValue :: String -> Decl -> [Value]
portfwdMapValue tbl (DPortForward n _ t entries) =
case t of
TName "Map" [tk, tv] ->
[ object [ "map" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= renderNftType (fwlTypeToNft tv)
, "elem" .= toJSON (map renderMapElem entries)
] ]
]
_ -> []
portfwdMapValue _ _ = []
portfwdChainValue :: String -> Decl -> [Value]
portfwdChainValue tbl (DPortForward n _ _ _) =
[ object [ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_prerouting")
, "type" .= ("nat" :: String)
, "hook" .= ("prerouting" :: String)
, "prio" .= priorityInt pDstNat
, "policy" .= ("accept" :: String)
] ]
]
portfwdChainValue _ _ = []
portfwdRuleValues :: Env -> String -> Decl -> [Value]
portfwdRuleValues _ tbl (DPortForward n _ _ _) =
let chainName = n ++ "_prerouting"
in [ ruleValue tbl chainName
[ matchMeta "nfproto" "ipv4"
, matchInSet (metaVal "l4proto") [A.String "tcp", A.String "udp"]
, matchExpr "==" (object ["fib" .= object ["result" .= ("type" :: String), "flags" .= toJSON (["daddr"] :: [String])]])
(A.String "local")
, object ["dnat" .= object
[ "family" .= ("ip" :: String)
, "addr" .= object
[ "map" .= object
[ "key" .= object ["concat" .= toJSON
[ metaVal "l4proto"
, payloadVal "th" "dport"
]]
, "data" .= A.String (toText ("@" ++ n))
]
]
]]
]
]
portfwdRuleValues _ _ _ = []
-- ─── DMasquerade compilation ──────────────────────────────────────────────────
masqChainValue :: String -> Decl -> [Value]
masqChainValue tbl (DMasquerade n _ _) =
[ object [ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_postrouting")
, "type" .= ("nat" :: String)
, "hook" .= ("postrouting" :: String)
, "prio" .= priorityInt pSrcNat
, "policy" .= ("accept" :: String)
] ]
]
masqChainValue _ _ = []
masqRuleValues :: Env -> String -> Decl -> [Value]
masqRuleValues _ tbl (DMasquerade n iface srcSet) =
let chainName = n ++ "_postrouting"
in [ ruleValue tbl chainName
[ matchMeta "oifname" iface
, matchExpr "==" (payloadVal "ip" "saddr")
(A.String (toText ("@" ++ srcSet)))
, object ["masquerade" .= Null]
]
]
masqRuleValues _ _ _ = []
letDecls = [ (n, t, e) | DLet n t e <- decls ]
mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls
-- ─── Table / Chain declarations ────────────────────────────────────────────── -- ─── Table / Chain declarations ──────────────────────────────────────────────
@@ -93,11 +438,12 @@ defaultPolicyStr _ = "accept"
-- ─── Arm → Rule objects ────────────────────────────────────────────────────── -- ─── Arm → Rule objects ──────────────────────────────────────────────────────
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value] armToRuleValues :: Env -> String -> Name -> Arm -> [Value]
armToRuleValues env tbl chain (Arm p mg body) = armToRuleValues env tbl chain (Arm p mg body) =
-- Phase 2: compileAction returns Maybe [Value]
case compileAction env body of case compileAction env body of
Nothing -> [] Nothing -> []
Just verdict -> Just verdicts ->
let patExprsAlts = compilePat env p let patExprsAlts = compilePat env p
guardExprs = maybe [] (compileGuard env) mg guardExprs = maybe [] (compileGuard env) mg
in [ object in [ object
@@ -105,28 +451,21 @@ armToRuleValues env tbl chain (Arm p mg body) =
[ "family" .= ("inet" :: String) [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "chain" .= chain , "chain" .= chain
, "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict]) , "expr" .= toJSON (patExprs ++ guardExprs ++ verdicts)
] ]
] ]
| patExprs <- patExprsAlts ] | patExprs <- patExprsAlts ]
-- ─── Pattern → [Value] ─────────────────────────────────────────────────────── -- ─── Pattern → [Value] ───────────────────────────────────────────────────────
type CompileEnv = Map.Map String Decl type CompileEnv = Map.Map String Decl -- kept for internal helpers that only
-- need the decl map
buildEnv :: [Decl] -> CompileEnv -- Convenience accessor
buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty declEnv :: Env -> CompileEnv
where declEnv = envDecls
declNameOf (DInterface n _ _) = n
declNameOf (DZone n _) = n
declNameOf (DPattern n _ _) = n
declNameOf (DFlow n _) = n
declNameOf (DRule n _ _) = n
declNameOf (DPolicy n _ _ _) = n
declNameOf (DLet n _ _) = n
declNameOf (DImport n _ _) = n
compilePat :: CompileEnv -> Pat -> [[Value]] compilePat :: Env -> Pat -> [[Value]]
compilePat _ PWild = [[]] compilePat _ PWild = [[]]
compilePat _ (PVar _) = [[]] compilePat _ (PVar _) = [[]]
compilePat env (PNamed n) = expandNamedPat env n compilePat env (PNamed n) = expandNamedPat env n
@@ -140,13 +479,13 @@ compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps
compilePat _ (PBytes _) = [[]] compilePat _ (PBytes _) = [[]]
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2 compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
expandNamedPat :: CompileEnv -> Name -> [[Value]] expandNamedPat :: Env -> Name -> [[Value]]
expandNamedPat env n = expandNamedPat env n =
case Map.lookup n env of case Map.lookup n (declEnv env) of
Just (DPattern _ _ p) -> compilePat env p Just (DPattern _ _ p) -> compilePat env p
_ -> [] _ -> []
compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]] compileCtorPat :: Env -> String -> [Pat] -> [[Value]]
compileCtorPat env ctor ps = case ctor of compileCtorPat env ctor ps = case ctor of
"Ether" -> children "Ether" -> children
"IPv4" -> map (matchMeta "nfproto" "ipv4" :) children "IPv4" -> map (matchMeta "nfproto" "ipv4" :) children
@@ -165,31 +504,29 @@ compileRecordPat proto fs = [mapMaybe go fs]
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit)) go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
go _ = Nothing go _ = Nothing
compilePathPat :: CompileEnv -> PathPat -> [[Value]] compilePathPat :: Env -> PathPat -> [[Value]]
compilePathPat env (PathPat ms md) = compilePathPat env (PathPat ms md) =
[ maybe [] (compileEndpoint env "iifname") ms ++ [ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint env "oifname") md ] maybe [] (compileEndpoint env "oifname") md ]
compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value] compileEndpoint :: Env -> String -> EndpointPat -> [Value]
compileEndpoint _ _ EPWild = [] compileEndpoint _ _ EPWild = []
compileEndpoint _ dir (EPName n) = [matchMeta dir n] compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint env dir (EPMember _ z) = compileEndpoint env dir (EPMember _ z) =
case Map.lookup z env of case Map.lookup z (declEnv env) of
Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)] Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
_ -> [matchInSet (metaVal dir) [A.String (toText z)]] _ -> [matchInSet (metaVal dir) [A.String (toText z)]]
-- ─── Guard → [Value] ───────────────────────────────────────────────────────── -- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: CompileEnv -> Expr -> [Value] compileGuard :: Env -> Expr -> [Value]
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r] compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)] compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)] compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
compileGuard _ _ = [] compileGuard _ _ = []
compileInExpr :: CompileEnv -> Expr -> Expr -> Value compileInExpr :: Env -> Expr -> Expr -> Value
-- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element
-- EQual case to eliminate the overlapping pattern match warning.
compileInExpr env (EQual ["ct", "state"]) (ESet vs) = compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs)) matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr env (EQual ["ct", "status"]) (ESet vs) = compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
@@ -197,29 +534,82 @@ compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
compileInExpr env l (ESet vs) = compileInExpr env l (ESet vs) =
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs)) matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
compileInExpr env l (EVar z) compileInExpr env l (EVar z)
| Just (DZone _ ns) <- Map.lookup z env = | Just (DZone _ ns) <- Map.lookup z (declEnv env) =
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns)) matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
compileInExpr env l r = compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r) matchExpr "==" (exprVal env l) (exprVal env r)
-- ─── Action → Maybe Value ───────────────────────────────────────────────────── -- ─── Action → Maybe [Value] (Phase 2) ───────────────────────────────────────
--
-- Returns Nothing for Continue (arm is silently dropped).
-- Returns Just [..] for everything else.
-- Single-verdict arms return a one-element list.
-- Multi-step do-block arms return a multi-element list.
compileAction :: CompileEnv -> Expr -> Maybe Value compileAction :: Env -> Expr -> Maybe [Value]
compileAction _ (EVar "Allow") = Just (object ["accept" .= Null]) -- Simple verdicts
compileAction _ (EVar "Drop") = Just (object ["drop" .= Null]) compileAction _ (EVar "Allow") = Just [object ["accept" .= Null]]
compileAction _ (EVar "Drop") = Just [object ["drop" .= Null]]
compileAction _ (EVar "Continue") = Nothing compileAction _ (EVar "Continue") = Nothing
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null]) compileAction _ (EVar "Masquerade") = Just [object ["masquerade" .= Null]]
compileAction _ (EApp (EVar "DNAT") arg) = compileAction _ (EApp (EVar "DNAT") arg) =
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]] Just [object ["dnat" .= object ["addr" .= exprToStr arg]]]
compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) = compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
Just $ object ["dnat" .= object ["addr" .= object Just [object ["dnat" .= object ["addr" .= object
[ "map" .= object [ "key" .= exprVal env key [ "map" .= object [ "key" .= exprVal env key
, "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]] , "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]]
-- Phase 1: rule call -> jump
compileAction env (EApp (EVar rn) _) = compileAction env (EApp (EVar rn) _) =
case Map.lookup rn env of case Map.lookup rn (declEnv env) of
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]] Just (DRule _ _ _) -> Just [object ["jump" .= object ["target" .= rn]]]
_ -> Just (object ["accept" .= Null]) _ -> Just [object ["accept" .= Null]]
compileAction _ _ = Just (object ["accept" .= Null]) -- Phase 3: Log.emit effect
compileAction env (EPerform ["Log", "emit"] [levelExpr, msgExpr]) =
let lvl = case levelExpr of
EVar "Warn" -> "warn"
EVar "Info" -> "info"
EVar "Debug" -> "debug"
_ -> "warn"
msg = case msgExpr of
ELit (LString s) -> s
_ -> exprToStr msgExpr
logStmt = object ["log" .= object
[ "prefix" .= A.String (toText msg)
, "level" .= A.String (toText lvl)
]]
in Just [logStmt] -- single statement; do-block handles sequencing
compileAction _ (EPerform ["Log", "emit"] _) =
Just [object ["log" .= object ["prefix" .= A.String ""]]]
-- Phase 4: FlowMatch.check effect
compileAction env (EPerform ["FlowMatch", "check"] (EVar flowName : _)) =
case Map.lookup flowName (envCtMarks env) of
Just (_inProg, confirmed) ->
Just
[ object ["jump" .= object ["target" .= (flowName ++ "_track")]]
, matchExpr "=="
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON confirmed)
]
Nothing ->
-- flow not found; emit jump only
Just [object ["jump" .= object ["target" .= (flowName ++ "_track")]]]
compileAction _ (EPerform ["FlowMatch", "check"] _) =
Just [object ["accept" .= Null]]
-- do-block: sequence statements, collecting all effects + final verdict
compileAction env (EDo stmts) = compileDo env stmts
-- Fallback
compileAction _ _ = Just [object ["accept" .= Null]]
-- | Compile a do-block: each DSExpr is compiled and its [Value] contributions
-- are concatenated in order. DSBind is ignored for now.
compileDo :: Env -> [DoStmt] -> Maybe [Value]
compileDo _ [] = Nothing
compileDo env stmts =
let results = concatMap compileStmt stmts
in if null results then Nothing else Just results
where
compileStmt (DSBind _ e) = maybe [] id (compileAction env e)
compileStmt (DSExpr e) = maybe [] id (compileAction env e)
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
@@ -234,12 +624,14 @@ letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
] ]
letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object
[ "set" .= object [ "set" .= object
[ "family" .= ("inet" :: String) ( [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "name" .= n , "name" .= n
, "type" .= renderNftType (fwlTypeToNft t) , "type" .= renderNftType (fwlTypeToNft t)
, "elem" .= toJSON (map renderSetElem entries) ]
] ++ (if any isCidrElem entries then ["flags" .= toJSON (["interval"] :: [String])] else [])
++ [ "elem" .= toJSON (map renderSetElem entries) ]
)
] ]
letToSetOrMapValue _ _ _ _ = Nothing letToSetOrMapValue _ _ _ _ = Nothing
@@ -266,9 +658,9 @@ exprToVal (ELit (LCIDR ip p))= object
] ]
] ]
exprToVal (ELit l) = A.String (toText (renderLit l)) exprToVal (ELit l) = A.String (toText (renderLit l))
exprToVal (EVar n) = A.String (toText n) exprToVal (EVar n) = A.String (toText n)
exprToVal (EQual ns) = A.String (toText (intercalate "." ns)) exprToVal (EQual ns) = A.String (toText (intercalate "." ns))
exprToVal _ = A.String "_" exprToVal _ = A.String "_"
exprToConcatList :: Expr -> [Value] exprToConcatList :: Expr -> [Value]
exprToConcatList (ETuple es) = concatMap exprToConcatList es exprToConcatList (ETuple es) = concatMap exprToConcatList es
@@ -287,6 +679,10 @@ renderMapElem (k, v) = toJSON
renderSetElem :: Expr -> Value renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey renderSetElem = renderMapOrSetKey
isCidrElem :: Expr -> Bool
isCidrElem (ELit (LCIDR _ _)) = True
isCidrElem _ = False
-- ─── Aeson building blocks ─────────────────────────────────────────────────── -- ─── Aeson building blocks ───────────────────────────────────────────────────
matchExpr :: String -> Value -> Value -> Value matchExpr :: String -> Value -> Value -> Value
@@ -323,8 +719,8 @@ setVal vs = object ["set" .= toJSON vs]
-- ─── Expression helpers ─────────────────────────────────────────────────────── -- ─── Expression helpers ───────────────────────────────────────────────────────
isSetOrMapRef :: CompileEnv -> Name -> Bool isSetOrMapRef :: Env -> Name -> Bool
isSetOrMapRef env n = case Map.lookup n env of isSetOrMapRef env n = case Map.lookup n (declEnv env) of
Just (DLet _ _ _) -> True Just (DLet _ _ _) -> True
Just (DImport _ _ _) -> True Just (DImport _ _ _) -> True
_ -> False _ -> False
@@ -334,15 +730,16 @@ mapField "src" = "saddr"
mapField "dst" = "daddr" mapField "dst" = "daddr"
mapField f = f mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second. exprVal :: Env -> Expr -> Value
exprVal :: CompileEnv -> Expr -> Value exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]] exprVal _ (EQual ["meta", k]) = metaVal k
exprVal _ (EQual ["meta", k])= metaVal k exprVal _ (EQual ["th", k]) = payloadVal "th" k
exprVal _ (EQual ["th", k]) = payloadVal "th" k exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto"
exprVal _ (EQual [p, f]) = payloadVal p (mapField f) exprVal _ (EQual ["ip", "protocol"]) = metaVal "l4proto"
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns)) exprVal _ (EQual [p, f]) = payloadVal p (mapField f)
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns))
exprVal env (EVar n) exprVal env (EVar n)
| Just (DInterface _ _ _) <- Map.lookup n env = A.String (toText n) | Just (DInterface _ _ _) <- Map.lookup n (declEnv env) = A.String (toText n)
| isSetOrMapRef env n = A.String ("@" <> toText n) | isSetOrMapRef env n = A.String ("@" <> toText n)
| n == "iif" = metaVal "iifname" | n == "iif" = metaVal "iifname"
| n == "oif" = metaVal "oifname" | n == "oif" = metaVal "oifname"
@@ -372,9 +769,6 @@ exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es) exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
exprToStr _ = "_" exprToStr _ = "_"
-- Fix 2: Use Data.Text.pack via OverloadedStrings + fromString instead of
-- the fragile read(show s) hack. With OverloadedStrings enabled, string
-- literals already produce the correct Text/Key types; for runtime String
toText :: String -> T.Text toText :: String -> T.Text
toText = T.pack toText = T.pack
@@ -392,3 +786,11 @@ renderLit (LDuration n Millis) = show n ++ "ms"
renderLit (LDuration n Minutes) = show n ++ "m" renderLit (LDuration n Minutes) = show n ++ "m"
renderLit (LDuration n Hours) = show n ++ "h" renderLit (LDuration n Hours) = show n ++ "h"
renderLit (LHex b) = show b renderLit (LHex b) = show b
-- ─── Hex rendering helper (for ct mark values in comments) ───────────────────
hex32 :: Word32 -> String
hex32 w = "0x" ++ showHex w ""
-- silence unused warning for hex32 (used in potential debug output)
_ = hex32

View File

@@ -20,9 +20,10 @@ fwlDef = emptyDef
-- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must -- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must
-- NOT be reserved so that `identifier` can consume them in those -- NOT be reserved so that `identifier` can consume them in those
-- positions. -- positions.
[ "config", "table" [ "config"
, "interface", "zone", "import", "from" , "interface", "zone", "import", "from"
, "let", "in", "pattern", "flow", "rule", "policy", "on" , "let", "in", "pattern", "flow", "rule", "policy", "on"
, "portforward", "masquerade", "via", "src"
, "case", "of", "if", "then", "else", "do", "perform" , "case", "of", "if", "then", "else", "do", "perform"
, "within", "as", "dynamic", "cidr4", "cidr6" , "within", "as", "dynamic", "cidr4", "cidr6"
, "hook", "priority" , "hook", "priority"

View File

@@ -47,10 +47,10 @@ configBlock = do
configProp :: Parser (String, String) configProp :: Parser (String, String)
configProp = do configProp = do
reserved "table" n <- identifier -- "table" is no longer reserved
reservedOp "=" reservedOp "="
v <- stringLit v <- stringLit
return ("table", v) return (n, v)
-- ─── Declarations ──────────────────────────────────────────────────────────── -- ─── Declarations ────────────────────────────────────────────────────────────
@@ -63,6 +63,8 @@ decl = interfaceDecl
<|> flowDecl <|> flowDecl
<|> ruleDecl <|> ruleDecl
<|> policyDecl <|> policyDecl
<|> portforwardDecl
<|> masqueradeDecl
interfaceDecl :: Parser Decl interfaceDecl :: Parser Decl
interfaceDecl = do interfaceDecl = do
@@ -158,26 +160,31 @@ policyDecl = do
n <- identifier n <- identifier
reservedOp ":" reservedOp ":"
t <- typeP t <- typeP
reserved "on" reserved "hook"
pm <- braces policyMeta h <- hookP
mp <- optionMaybe (reserved "priority" >> priorityP)
let tb = hookDefaultTable h
pr = maybe (hookDefaultPriority h) id mp
reservedOp "=" reservedOp "="
ab <- armBlock ab <- armBlock
_ <- semi _ <- semi
return (DPolicy n t pm ab) return (DPolicy n t (PolicyMeta h tb pr) ab)
policyMeta :: Parser PolicyMeta -- | Infer table from hook
policyMeta = do hookDefaultTable :: Hook -> TableName
props <- commaSep1 metaProp hookDefaultTable HInput = TFilter
let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props hookDefaultTable HForward = TFilter
tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props hookDefaultTable HOutput = TFilter
pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) pFilter props hookDefaultTable HPrerouting = TNAT
return (PolicyMeta h tb pr) hookDefaultTable HPostrouting = TNAT
metaProp :: Parser (Either Hook (Either TableName Priority)) -- | Default priority per hook
metaProp hookDefaultPriority :: Hook -> Priority
= (reserved "hook" >> reservedOp "=" >> fmap (Left) hookP) hookDefaultPriority HInput = pFilter
<|> (reserved "table" >> reservedOp "=" >> fmap (Right . Left) tableNameP) hookDefaultPriority HForward = pFilter
<|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right) priorityP) hookDefaultPriority HOutput = pFilter
hookDefaultPriority HPrerouting = pDstNat
hookDefaultPriority HPostrouting = pSrcNat
hookP :: Parser Hook hookP :: Parser Hook
hookP = (reserved "Input" >> return HInput) hookP = (reserved "Input" >> return HInput)
@@ -186,9 +193,31 @@ hookP = (reserved "Input" >> return HInput)
<|> (reserved "Prerouting" >> return HPrerouting) <|> (reserved "Prerouting" >> return HPrerouting)
<|> (reserved "Postrouting" >> return HPostrouting) <|> (reserved "Postrouting" >> return HPostrouting)
tableNameP :: Parser TableName -- portforward <name> on <iface> via <MapType> = { entries };
tableNameP = (reserved "Filter" >> return TFilter) portforwardDecl :: Parser Decl
<|> (reserved "NAT" >> return TNAT) portforwardDecl = do
reserved "portforward"
n <- identifier
reserved "on"
iface <- identifier
reserved "via"
t <- typeP
reservedOp "="
entries <- braces (commaSep mapEntry)
_ <- semi
return (DPortForward n iface t entries)
-- masquerade <name> on <iface> src <set-name>;
masqueradeDecl :: Parser Decl
masqueradeDecl = do
reserved "masquerade"
n <- identifier
reserved "on"
iface <- identifier
reserved "src"
srcSet <- identifier
_ <- semi
return (DMasquerade n iface srcSet)
priorityP :: Parser Priority priorityP :: Parser Priority
priorityP priorityP

View File

@@ -31,11 +31,22 @@ prettyDecl (DFlow n f) =
prettyDecl (DRule n t e) = prettyDecl (DRule n t e) =
"rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";" "rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";"
prettyDecl (DPolicy n t pm ab) = prettyDecl (DPolicy n t pm ab) =
"policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++ "policy " ++ n ++ " : " ++ prettyType t ++
" on { hook = " ++ prettyHook (pmHook pm) ++ " hook " ++ prettyHook (pmHook pm) ++
", table = " ++ prettyTable (pmTable pm) ++ (if pmPriority pm /= prettyDefaultPriority (pmHook pm)
", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++ then " priority " ++ prettyNamedPriority (pmPriority pm)
else "") ++ "\n" ++
" = " ++ prettyArmBlock ab ++ ";" " = " ++ prettyArmBlock ab ++ ";"
prettyDecl (DPortForward n iface t entries) =
"portforward " ++ n ++ "\n" ++
" on " ++ iface ++ "\n" ++
" via " ++ prettyType t ++ " = {\n" ++
concatMap (\(k,v) -> " " ++ prettyExpr k ++ " -> " ++ prettyExpr v ++ "\n") entries ++
" };"
prettyDecl (DMasquerade n iface srcSet) =
"masquerade " ++ n ++ "\n" ++
" on " ++ iface ++ "\n" ++
" src " ++ srcSet ++ ";"
prettyKind :: IfaceKind -> String prettyKind :: IfaceKind -> String
prettyKind IWan = "WAN" prettyKind IWan = "WAN"
@@ -58,12 +69,24 @@ prettyHook HOutput = "Output"
prettyHook HPrerouting = "Prerouting" prettyHook HPrerouting = "Prerouting"
prettyHook HPostrouting = "Postrouting" prettyHook HPostrouting = "Postrouting"
prettyTable :: TableName -> String -- | Default priority for a hook (for round-trip: omit when at default)
prettyTable TFilter = "Filter" prettyDefaultPriority :: Hook -> Priority
prettyTable TNAT = "NAT" prettyDefaultPriority HInput = pFilter
prettyDefaultPriority HForward = pFilter
prettyDefaultPriority HOutput = pFilter
prettyDefaultPriority HPrerouting = pDstNat
prettyDefaultPriority HPostrouting = pSrcNat
prettyPriority :: Priority -> String -- | Emit a named priority constant when possible, otherwise decimal
prettyPriority p = show (priorityValue p) prettyNamedPriority :: Priority -> String
prettyNamedPriority p
| p == pFilter = "Filter"
| p == pDstNat = "DstNat"
| p == pSrcNat = "SrcNat"
| p == pMangle = "Mangle"
| p == pRaw = "Raw"
| p == pConnTrack= "ConnTrack"
| otherwise = show (priorityValue p)
prettyType :: Type -> String prettyType :: Type -> String
prettyType (TName n []) = n prettyType (TName n []) = n

View File

@@ -86,8 +86,7 @@ undefinedNameTests = testGroup "undefined names"
, testCase "policy guard references undeclared zone" $ , testCase "policy guard references undeclared zone" $
-- 'unknown_zone' not declared; check should flag it -- 'unknown_zone' not declared; check should flag it
assertHasError (isUndefined "unknown_zone") assertHasError (isUndefined "unknown_zone")
"policy fwd : Frame \ "policy fwd : Frame hook Forward \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | Frame(iif in unknown_zone -> wan, _) -> Allow; \ \ = { | Frame(iif in unknown_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
@@ -96,8 +95,7 @@ undefinedNameTests = testGroup "undefined names"
assertNoErrors assertNoErrors
"interface lan : LAN {}; \ "interface lan : LAN {}; \
\zone trusted = { lan }; \ \zone trusted = { lan }; \
\policy fwd : Frame \ \policy fwd : Frame hook Forward \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | Frame(iif in trusted -> wan, _) -> Allow; \ \ = { | Frame(iif in trusted -> wan, _) -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
@@ -124,11 +122,9 @@ duplicateTests = testGroup "duplicates"
, testCase "duplicate policy" $ , testCase "duplicate policy" $
assertHasError (isDuplicate "input") assertHasError (isDuplicate "input")
"policy input : Frame \ "policy input : Frame hook Input \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Allow; }; \ \ = { | _ -> Allow; }; \
\policy input : Frame \ \policy input : Frame hook Input \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };" \ = { | _ -> Drop; };"
, testCase "distinct names — no error" $ , testCase "distinct names — no error" $
@@ -144,23 +140,18 @@ policyTerminationTests :: TestTree
policyTerminationTests = testGroup "policy termination" policyTerminationTests = testGroup "policy termination"
[ testCase "last arm is Continue — error" $ [ testCase "last arm is Continue — error" $
assertHasError (isNoContinue "bad_policy") assertHasError (isNoContinue "bad_policy")
"policy bad_policy : Frame \ "policy bad_policy : Frame hook Input = { | _ -> Continue; };"
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Continue; };"
, testCase "last arm is Drop — ok" $ , testCase "last arm is Drop — ok" $
assertNoErrors assertNoErrors
"policy good : Frame \ "policy good : Frame hook Input \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \ \ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
, testCase "last arm is Allow — ok" $ , testCase "last arm is Allow — ok" $
assertNoErrors assertNoErrors
"policy output : Frame \ "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, testCase "Continue in non-last arm is fine" $ , testCase "Continue in non-last arm is fine" $
assertNoErrors assertNoErrors
@@ -172,9 +163,7 @@ policyTerminationTests = testGroup "policy termination"
, testCase "empty policy body — error" $ , testCase "empty policy body — error" $
assertHasError (isNoContinue "empty") assertHasError (isNoContinue "empty")
"policy empty : Frame \ "policy empty : Frame hook Output = {};"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
] ]
-- ─── Pattern cycle tests ───────────────────────────────────────────────────── -- ─── Pattern cycle tests ─────────────────────────────────────────────────────
@@ -207,14 +196,11 @@ cleanProgramTests = testGroup "clean programs"
\interface lan : LAN { cidr4 = { 10.17.1.0/24 }; }; \ \interface lan : LAN { cidr4 = { 10.17.1.0/24 }; }; \
\interface wg0 : WireGuard {}; \ \interface wg0 : WireGuard {}; \
\zone lan_zone = { lan, wg0 }; \ \zone lan_zone = { lan, wg0 }; \
\policy input : Frame \ \policy input : Frame hook Input \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \ \ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ }; \ \ }; \
\policy output : Frame \ \policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, testCase "pattern and flow declarations" $ , testCase "pattern and flow declarations" $
assertNoErrors assertNoErrors

View File

@@ -22,6 +22,9 @@ tests = testGroup "Compile"
, layerStrippingTests , layerStrippingTests
, continueTests , continueTests
, configTests , configTests
, filterInjectionTests
, portforwardCompileTests
, masqueradeCompileTests
] ]
-- ─── Helpers ───────────────────────────────────────────────────────────────── -- ─── Helpers ─────────────────────────────────────────────────────────────────
@@ -60,23 +63,16 @@ withKey k = filter (\v -> case at [k] v of Just _ -> True; _ -> False)
jsonStructureTests :: TestTree jsonStructureTests :: TestTree
jsonStructureTests = testGroup "JSON structure" jsonStructureTests = testGroup "JSON structure"
[ testCase "output is valid JSON" $ do [ testCase "output is valid JSON" $ do
_ <- compileToValue _ <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
return () return ()
, testCase "top-level nftables array present" $ do , testCase "top-level nftables array present" $ do
v <- compileToValue "policy output : Frame \ v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
_ <- nftArr v _ <- nftArr v
return () return ()
, testCase "metainfo is first element" $ do , testCase "metainfo is first element" $ do
v <- compileToValue "policy output : Frame \ v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case arr of case arr of
(first:_) -> case at ["metainfo"] first of (first:_) -> case at ["metainfo"] first of
@@ -85,17 +81,13 @@ jsonStructureTests = testGroup "JSON structure"
[] -> assertFailure "Empty nftables array" [] -> assertFailure "Empty nftables array"
, testCase "table object present" $ do , testCase "table object present" $ do
v <- compileToValue "policy output : Frame \ v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
assertBool "Expected at least one table object" assertBool "Expected at least one table object"
(not (null (withKey "table" arr))) (not (null (withKey "table" arr)))
, testCase "default table name is fwl" $ do , testCase "default table name is fwl" $ do
v <- compileToValue "policy output : Frame \ v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case withKey "table" arr of case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "fwl") (t:_) -> at ["table","name"] t @?= Just (A.String "fwl")
@@ -104,9 +96,7 @@ jsonStructureTests = testGroup "JSON structure"
, testCase "custom table name respected" $ do , testCase "custom table name respected" $ do
v <- compileToValue v <- compileToValue
"config { table = \"custom\"; } \ "config { table = \"custom\"; } \
\policy output : Frame \ \policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case withKey "table" arr of case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "custom") (t:_) -> at ["table","name"] t @?= Just (A.String "custom")
@@ -118,60 +108,42 @@ jsonStructureTests = testGroup "JSON structure"
chainTests :: TestTree chainTests :: TestTree
chainTests = testGroup "chain declarations" chainTests = testGroup "chain declarations"
[ testCase "filter input chain has correct hook" $ do [ testCase "filter input chain has correct hook" $ do
v <- compileToValue v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","hook"] c @?= Just (A.String "input") (c:_) -> at ["chain","hook"] c @?= Just (A.String "input")
[] -> assertFailure "No chain" [] -> assertFailure "No chain"
, testCase "filter chain type is filter" $ do , testCase "filter chain type is filter" $ do
v <- compileToValue v <- compileToValue "policy fwd : Frame hook Forward = { | _ -> Drop; };"
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "filter") (c:_) -> at ["chain","type"] c @?= Just (A.String "filter")
[] -> assertFailure "No chain" [] -> assertFailure "No chain"
, testCase "NAT chain type is nat" $ do , testCase "NAT chain type is nat" $ do
v <- compileToValue v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Allow; };"
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "nat") (c:_) -> at ["chain","type"] c @?= Just (A.String "nat")
[] -> assertFailure "No chain" [] -> assertFailure "No chain"
, testCase "input chain default policy is drop" $ do , testCase "input chain default policy is drop" $ do
v <- compileToValue v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "drop") (c:_) -> at ["chain","policy"] c @?= Just (A.String "drop")
[] -> assertFailure "No chain" [] -> assertFailure "No chain"
, testCase "output chain default policy is accept" $ do , testCase "output chain default policy is accept" $ do
v <- compileToValue v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "accept") (c:_) -> at ["chain","policy"] c @?= Just (A.String "accept")
[] -> assertFailure "No chain" [] -> assertFailure "No chain"
, testCase "chain name matches policy name" $ do , testCase "chain name matches policy name" $ do
v <- compileToValue v <- compileToValue "policy my_input : Frame hook Input = { | _ -> Drop; };"
"policy my_input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
case withKey "chain" arr of case withKey "chain" arr of
(c:_) -> at ["chain","name"] c @?= Just (A.String "my_input") (c:_) -> at ["chain","name"] c @?= Just (A.String "my_input")
@@ -179,12 +151,8 @@ chainTests = testGroup "chain declarations"
, testCase "two policies produce two chains" $ do , testCase "two policies produce two chains" $ do
v <- compileToValue v <- compileToValue
"policy input : Frame \ "policy input : Frame hook Input = { | _ -> Drop; }; \
\ on { hook = Input, table = Filter, priority = Filter } \ \policy output : Frame hook Output = { | _ -> Allow; };"
\ = { | _ -> Drop; }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
length (withKey "chain" arr) @?= 2 length (withKey "chain" arr) @?= 2
] ]
@@ -199,29 +167,14 @@ ruleExprs arr =
ruleExprTests :: TestTree ruleExprTests :: TestTree
ruleExprTests = testGroup "rule expressions" ruleExprTests = testGroup "rule expressions"
[ testCase "two arms produce two rules" $ do [ testCase "arm without guard produces rule" $ do
v <- compileToValue v <- compileToValue
"policy input : Frame \ "policy output : Frame hook Output = { | _ -> Allow; };"
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v arr <- nftArr v
length (withKey "rule" arr) @?= 2 assertBool "Should have at least one rule" (not (null (withKey "rule" arr)))
, testCase "arm without guard produces one rule" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "rule" arr) @?= 1
, testCase "rule expr array is present" $ do , testCase "rule expr array is present" $ do
v <- compileToValue v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
case withKey "rule" arr of case withKey "rule" arr of
(r:_) -> case at ["rule","expr"] r of (r:_) -> case at ["rule","expr"] r of
@@ -231,10 +184,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "IPv4 ctor emits nfproto match" $ do , testCase "IPv4 ctor emits nfproto match" $ do
v <- compileToValue v <- compileToValue
"policy input : Frame \ "policy input : Frame hook Input = \
\ on { hook = Input, table = Filter, priority = Filter } \ \ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \ \ | _ -> Drop; \
\ | _ -> Drop; \
\ };" \ };"
arr <- nftArr v arr <- nftArr v
let matches = withKey "match" (ruleExprs arr) let matches = withKey "match" (ruleExprs arr)
@@ -245,10 +197,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "record field pat emits payload match" $ do , testCase "record field pat emits payload match" $ do
v <- compileToValue v <- compileToValue
"policy input : Frame \ "policy input : Frame hook Input = \
\ on { hook = Input, table = Filter, priority = Filter } \ \ { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ = { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \ \ | _ -> Drop; \
\ | _ -> Drop; \
\ };" \ };"
arr <- nftArr v arr <- nftArr v
let matches = withKey "match" (ruleExprs arr) let matches = withKey "match" (ruleExprs arr)
@@ -269,28 +220,19 @@ allExprs arr =
verdictTests :: TestTree verdictTests :: TestTree
verdictTests = testGroup "verdicts" verdictTests = testGroup "verdicts"
[ testCase "Allow compiles to accept" $ do [ testCase "Allow compiles to accept" $ do
v <- compileToValue v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v arr <- nftArr v
assertBool "Expected accept verdict" assertBool "Expected accept verdict"
(not (null (withKey "accept" (allExprs arr)))) (not (null (withKey "accept" (allExprs arr))))
, testCase "Drop compiles to drop" $ do , testCase "Drop compiles to drop" $ do
v <- compileToValue v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
assertBool "Expected drop verdict" assertBool "Expected drop verdict"
(not (null (withKey "drop" (allExprs arr)))) (not (null (withKey "drop" (allExprs arr))))
, testCase "Masquerade compiles to masquerade" $ do , testCase "Masquerade compiles to masquerade" $ do
v <- compileToValue v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Masquerade; };"
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Masquerade; };"
arr <- nftArr v arr <- nftArr v
assertBool "Expected masquerade verdict" assertBool "Expected masquerade verdict"
(not (null (withKey "masquerade" (allExprs arr)))) (not (null (withKey "masquerade" (allExprs arr))))
@@ -298,9 +240,7 @@ verdictTests = testGroup "verdicts"
, testCase "rule call compiles to jump" $ do , testCase "rule call compiles to jump" $ do
v <- compileToValue v <- compileToValue
"rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \ "rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \
\policy fwd : Frame \ \policy fwd : Frame hook Forward = { | frame -> blockAll(frame); };"
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | frame -> blockAll(frame); };"
arr <- nftArr v arr <- nftArr v
assertBool "Expected jump verdict for rule call" assertBool "Expected jump verdict for rule call"
(not (null (withKey "jump" (allExprs arr)))) (not (null (withKey "jump" (allExprs arr))))
@@ -312,16 +252,14 @@ layerStrippingTests :: TestTree
layerStrippingTests = testGroup "layer stripping" layerStrippingTests = testGroup "layer stripping"
[ testCase "Frame with and without Ether both emit nfproto match" $ do [ testCase "Frame with and without Ether both emit nfproto match" $ do
let withEther = let withEther =
"policy p1 : Frame \ "policy p1 : Frame hook Input = \
\ on { hook = Input, table = Filter, priority = Filter } \ \ { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ = { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \ \ | _ -> Drop; \
\ | _ -> Drop; \
\ };" \ };"
withoutEther = withoutEther =
"policy p1 : Frame \ "policy p1 : Frame hook Input = \
\ on { hook = Input, table = Filter, priority = Filter } \ \ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \ \ | _ -> Drop; \
\ | _ -> Drop; \
\ };" \ };"
v1 <- compileToValue withEther v1 <- compileToValue withEther
v2 <- compileToValue withoutEther v2 <- compileToValue withoutEther
@@ -338,22 +276,11 @@ layerStrippingTests = testGroup "layer stripping"
continueTests :: TestTree continueTests :: TestTree
continueTests = testGroup "Continue" continueTests = testGroup "Continue"
[ testCase "two terminal arms produce two rules" $ do [ testCase "non-Continue arms still produce rules" $ do
v <- compileToValue v <- compileToValue
"policy fwd : Frame \ "policy input : Frame hook Input = \
\ on { hook = Forward, table = Filter, priority = Filter } \ \ { | _ if ct.state in { Established } -> Allow; \
\ = { | _ if ct.state in { Established } -> Allow; \ \ | _ -> Drop; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };" \ };"
arr <- nftArr v arr <- nftArr v
assertBool "Should have rules for non-Continue arms" assertBool "Should have rules for non-Continue arms"
@@ -365,20 +292,166 @@ continueTests = testGroup "Continue"
configTests :: TestTree configTests :: TestTree
configTests = testGroup "config" configTests = testGroup "config"
[ testCase "all rule objects reference correct table" $ do [ testCase "all rule objects reference correct table" $ do
v <- compileToValue v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl")) mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl"))
(withKey "rule" arr) (withKey "rule" arr)
, testCase "chain objects reference correct table" $ do , testCase "chain objects reference correct table" $ do
v <- compileToValue v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v arr <- nftArr v
mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl")) mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl"))
(withKey "chain" arr) (withKey "chain" arr)
] ]
-- ─── Filter-hook injection tests ─────────────────────────────────────────────
filterInjectionTests :: TestTree
filterInjectionTests = testGroup "filter hook injections"
[ testCase "Input chain first rule is stateful ct state" $ do
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
inputRules = filter (\r -> at ["rule","chain"] r == Just (A.String "input")) rules
case inputRules of
(r:_) -> case at ["rule","expr","0","match","left","ct","key"] r of
Just (A.String "state") -> return ()
_ -> case at ["rule","expr"] r of
Just (A.Array es) ->
let exprs = V.toList es
hasState = any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) exprs
in assertBool "First rule should have ct state match" hasState
_ -> assertFailure "No expr in first rule"
[] -> assertFailure "No rules for input chain"
, testCase "Input chain has loopback rule (iifname lo)" $ do
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
inputRules = filter (\r -> at ["rule","chain"] r == Just (A.String "input")) rules
hasLo = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","right"] e == Just (A.String "lo")) (V.toList es)
_ -> False) inputRules
assertBool "Input chain should have iifname lo rule" hasLo
, testCase "Forward chain first rule is stateful ct state" $ do
v <- compileToValue "policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
fwdRules = filter (\r -> at ["rule","chain"] r == Just (A.String "forward")) rules
case fwdRules of
(r:_) -> case at ["rule","expr"] r of
Just (A.Array es) ->
let hasState = any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) (V.toList es)
in assertBool "First forward rule should have ct state match" hasState
_ -> assertFailure "No expr"
[] -> assertFailure "No rules for forward chain"
, testCase "Output chain has stateful rule but no loopback" $ do
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
let rules = withKey "rule" arr
outRules = filter (\r -> at ["rule","chain"] r == Just (A.String "output")) rules
hasState = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) (V.toList es)
_ -> False) outRules
hasLo = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e -> at ["match","right"] e == Just (A.String "lo")) (V.toList es)
_ -> False) outRules
assertBool "Output chain should have ct state rule" hasState
assertBool "Output chain should NOT have loopback rule" (not hasLo)
]
-- ─── PortForward compile tests ───────────────────────────────────────────────
portforwardCompileTests :: TestTree
portforwardCompileTests = testGroup "portforward compilation"
[ testCase "portforward produces a map object with the decl name" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let maps = withKey "map" arr
named = filter (\m -> at ["map","name"] m == Just (A.String "wan_forwards")) maps
assertBool "Should have a map named wan_forwards" (not (null named))
, testCase "portforward produces prerouting chain" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let chains = withKey "chain" arr
preChain = filter (\c ->
at ["chain","name"] c == Just (A.String "wan_forwards_prerouting")) chains
assertBool "Should have wan_forwards_prerouting chain" (not (null preChain))
case preChain of
(c:_) -> do
at ["chain","type"] c @?= Just (A.String "nat")
at ["chain","hook"] c @?= Just (A.String "prerouting")
[] -> return ()
, testCase "portforward injects ct status dnat accept into Forward chain" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
fwdRules = filter (\r -> at ["rule","chain"] r == Just (A.String "forward")) rules
hasDnat = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","left","ct","key"] e == Just (A.String "status")) (V.toList es)
_ -> False) fwdRules
assertBool "Forward chain should have ct status dnat rule when portforward present" hasDnat
]
-- ─── Masquerade compile tests ────────────────────────────────────────────────
masqueradeCompileTests :: TestTree
masqueradeCompileTests = testGroup "masquerade compilation"
[ testCase "masquerade produces postrouting chain" $ do
v <- compileToValue
"let rfc1918 : Set<IPv4> = { 10.0.0.0/8 }; \
\masquerade wan_snat on wan src rfc1918;"
arr <- nftArr v
let chains = withKey "chain" arr
postChain = filter (\c ->
at ["chain","name"] c == Just (A.String "wan_snat_postrouting")) chains
assertBool "Should have wan_snat_postrouting chain" (not (null postChain))
case postChain of
(c:_) -> do
at ["chain","type"] c @?= Just (A.String "nat")
at ["chain","hook"] c @?= Just (A.String "postrouting")
[] -> return ()
, testCase "masquerade rule has oifname match and masquerade verdict" $ do
v <- compileToValue
"let rfc1918 : Set<IPv4> = { 10.0.0.0/8 }; \
\masquerade wan_snat on wan src rfc1918;"
arr <- nftArr v
let rules = withKey "rule" arr
snatRules = filter (\r ->
at ["rule","chain"] r == Just (A.String "wan_snat_postrouting")) rules
hasOifname = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","left","meta","key"] e == Just (A.String "oifname")) (V.toList es)
_ -> False) snatRules
hasMasq = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["masquerade"] e /= Nothing) (V.toList es)
_ -> False) snatRules
assertBool "Masquerade rule should match oifname" hasOifname
assertBool "Masquerade rule should have masquerade verdict" hasMasq
]

View File

@@ -17,6 +17,8 @@ tests = testGroup "Parser"
, typeTests , typeTests
, exprTests , exprTests
, policyTests , policyTests
, portforwardTests
, masqueradeTests
, ruleTests , ruleTests
, configTests , configTests
, errorTests , errorTests
@@ -351,31 +353,38 @@ exprTests = testGroup "expressions"
policyTests :: TestTree policyTests :: TestTree
policyTests = testGroup "policy" policyTests = testGroup "policy"
[ testCase "minimal policy" $ do [ testCase "compact hook Input syntax" $ do
p <- parseOk p <- parseOk "policy input : Frame hook Input = { | _ -> Drop; };"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
d <- singleDecl p d <- singleDecl p
case d of case d of
DPolicy "output" _ (PolicyMeta HOutput TFilter (Priority 0)) [_] -> return () DPolicy "input" _ (PolicyMeta HInput TFilter (Priority 0)) [_] -> return ()
_ -> assertFailure (show d) _ -> assertFailure (show d)
, testCase "NAT prerouting" $ do , testCase "hook Prerouting priority Mangle" $ do
p <- parseOk p <- parseOk
"policy nat_pre : Frame \ "policy pre : Frame hook Prerouting priority Mangle = { | _ -> Drop; };"
\ on { hook = Prerouting, table = NAT, priority = DstNat } \
\ = { | _ -> Allow; };"
d <- singleDecl p d <- singleDecl p
case d of case d of
DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-100))) _ -> return () DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-150))) _ -> return ()
_ -> assertFailure (show d)
, testCase "hook Forward infers filter table and priority 0" $ do
p <- parseOk "policy forward : Frame hook Forward = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HForward TFilter (Priority 0)) _ -> return ()
_ -> assertFailure (show d)
, testCase "hook Postrouting infers nat table and priority 100" $ do
p <- parseOk "policy post : Frame hook Postrouting = { | _ -> Allow; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HPostrouting TNAT (Priority 100)) _ -> return ()
_ -> assertFailure (show d) _ -> assertFailure (show d)
, testCase "arm with guard" $ do , testCase "arm with guard" $ do
p <- parseOk p <- parseOk
"policy input : Frame \ "policy input : Frame hook Input = { \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
\ | _ if ct.state in { Established, Related } -> Allow; \ \ | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
@@ -386,9 +395,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern with path" $ do , testCase "Frame pattern with path" $ do
p <- parseOk p <- parseOk
"policy forward : Frame \ "policy forward : Frame hook Forward = { \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
\ | Frame(iif in lan_zone -> wan, _) -> Allow; \ \ | Frame(iif in lan_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
@@ -399,9 +406,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern without Ether (layer stripping)" $ do , testCase "Frame pattern without Ether (layer stripping)" $ do
p <- parseOk p <- parseOk
"policy input : Frame \ "policy input : Frame hook Input = { \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
\ | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \ \ | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \
\ | _ -> Drop; \ \ | _ -> Drop; \
\ };" \ };"
@@ -412,9 +417,7 @@ policyTests = testGroup "policy"
, testCase "policy arm calls rule" $ do , testCase "policy arm calls rule" $ do
p <- parseOk p <- parseOk
"policy forward : Frame \ "policy forward : Frame hook Forward = { \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
\ | frame -> blockOutboundWG(frame); \ \ | frame -> blockOutboundWG(frame); \
\ };" \ };"
d <- singleDecl p d <- singleDecl p
@@ -435,6 +438,36 @@ policyTests = testGroup "policy"
_ -> assertFailure (show d) _ -> assertFailure (show d)
] ]
-- ─── PortForward ─────────────────────────────────────────────────────────────
portforwardTests :: TestTree
portforwardTests = testGroup "portforward"
[ testCase "basic portforward decl" $ do
p <- parseOk
"portforward wan_forwards \
\ on wan \
\ via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\ };"
d <- singleDecl p
case d of
DPortForward "wan_forwards" "wan" (TName "Map" [TTuple _, TTuple _]) [(_, _)] -> return ()
DPortForward "wan_forwards" "wan" _ [_] -> return ()
_ -> assertFailure (show d)
]
-- ─── Masquerade ──────────────────────────────────────────────────────────────
masqueradeTests :: TestTree
masqueradeTests = testGroup "masquerade"
[ testCase "basic masquerade decl" $ do
p <- parseOk "masquerade wan_snat on wan src rfc1918;"
d <- singleDecl p
case d of
DMasquerade "wan_snat" "wan" "rfc1918" -> return ()
_ -> assertFailure (show d)
]
-- ─── Rule ──────────────────────────────────────────────────────────────────── -- ─── Rule ────────────────────────────────────────────────────────────────────
ruleTests :: TestTree ruleTests :: TestTree
@@ -495,17 +528,18 @@ errorTests = testGroup "parse errors"
[ testCase "missing semicolon" $ [ testCase "missing semicolon" $
parseFail "interface wan : WAN {}" parseFail "interface wan : WAN {}"
, testCase "unknown hook" $ , testCase "old on-brace policy syntax is a parse error" $
parseFail parseFail
"policy p : Frame \ "policy p : Frame \
\ on { hook = Bogus, table = Filter, priority = Filter } \ \ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };" \ = { | _ -> Allow; };"
, testCase "unknown hook" $
parseFail
"policy p : Frame hook Bogus = { | _ -> Allow; };"
, testCase "empty arm block with no arms is ok" $ do , testCase "empty arm block with no arms is ok" $ do
p <- parseOk p <- parseOk "policy output : Frame hook Output = {};"
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
d <- singleDecl p d <- singleDecl p
case d of case d of
DPolicy _ _ _ [] -> return () DPolicy _ _ _ [] -> return ()