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
cabal build # build everything
cabal test # run all test suites
cabal run fwlc -- check examples/router.fwl # parse + type-check a source file
cabal run fwlc -- compile examples/router.fwl # emit nftables JSON to stdout
cabal run fwlc -- pretty examples/router.fwl # pretty-print the parsed AST
cabal run fwlc -- check examples/simple-router.fwl # parse + type-check a source file
cabal run fwlc -- compile examples/simple-router.fwl # emit nftables JSON to stdout
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`.
@@ -25,22 +25,24 @@ Run tests before marking any task complete. The test suite is `cabal test`.
fwl/
├── AGENTS.md
├── doc/
│ ├── proposal.md ← initial design document and exploration
│ ├── fwl_grammar.md ← authoritative grammar reference; keep in sync with Parser.hs
│ ├── proposal.md <- initial design document and exploration
│ ├── fwl_grammar.md <- authoritative grammar reference; keep in sync with Parser.hs
│ └── ref/
│ ├── ruleset.nft ← example nftables ruleset
│ └── ruleset.json ← the same example nftables ruleset in json format
│ ├── ruleset.nft <- example nftables ruleset
│ └── ruleset.json <- the same example nftables ruleset in json format
├── 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/
│ ├── AST.hs ← all data types; source of truth for the AST
│ ├── Lexer.hs ← Parsec TokenParser, reservedNames, reservedOpNames
│ ├── Parser.hs ← top-level parser, all sub-parsers
│ ├── Pretty.hs ← AST → FWL source (round-trip printer)
│ ├── TypeCheck.hs ← effect row checker, exhaustiveness, CIDR intervals
│ ├── Interpret.hs ← evaluator + effect dispatch
│ ├── Compile.hs ← AST → nftables JSON (Aeson Value)
│ └── Util.hs ← shared helpers
│ ├── AST.hs <- all data types; source of truth for the AST
│ ├── Lexer.hs <- Parsec TokenParser, reservedNames, reservedOpNames
│ ├── Parser.hs <- top-level parser, all sub-parsers
│ ├── Pretty.hs <- AST -> FWL source (round-trip printer)
│ ├── TypeCheck.hs <- effect row checker, exhaustiveness, CIDR intervals
│ ├── Interpret.hs <- evaluator + effect dispatch
│ ├── Compile.hs <- AST -> nftables JSON (Aeson Value)
│ └── Util.hs <- shared helpers
└── test/
├── Main.hs
├── ParserTests.hs
@@ -48,7 +50,7 @@ fwl/
└── 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.
---
@@ -59,15 +61,29 @@ The pipeline is strictly linear with no back-edges:
```
source text
→ Lexer (Text.Parsec.Token)
→ Parser → [Decl] (AST.hs)
→ TypeCheck → TypedDecl
→ Compile → Aeson Value (nftables JSON)
-> Lexer (Text.Parsec.Token)
-> Parser -> [Decl] (AST.hs)
-> TypeCheck -> TypedDecl
-> Compile -> Aeson Value (nftables JSON)
```
The interpreter (`Interpret.hs`) runs the policy against a mock packet environment
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
@@ -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`
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
@@ -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.
- `Frame` and `FlowPattern` are NOT in `reservedNames`; they appear as type
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.
- Priority assertions use `Priority n` directly, e.g. `Priority 0`, `Priority (-100)`.
- 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
- Read any file, list directories
- 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
### ⚠️ Ask first
- Add or remove Cabal dependencies (`fwl.cabal`)
- Rename or delete source modules
- 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
- 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
- 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
> **Version:** MVP
> **Last updated:** May 2026
> **Version:** MVP
> **Last updated:** May 2026
> 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.
@@ -14,6 +14,8 @@
- **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.
- **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
| flowDecl
| ruleDecl
| portforwardDecl
| masqueradeDecl
| policyDecl
```
@@ -60,23 +64,104 @@ flowExpr ::= ident
| ident "." ident "within" duration
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
"on" "{"
"hook" "=" hook ","
"table" "=" tableName ","
"priority" "=" priority
"}"
"hook" hook ( "priority" priority )?
"=" 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
hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting"
tableName ::= "Filter" | "NAT" | ident
-- Priority is always an integer in nftables JSON.
-- Named constants are resolved at parse time:
-- Raw = -300, ConnTrack = -200, Mangle = -150,
@@ -127,7 +212,7 @@ stmt ::= "let" ident "=" expr
infixExpr ::= prefixExpr { infixOp prefixExpr }
infixOp ::= "&&" | "||" | "==" | "!=" | "<" | "<=" | ">" | ">="
| "++" | ">>" | ">>=" | "∈" | "in"
| "++" | ">>" | ">>=" | "\u2208" | "in"
prefixExpr ::= "!" prefixExpr | appExpr
@@ -136,7 +221,7 @@ appExpr ::= atom { atom }
atom ::= performExpr
| mapLit -- { expr -> expr, ... } tried before setLit
| setLit -- { expr, ... }
| tupleLit -- ( expr, expr, ... ) requires ≥ 2
| tupleLit -- ( expr, expr, ... ) requires >= 2
| "(" expr ")"
| literal
| portLit -- :22 :8080
@@ -161,7 +246,7 @@ qualName ::= ident { "." ident }
```ebnf
pat ::= wildcardPat -- _
| framePat -- Frame(...)
| tuplePat -- (p, p, ...) requires ≥ 2
| tuplePat -- (p, p, ...) requires >= 2
| bytesPat -- [ byteElem* ]
| recordPat -- Ctor { field = lit, ... }
| namedOrCtorPat -- Ctor(p,...) or bare identifier
@@ -175,7 +260,7 @@ frameArgs ::= pathPat "," pat -- with explicit path
pathPat ::= endpointPat? ( "->" endpointPat? )?
endpointPat ::= "_"
| ident "in" ident -- iif in lan_zone
| ident "∈" ident
| ident "\u2208" ident
| ident
tuplePat ::= "(" pat "," pat { "," pat } ")"
@@ -188,7 +273,7 @@ byteElem ::= hexByte -- 0xff
recordPat ::= ident "{" fieldPat { "," fieldPat } "}"
fieldPat ::= ident "=" fieldLit -- exact match
| ident "in" expr -- membership
| ident "∈" expr
| ident "\u2208" expr
| ident "as" ident -- bind with alias
| ident -- bind to same name
@@ -222,7 +307,7 @@ literal ::= ipOrCidrLit
portLit ::= ":" nat -- :22, :8080, :51944
ipOrCidrLit ::= ipLit ( "/" nat )? -- optional prefix → CIDR
ipOrCidrLit ::= ipLit ( "/" nat )? -- optional prefix -> CIDR
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):
```
config table interface zone import from
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
@@ -283,6 +369,9 @@ Raw ConnTrack
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
(type names, constructors, action values, effect labels):
@@ -291,7 +380,7 @@ Frame FlowPattern
Allow Drop Continue Masquerade DNAT DNATMap
Log Info Warn Error
Matched Unmatched
Action Packet IP Port Protocol
Action Packet IP IPv4 IPv6 Port Protocol
CIDRSet Map Bytes
```
@@ -320,7 +409,7 @@ From lowest to highest binding:
| Level | Operators | Associativity |
|-------|------------------------|---------------|
| 1 | `if … then … else` | — |
| 1 | `if ... then ... else` | — |
| 2 | `\|\|` | left |
| 3 | `&&` | left |
| 4 | `==` `!=` | none |
@@ -344,6 +433,23 @@ interface wg0 : WireGuard {};
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
```fwl
@@ -382,18 +488,28 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
};
```
### Policy
### Policy (new compact hook syntax)
```fwl
policy input : Frame
on { hook = Input, table = Filter, priority = Filter } =
{
| _ if ct.state in { Established, Related } -> Allow;
| Frame(lo, _) -> Allow;
| Frame(_, Ether(_, IPv4(_, TCP(tcp, _))))
if tcp.dport == :22 -> Allow;
| Frame(_, Ether(_, IPv4(_, UDP(udp, _))))
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
-- stateful, loopback, and ndp are injected automatically by the compiler.
-- No need to write them in the arm list.
policy input : Frame hook Input = {
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport in open_ports -> Allow;
| Frame(_, IPv4(_, UDP(udp, _)))
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 lan : LAN { cidr4 = { 10.0.0.0/24 }; };
interface wan : WAN { dynamic; };
interface lan : LAN { cidr4 = { 10.0.0.0/24 }; };
zone lan_zone = { lan };
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 };
-- IPv6 forwarded destination: tcp . 2001:db8::1 . 22000
let forwards_v6 : Set<(Protocol, IP, Port)> = {
(tcp, 2001:db8::1, :22000)
let forwards_v6 : Set<(Protocol, IPv6, Port)> = {
(tcp, 2001:db8::1, :22000)
};
policy input : Frame
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;
portforward wan_forwards
on wan
via Map<(Protocol, Port), (IPv4, Port)> = {
(tcp, :8080) -> (10.0.0.10, :80)
};
masquerade wan_snat
on wan
src rfc1918;
policy input : Frame hook Input = {
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport in open_ports -> Allow;
if tcp.dport in open_ports -> Allow;
| Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
policy forward : Frame
on { hook = Forward, table = Filter, priority = Filter }
= {
| _ 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;
policy forward : Frame hook Forward = {
| 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;
};
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;
};
if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow;
| _ -> Drop;
};

407
examples/simple-router.fwl.json
View File

@@ -33,22 +33,11 @@
"type": "filter"
}
},
{
"chain": {
"family": "inet",
"hook": "output",
"name": "output",
"policy": "accept",
"prio": 0,
"table": "fwl",
"type": "filter"
}
},
{
"chain": {
"family": "inet",
"hook": "prerouting",
"name": "nat_prerouting",
"name": "wan_forwards_prerouting",
"policy": "accept",
"prio": -100,
"table": "fwl",
@@ -59,41 +48,13 @@
"chain": {
"family": "inet",
"hook": "postrouting",
"name": "nat_postrouting",
"name": "wan_snat_postrouting",
"policy": "accept",
"prio": 100,
"table": "fwl",
"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": {
"elem": [
@@ -117,7 +78,7 @@
"ipv4_addr",
"inet_service"
],
"name": "forwards",
"name": "wan_forwards",
"table": "fwl",
"type": [
"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": {
"elem": [
@@ -152,7 +144,7 @@
"table": "fwl",
"type": [
"inet_proto",
"ipv4_addr",
"ipv6_addr",
"inet_service"
]
}
@@ -168,11 +160,13 @@
"key": "state"
}
},
"op": "in",
"right": [
"established",
"related"
]
"op": "==",
"right": {
"set": [
"established",
"related"
]
}
}
},
{
@@ -210,17 +204,6 @@
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv6"
}
},
{
"match": {
"left": {
@@ -244,7 +227,7 @@
"op": "==",
"right": {
"prefix": {
"addr": "fe80:0:0:0:0:0:0:0",
"addr": "fe80::",
"len": 10
}
}
@@ -373,11 +356,13 @@
"key": "state"
}
},
"op": "in",
"right": [
"established",
"related"
]
"op": "==",
"right": {
"set": [
"established",
"related"
]
}
}
},
{
@@ -399,7 +384,7 @@
"key": "status"
}
},
"op": "==",
"op": "in",
"right": "dnat"
}
},
@@ -449,170 +434,6 @@
"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": {
"chain": "forward",
@@ -670,9 +491,8 @@
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip6"
"meta": {
"key": "l4proto"
}
},
{
@@ -758,9 +578,8 @@
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip6"
"meta": {
"key": "l4proto"
}
},
{
@@ -803,19 +622,7 @@
},
{
"rule": {
"chain": "output",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"chain": "wan_forwards_prerouting",
"expr": [
{
"match": {
@@ -835,46 +642,53 @@
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
"op": "in",
"right": {
"set": [
"tcp",
"udp"
]
}
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
"fib": {
"flags": [
"daddr"
],
"result": "type"
}
},
"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",
@@ -883,19 +697,7 @@
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_postrouting",
"chain": "wan_snat_postrouting",
"expr": [
{
"match": {
@@ -908,17 +710,6 @@
"right": "wan"
}
},
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
@@ -938,18 +729,6 @@
"family": "inet",
"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 ───────────────────────────────────────────────────────────
data Decl
= DInterface Name IfaceKind [IfaceProp]
| DZone Name [Name]
| DImport Name Type FilePath
| DLet Name Type Expr
| DPattern Name Type Pat
| DFlow Name FlowExpr
| DRule Name Type Expr
| DPolicy Name Type PolicyMeta ArmBlock
= DInterface Name IfaceKind [IfaceProp]
| DZone Name [Name]
| DImport Name Type FilePath
| DLet Name Type Expr
| DPattern Name Type Pat
| DFlow Name FlowExpr
| DRule Name Type Expr
| 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)
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 (DRule n _ _) = Map.insert n KRule 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 decls = go [] Set.empty decls
@@ -70,6 +72,8 @@ declName (DPattern n _ _) = n
declName (DFlow n _) = n
declName (DRule n _ _) = n
declName (DPolicy n _ _ _) = n
declName (DPortForward n _ _ _) = n
declName (DMasquerade n _ _) = n
declKindStr :: Decl -> String
declKindStr (DInterface _ _ _) = "interface"
@@ -80,6 +84,8 @@ declKindStr (DPattern _ _ _) = "pattern"
declKindStr (DFlow _ _) = "flow"
declKindStr (DRule _ _ _) = "rule"
declKindStr (DPolicy _ _ _ _) = "policy"
declKindStr (DPortForward _ _ _ _) = "portforward"
declKindStr (DMasquerade _ _ _) = "masquerade"
-- ─── Name resolution ─────────────────────────────────────────────────────────
@@ -90,6 +96,12 @@ checkDecl env (DFlow _ fe) = checkFlow env fe
checkDecl env (DRule _ _ e) = checkExpr env e
checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab
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 _ _ = []
checkName :: Env -> String -> String -> [CheckError]

225
src/FWL/Compile.hs
View File

@@ -32,23 +32,173 @@ compileProgram = programToValue
programToValue :: Program -> Value
programToValue (Program cfg decls) =
object [ "nftables" .= toJSON
(metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
(metainfo : tableObj : allObjects) ]
where
env = buildEnv decls
tbl = configTable cfg
env = buildEnv decls
tbl = configTable cfg
metainfo = object [ "metainfo" .= object
[ "json_schema_version" .= (1 :: Int) ] ]
tableObj = object [ "table" .= tableValue tbl ]
metainfo = object [ "metainfo" .= object
[ "json_schema_version" .= (1 :: Int) ] ]
tableObj = object [ "table" .= tableValue tbl ]
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies
ruleObjs = concatMap
(\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab)
policies
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
portfwds = [ d | d@(DPortForward {}) <- decls ]
masqs = [ d | d@(DMasquerade {}) <- decls ]
hasPortFwd = not (null portfwds)
-- 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 ──────────────────────────────────────────────
@@ -117,14 +267,16 @@ type CompileEnv = Map.Map String Decl
buildEnv :: [Decl] -> CompileEnv
buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) 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 (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
compilePat :: CompileEnv -> Pat -> [[Value]]
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
[ "set" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= renderNftType (fwlTypeToNft t)
, "elem" .= toJSON (map renderSetElem entries)
]
( [ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= renderNftType (fwlTypeToNft t)
]
++ (if any isCidrElem entries then ["flags" .= toJSON (["interval"] :: [String])] else [])
++ [ "elem" .= toJSON (map renderSetElem entries) ]
)
]
letToSetOrMapValue _ _ _ _ = Nothing
@@ -287,6 +441,11 @@ renderMapElem (k, v) = toJSON
renderSetElem :: Expr -> Value
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 ───────────────────────────────────────────────────
matchExpr :: String -> Value -> Value -> Value
@@ -336,11 +495,13 @@ mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
exprVal :: CompileEnv -> Expr -> Value
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
exprVal _ (EQual ["meta", k])= metaVal k
exprVal _ (EQual ["th", k]) = payloadVal "th" k
exprVal _ (EQual [p, f]) = payloadVal p (mapField f)
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns))
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
exprVal _ (EQual ["meta", k]) = metaVal k
exprVal _ (EQual ["th", k]) = payloadVal "th" k
exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto" -- nexthdr alias via l4proto
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)
| Just (DInterface _ _ _) <- Map.lookup n env = 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
-- NOT be reserved so that `identifier` can consume them in those
-- positions.
[ "config", "table"
[ "config"
, "interface", "zone", "import", "from"
, "let", "in", "pattern", "flow", "rule", "policy", "on"
, "portforward", "masquerade", "via", "src"
, "case", "of", "if", "then", "else", "do", "perform"
, "within", "as", "dynamic", "cidr4", "cidr6"
, "hook", "priority"

71
src/FWL/Parser.hs
View File

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

41
src/FWL/Pretty.hs
View File

@@ -31,11 +31,22 @@ prettyDecl (DFlow n f) =
prettyDecl (DRule n t e) =
"rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";"
prettyDecl (DPolicy n t pm ab) =
"policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++
" on { hook = " ++ prettyHook (pmHook pm) ++
", table = " ++ prettyTable (pmTable pm) ++
", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++
"policy " ++ n ++ " : " ++ prettyType t ++
" hook " ++ prettyHook (pmHook pm) ++
(if pmPriority pm /= prettyDefaultPriority (pmHook pm)
then " priority " ++ prettyNamedPriority (pmPriority pm)
else "") ++ "\n" ++
" = " ++ 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 IWan = "WAN"
@@ -58,12 +69,24 @@ prettyHook HOutput = "Output"
prettyHook HPrerouting = "Prerouting"
prettyHook HPostrouting = "Postrouting"
prettyTable :: TableName -> String
prettyTable TFilter = "Filter"
prettyTable TNAT = "NAT"
-- | Default priority for a hook (for round-trip: omit when at default)
prettyDefaultPriority :: Hook -> Priority
prettyDefaultPriority HInput = pFilter
prettyDefaultPriority HForward = pFilter
prettyDefaultPriority HOutput = pFilter
prettyDefaultPriority HPrerouting = pDstNat
prettyDefaultPriority HPostrouting = pSrcNat
prettyPriority :: Priority -> String
prettyPriority p = show (priorityValue p)
-- | Emit a named priority constant when possible, otherwise decimal
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 (TName n []) = n

34
test/CheckTests.hs
View File

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

317
test/CompileTests.hs
View File

@@ -22,6 +22,9 @@ tests = testGroup "Compile"
, layerStrippingTests
, continueTests
, configTests
, filterInjectionTests
, portforwardCompileTests
, masqueradeCompileTests
]
-- ─── Helpers ─────────────────────────────────────────────────────────────────
@@ -60,23 +63,16 @@ withKey k = filter (\v -> case at [k] v of Just _ -> True; _ -> False)
jsonStructureTests :: TestTree
jsonStructureTests = testGroup "JSON structure"
[ testCase "output is valid JSON" $ do
_ <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
_ <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
return ()
, testCase "top-level nftables array present" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
_ <- nftArr v
return ()
, testCase "metainfo is first element" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case arr of
(first:_) -> case at ["metainfo"] first of
@@ -85,17 +81,13 @@ jsonStructureTests = testGroup "JSON structure"
[] -> assertFailure "Empty nftables array"
, testCase "table object present" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected at least one table object"
(not (null (withKey "table" arr)))
, testCase "default table name is fwl" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "fwl")
@@ -104,9 +96,7 @@ jsonStructureTests = testGroup "JSON structure"
, testCase "custom table name respected" $ do
v <- compileToValue
"config { table = \"custom\"; } \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "custom")
@@ -118,60 +108,42 @@ jsonStructureTests = testGroup "JSON structure"
chainTests :: TestTree
chainTests = testGroup "chain declarations"
[ testCase "filter input chain has correct hook" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","hook"] c @?= Just (A.String "input")
[] -> assertFailure "No chain"
, testCase "filter chain type is filter" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy fwd : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "filter")
[] -> assertFailure "No chain"
, testCase "NAT chain type is nat" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "nat")
[] -> assertFailure "No chain"
, testCase "input chain default policy is drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "drop")
[] -> assertFailure "No chain"
, testCase "output chain default policy is accept" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "accept")
[] -> assertFailure "No chain"
, testCase "chain name matches policy name" $ do
v <- compileToValue
"policy my_input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy my_input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(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
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
"policy input : Frame hook Input = { | _ -> Drop; }; \
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "chain" arr) @?= 2
]
@@ -199,29 +167,14 @@ ruleExprs arr =
ruleExprTests :: TestTree
ruleExprTests = testGroup "rule expressions"
[ testCase "two arms produce two rules" $ do
[ testCase "arm without guard produces rule" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
"policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, 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
assertBool "Should have at least one rule" (not (null (withKey "rule" arr)))
, testCase "rule expr array is present" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "rule" arr of
(r:_) -> case at ["rule","expr"] r of
@@ -231,10 +184,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "IPv4 ctor emits nfproto match" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
"policy input : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
@@ -245,10 +197,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "record field pat emits payload match" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ | _ -> Drop; \
"policy input : Frame hook Input = \
\ { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
@@ -269,28 +220,19 @@ allExprs arr =
verdictTests :: TestTree
verdictTests = testGroup "verdicts"
[ testCase "Allow compiles to accept" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected accept verdict"
(not (null (withKey "accept" (allExprs arr))))
, testCase "Drop compiles to drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
assertBool "Expected drop verdict"
(not (null (withKey "drop" (allExprs arr))))
, testCase "Masquerade compiles to masquerade" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Masquerade; };"
v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Masquerade; };"
arr <- nftArr v
assertBool "Expected masquerade verdict"
(not (null (withKey "masquerade" (allExprs arr))))
@@ -298,9 +240,7 @@ verdictTests = testGroup "verdicts"
, testCase "rule call compiles to jump" $ do
v <- compileToValue
"rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \
\policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | frame -> blockAll(frame); };"
\policy fwd : Frame hook Forward = { | frame -> blockAll(frame); };"
arr <- nftArr v
assertBool "Expected jump verdict for rule call"
(not (null (withKey "jump" (allExprs arr))))
@@ -312,16 +252,14 @@ layerStrippingTests :: TestTree
layerStrippingTests = testGroup "layer stripping"
[ testCase "Frame with and without Ether both emit nfproto match" $ do
let withEther =
"policy p1 : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
"policy p1 : Frame hook Input = \
\ { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
\ };"
withoutEther =
"policy p1 : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
"policy p1 : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
v1 <- compileToValue withEther
v2 <- compileToValue withoutEther
@@ -338,22 +276,11 @@ layerStrippingTests = testGroup "layer stripping"
continueTests :: TestTree
continueTests = testGroup "Continue"
[ testCase "two terminal arms produce two rules" $ do
[ testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> 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; \
"policy input : Frame hook Input = \
\ { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
assertBool "Should have rules for non-Continue arms"
@@ -365,20 +292,166 @@ continueTests = testGroup "Continue"
configTests :: TestTree
configTests = testGroup "config"
[ testCase "all rule objects reference correct table" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl"))
(withKey "rule" arr)
, testCase "chain objects reference correct table" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl"))
(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
, exprTests
, policyTests
, portforwardTests
, masqueradeTests
, ruleTests
, configTests
, errorTests
@@ -351,31 +353,38 @@ exprTests = testGroup "expressions"
policyTests :: TestTree
policyTests = testGroup "policy"
[ testCase "minimal policy" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
[ testCase "compact hook Input syntax" $ do
p <- parseOk "policy input : Frame hook Input = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy "output" _ (PolicyMeta HOutput TFilter (Priority 0)) [_] -> return ()
DPolicy "input" _ (PolicyMeta HInput TFilter (Priority 0)) [_] -> return ()
_ -> assertFailure (show d)
, testCase "NAT prerouting" $ do
, testCase "hook Prerouting priority Mangle" $ do
p <- parseOk
"policy nat_pre : Frame \
\ on { hook = Prerouting, table = NAT, priority = DstNat } \
\ = { | _ -> Allow; };"
"policy pre : Frame hook Prerouting priority Mangle = { | _ -> Drop; };"
d <- singleDecl p
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)
, testCase "arm with guard" $ do
p <- parseOk
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
"policy input : Frame hook Input = { \
\ | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -386,9 +395,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern with path" $ do
p <- parseOk
"policy forward : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
"policy forward : Frame hook Forward = { \
\ | Frame(iif in lan_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -399,9 +406,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern without Ether (layer stripping)" $ do
p <- parseOk
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
"policy input : Frame hook Input = { \
\ | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -412,9 +417,7 @@ policyTests = testGroup "policy"
, testCase "policy arm calls rule" $ do
p <- parseOk
"policy forward : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
"policy forward : Frame hook Forward = { \
\ | frame -> blockOutboundWG(frame); \
\ };"
d <- singleDecl p
@@ -435,6 +438,36 @@ policyTests = testGroup "policy"
_ -> 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 ────────────────────────────────────────────────────────────────────
ruleTests :: TestTree
@@ -495,17 +528,18 @@ errorTests = testGroup "parse errors"
[ testCase "missing semicolon" $
parseFail "interface wan : WAN {}"
, testCase "unknown hook" $
, testCase "old on-brace policy syntax is a parse error" $
parseFail
"policy p : Frame \
\ on { hook = Bogus, table = Filter, priority = Filter } \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, testCase "unknown hook" $
parseFail
"policy p : Frame hook Bogus = { | _ -> Allow; };"
, testCase "empty arm block with no arms is ok" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
p <- parseOk "policy output : Frame hook Output = {};"
d <- singleDecl p
case d of
DPolicy _ _ _ [] -> return ()