CaZzzer/fwl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: CaZzzer:9390647f7ad2d0e34927552630d67c46a4f37033
Branches Tags
CaZzzer:master CaZzzer:v2-1 CaZzzer:v2
..
compare: CaZzzer:v2
Branches Tags
CaZzzer:v2-1 CaZzzer:v2 CaZzzer:master

2 Commits
9390647f7a ... v2

Author SHA1 Message Date
Yuri Tatishchev
6d96e2d159 crazy mega refactor 2026-05-04 03:16:40 -07:00
Yuri
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
13 changed files with 915 additions and 670 deletions
Expand all files Collapse all files

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

178
doc/fwl_grammar.md
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.

80
examples/simple-router.fwl
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;
};

407
examples/simple-router.fwl.json
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"
}
} }
] ]
} }

20
src/FWL/AST.hs
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

12
src/FWL/Check.hs
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]

225
src/FWL/Compile.hs
View File

@@ -32,23 +32,173 @@ compileProgram = programToValue
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 env = buildEnv decls
tbl = configTable cfg 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) hasPortFwd = not (null portfwds)
policies
-- Chain declarations: policy chains + synthesised NAT chains
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
masqChainObjs = concatMap (masqChainValue tbl) masqs
-- Rules: policy arms + implicit injections + synthesised NAT rules
policyRuleObjs = concatMap
(\(n, pm, ab) ->
injectFilterRules env tbl n pm hasPortFwd ++
concatMap (armToRuleValues env tbl n) ab)
policies
pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
-- 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
++ pfMapObjs ++ mapObjs
++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs
-- ─── Implicit filter-hook rule injection ─────────────────────────────────────
-- | Prepend implicit rules for filter-hook chains (Input/Forward/Output).
injectFilterRules :: CompileEnv -> 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]
]
-- silence unused env warning
_ = env
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 :: CompileEnv -> 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 :: CompileEnv -> 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 ──────────────────────────────────────────────
@@ -117,14 +267,16 @@ type CompileEnv = Map.Map String Decl
buildEnv :: [Decl] -> CompileEnv buildEnv :: [Decl] -> CompileEnv
buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty
where where
declNameOf (DInterface n _ _) = n declNameOf (DInterface n _ _) = n
declNameOf (DZone n _) = n declNameOf (DZone n _) = n
declNameOf (DPattern n _ _) = n declNameOf (DPattern n _ _) = n
declNameOf (DFlow n _) = n declNameOf (DFlow n _) = n
declNameOf (DRule n _ _) = n declNameOf (DRule n _ _) = n
declNameOf (DPolicy n _ _ _) = n declNameOf (DPolicy n _ _ _) = n
declNameOf (DLet n _ _) = n declNameOf (DLet n _ _) = n
declNameOf (DImport n _ _) = n declNameOf (DImport n _ _) = n
declNameOf (DPortForward n _ _ _) = n
declNameOf (DMasquerade n _ _) = n
compilePat :: CompileEnv -> Pat -> [[Value]] compilePat :: CompileEnv -> Pat -> [[Value]]
compilePat _ PWild = [[]] compilePat _ PWild = [[]]
@@ -234,12 +386,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
@@ -287,6 +441,11 @@ renderMapElem (k, v) = toJSON
renderSetElem :: Expr -> Value renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey renderSetElem = renderMapOrSetKey
-- | True if an expression is a CIDR literal (requires 'interval' flag in nftables set)
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
@@ -336,11 +495,13 @@ mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second. -- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
exprVal :: CompileEnv -> 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 [p, f]) = payloadVal p (mapField f) exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto" -- nexthdr alias via l4proto
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns)) exprVal _ (EQual ["ip", "protocol"]) = metaVal "l4proto"
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 env = A.String (toText n)
| isSetOrMapRef env n = A.String ("@" <> toText n) | isSetOrMapRef env n = A.String ("@" <> toText n)

3
src/FWL/Lexer.hs
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"

71
src/FWL/Parser.hs
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

41
src/FWL/Pretty.hs
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

34
test/CheckTests.hs
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

317
test/CompileTests.hs
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
]

92
test/ParserTests.hs
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 ()