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

Compare commits

base: CaZzzer:d01be7bc23ef192fd716f25c575a1e60670398f5
Branches Tags
CaZzzer:master CaZzzer:v2-1 CaZzzer:v2
...
compare: CaZzzer:v2
Branches Tags
CaZzzer:v2-1 CaZzzer:v2 CaZzzer:master

7 Commits
d01be7bc23 ... 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
Yuri Tatishchev
9390647f7a add more ruleset examples 2026-05-04 01:47:10 -07:00
Yuri Tatishchev
25f95996fb I don't even know rn 2026-05-04 01:44:11 -07:00
Yuri Tatishchev
d79206440a stupid compilation 2026-05-04 00:41:52 -07:00
Yuri Tatishchev
d136bd62f7 more compiler fixes 2026-05-04 00:14:47 -07:00
Yuri Tatishchev
8a508ad7cc gemini fixes nft json compilation 2026-05-03 19:01:02 -07:00
18 changed files with 2700 additions and 364 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

179
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,10 +246,11 @@ 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
| pat "|" pat -- Or-pattern
wildcardPat ::= "_"
framePat ::= "Frame" "(" frameArgs ")"
@@ -174,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 } ")"
@@ -187,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
@@ -221,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
@@ -270,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
@@ -282,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):
@@ -290,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
```
@@ -319,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 |
@@ -343,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
@@ -381,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.

1
doc/ref/ruleset-1.json Normal file
View File

File diff suppressed because one or more lines are too long

163
doc/ref/ruleset-1.nft Normal file
View File

@@ -0,0 +1,163 @@
#!/usr/sbin/nft -f
# Compiled from examples/router.fwl
# Single inet table: fwl
flush ruleset
table inet fwl {
# ── Data: let rfc1918 ────────────────────────────────────────────────────
set rfc1918 {
type ipv4_addr
flags interval
elements = {
10.0.0.0/8,
172.16.0.0/12,
192.168.0.0/16
}
}
# ── Data: let forwards ──────────────────────────────────────────────────
map forwards {
type inet_proto . inet_service : ipv4_addr . inet_service
elements = {
tcp . 8080 : 10.17.1.10 . 80,
tcp . 2222 : 10.17.1.11 . 22
}
}
# ── WireGuard ct mark state machine ─────────────────────────────────────
# Compiles: flow WireGuardHandshake = WGInitiation . WGResponse within 5s
# State: ct mark 0 = Idle, 1 = SawInitiation, 2 = Confirmed
#
# WGInitiation: UDP, udp length == 156 (8 hdr + 148 payload), payload[0] == 0x01
# WGResponse: UDP, udp length == 100 (8 hdr + 92 payload), payload[0] == 0x02
# @th,64,8 = first byte of UDP payload (offset 64 bits past transport header start)
chain wg_flow {
# Packet 1: Idle → SawInitiation
ct state new ct mark 0 \
meta l4proto udp udp length 156 \
@th,64,8 0x01 \
ct mark set 1 \
return
# Packet 2: SawInitiation → Confirmed
ct mark 1 \
meta l4proto udp udp length 100 \
@th,64,8 0x02 \
ct mark set 2 \
return
}
# ── rule blockOutboundWG ─────────────────────────────────────────────────
# Compiles: rule blockOutboundWG : Frame -> <FlowMatch, Log> Action
# Called via jump from forward. Drops confirmed WG handshakes, returns otherwise.
chain blockOutboundWG {
# Feed matching UDP into the WG state machine
meta nfproto ipv4 meta l4proto udp \
udp length 156 \
@th,64,8 0x01 \
jump wg_flow
# If handshake is now Confirmed (ct mark 2): log + drop
ct mark 2 \
log prefix "WG blocked: " level warn \
drop
# Continue: return to forward chain (no verdict)
return
}
# ── policy input ─────────────────────────────────────────────────────────
# hook = Input, table = Filter, priority = filter (0), default = drop
chain input {
type filter hook input priority filter; policy drop;
# | _ if ct.state in { Established, Related } -> Allow
ct state { established, related } accept
# | Frame(lo, _) -> Allow
iifname "lo" accept
# | Frame(_, IPv6(ip6, ICMPv6(_, _))) if ip6.src in fe80::/10 -> Allow
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
# | Frame(_, IPv4(_, TCP(tcp, _))) if tcp.dport == :22 -> Allow
meta nfproto ipv4 meta l4proto tcp tcp dport 22 accept
# | Frame(_, IPv4(_, UDP(udp, _))) if udp.dport == :51944 -> Allow
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
# | _ -> Drop (chain policy)
}
# ── policy forward ───────────────────────────────────────────────────────
# hook = Forward, table = Filter, priority = filter (0), default = drop
chain forward {
type filter hook forward priority filter; policy drop;
# | _ if ct.state in { Established, Related } -> Allow
ct state { established, related } accept
# | frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame)
meta iifname { "lan", "wg0" } meta oifname "wan" jump blockOutboundWG
# | _ if ct.status == DNAT -> Allow
ct status dnat accept
# | Frame(iif in lan_zone -> wan, _) -> Allow
meta iifname { "lan", "wg0" } meta oifname "wan" accept
# | Frame(iif in lan_zone -> lan_zone, _) -> Allow
meta iifname { "lan", "wg0" } meta oifname { "lan", "wg0" } accept
# | Frame(wan -> lan_zone, IPv4(ip, TCP|UDP)) if (proto, dport) in forwards -> Allow
# Membership test only — the actual DNAT is done in nat_prerouting.
meta iifname "wan" meta oifname { "lan", "wg0" } \
meta nfproto ipv4 \
meta l4proto { tcp, udp } \
meta l4proto . th dport @forwards \
accept
# | _ -> Drop (chain policy)
}
# ── policy output ────────────────────────────────────────────────────────
# hook = Output, table = Filter, priority = filter (0), default = accept
chain output {
type filter hook output priority filter; policy accept;
# | _ -> Allow (chain policy)
}
# ── policy nat_prerouting ────────────────────────────────────────────────
# hook = Prerouting, table = NAT, priority = dstnat (-100), default = accept
chain nat_prerouting {
type nat hook prerouting priority dstnat; policy accept;
# | Frame(_, IPv4(ip, TCP|UDP)) ->
# if FIB.daddrLocal(ip.dst) then DNATMap((proto, dport), forwards) else Allow
meta nfproto ipv4 meta l4proto { tcp, udp } \
fib daddr type local \
dnat ip to meta l4proto . th dport map @forwards
# | _ -> Allow (chain policy)
}
# ── policy nat_postrouting ───────────────────────────────────────────────
# hook = Postrouting, table = NAT, priority = srcnat (100), default = accept
chain nat_postrouting {
type nat hook postrouting priority srcnat; policy accept;
# | Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
# | _ -> Allow (chain policy)
}
}

10
examples/router.fwl
View File

@@ -7,7 +7,7 @@ interface wg0 : WireGuard {};
zone lan_zone = { lan, wg0 };
import rfc1918 : CIDRSet from "builtin:rfc1918";
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
let forwards : Map<(Protocol, Port), (IP, Port)> = {
(tcp, :8080) -> (10.17.1.10, :80),
@@ -64,8 +64,8 @@ policy forward : Frame
| _ if ct.status == DNAT -> Allow;
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| Frame(wan -> lan_zone, IPv4(ip, TCP(tcp, _)))
if (ip.dst, tcp.dport) in forwards -> Allow;
| Frame(wan -> lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _)))
if (ip.protocol, th.dport) in forwards -> Allow;
| _ -> Drop;
};
@@ -80,9 +80,9 @@ policy output : Frame
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, _)) ->
| Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap(forwards)
then DNATMap((ip.protocol, th.dport), forwards)
else Allow;
| _ -> Allow;
};

37
examples/simple-router.fwl Normal file
View File

@@ -0,0 +1,37 @@
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 };
let open_ports : Set<Port> = { :22 };
let forwards_v6 : Set<(Protocol, IPv6, Port)> = {
(tcp, 2001:db8::1, :22000)
};
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;
| Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
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;
};

734
examples/simple-router.fwl.json Normal file
View File

@@ -0,0 +1,734 @@
{
"nftables": [
{
"metainfo": {
"json_schema_version": 1
}
},
{
"table": {
"family": "inet",
"name": "fwl"
}
},
{
"chain": {
"family": "inet",
"hook": "input",
"name": "input",
"policy": "drop",
"prio": 0,
"table": "fwl",
"type": "filter"
}
},
{
"chain": {
"family": "inet",
"hook": "forward",
"name": "forward",
"policy": "drop",
"prio": 0,
"table": "fwl",
"type": "filter"
}
},
{
"chain": {
"family": "inet",
"hook": "prerouting",
"name": "wan_forwards_prerouting",
"policy": "accept",
"prio": -100,
"table": "fwl",
"type": "nat"
}
},
{
"chain": {
"family": "inet",
"hook": "postrouting",
"name": "wan_snat_postrouting",
"policy": "accept",
"prio": 100,
"table": "fwl",
"type": "nat"
}
},
{
"map": {
"elem": [
[
{
"concat": [
"tcp",
8080
]
},
{
"concat": [
"10.0.0.10",
80
]
}
]
],
"family": "inet",
"map": [
"ipv4_addr",
"inet_service"
],
"name": "wan_forwards",
"table": "fwl",
"type": [
"inet_proto",
"inet_service"
]
}
},
{
"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": [
22
],
"family": "inet",
"name": "open_ports",
"table": "fwl",
"type": "inet_service"
}
},
{
"set": {
"elem": [
{
"concat": [
"tcp",
"2001:db8:0:0:0:0:0:1",
22000
]
}
],
"family": "inet",
"name": "forwards_v6",
"table": "fwl",
"type": [
"inet_proto",
"ipv6_addr",
"inet_service"
]
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"ct": {
"key": "state"
}
},
"op": "==",
"right": {
"set": [
"established",
"related"
]
}
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "iifname"
}
},
"op": "==",
"right": "lo"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"payload": {
"field": "nexthdr",
"protocol": "ip6"
}
},
"op": "==",
"right": "ipv6-icmp"
}
},
{
"match": {
"left": {
"payload": {
"field": "saddr",
"protocol": "ip6"
}
},
"op": "==",
"right": {
"prefix": {
"addr": "fe80::",
"len": 10
}
}
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"match": {
"left": {
"payload": {
"field": "dport",
"protocol": "tcp"
}
},
"op": "==",
"right": "@open_ports"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "udp"
}
},
{
"match": {
"left": {
"payload": {
"field": "dport",
"protocol": "udp"
}
},
"op": "==",
"right": "51944"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"drop": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"ct": {
"key": "state"
}
},
"op": "==",
"right": {
"set": [
"established",
"related"
]
}
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"ct": {
"key": "status"
}
},
"op": "in",
"right": "dnat"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "iifname"
}
},
"op": "in",
"right": {
"set": [
"lan"
]
}
}
},
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"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": "ipv6"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"match": {
"left": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"field": "daddr",
"protocol": "ip6"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards_v6"
}
},
{
"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": "ipv6"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "udp"
}
},
{
"match": {
"left": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"field": "daddr",
"protocol": "ip6"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards_v6"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"drop": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "wan_forwards_prerouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "in",
"right": {
"set": [
"tcp",
"udp"
]
}
}
},
{
"match": {
"left": {
"fib": {
"flags": [
"daddr"
],
"result": "type"
}
},
"op": "==",
"right": "local"
}
},
{
"dnat": {
"addr": {
"map": {
"data": "@wan_forwards",
"key": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
}
}
},
"family": "ip"
}
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "wan_snat_postrouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"match": {
"left": {
"payload": {
"field": "saddr",
"protocol": "ip"
}
},
"op": "==",
"right": "@rfc1918"
}
},
{
"masquerade": null
}
],
"family": "inet",
"table": "fwl"
}
}
]
}

98
examples/simple-router.nft Normal file
View File

@@ -0,0 +1,98 @@
table inet fwl {
# ── let rfc1918 ──────────────────────────────────────────────────────────
set rfc1918 {
type ipv4_addr
flags interval
elements = {
10.0.0.0/8,
172.16.0.0/12,
192.168.0.0/16
}
}
# ── let open_ports : Set<Port> ───────────────────────────────────────────
set open_ports {
type inet_service
elements = { 22 }
}
# ── let forwards_v6 : Set<(Protocol, IP, Port)> ──────────────────────────
set forwards_v6 {
type inet_proto . ipv6_addr . inet_service
elements = {
tcp . 2001:db8::1 . 22000
}
}
# ── let forwards : Map<(Protocol, Port), (IP, Port)> ────────────────────
map forwards {
type inet_proto . inet_service : ipv4_addr . inet_service
elements = {
tcp . 8080 : 10.0.0.10 . 80
}
}
# ── zone lan_zone = { lan } ──────────────────────────────────────────────
# Zones compile to anonymous sets wherever referenced in iifname/oifname.
# With a single member the set degenerates to a plain string match,
# but we keep the set form so the compiler output is uniform regardless
# of zone size.
set lan_zone {
type ifname
elements = { "lan" }
}
# ── policy input ─────────────────────────────────────────────────────────
chain input {
type filter hook input priority filter; policy drop;
ct state { established, related } accept
iifname "lo" accept
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
meta nfproto ipv4 meta l4proto tcp tcp dport @open_ports accept
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
}
# ── policy forward ───────────────────────────────────────────────────────
chain forward {
type filter hook forward priority filter; policy drop;
ct state { established, related } accept
ct status dnat accept
# | Frame(iif in lan_zone -> wan, _) -> Allow
meta iifname @lan_zone meta oifname "wan" accept
# | Frame(wan -> iif in lan_zone, IPv4 TCP|UDP) if (proto,dport) in forwards
meta iifname "wan" meta oifname @lan_zone \
meta nfproto ipv4 meta l4proto { tcp, udp } \
meta l4proto . th dport @forwards accept
# | Frame(wan -> iif in lan_zone, IPv6 TCP|UDP) if (proto,dst,dport) in forwards_v6
meta iifname "wan" meta oifname @lan_zone \
meta nfproto ipv6 meta l4proto { tcp, udp } \
meta l4proto . ip6 daddr . th dport @forwards_v6 accept
}
# ── policy output ────────────────────────────────────────────────────────
chain output {
type filter hook output priority filter; policy accept;
}
# ── policy nat_prerouting ────────────────────────────────────────────────
chain nat_prerouting {
type nat hook prerouting priority dstnat; policy accept;
meta nfproto ipv4 meta l4proto { tcp, udp } \
fib daddr type local \
dnat ip to meta l4proto . th dport map @forwards
}
# ── policy nat_postrouting ───────────────────────────────────────────────
chain nat_postrouting {
type nat hook postrouting priority srcnat; policy accept;
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
}
}

693
examples/simple-router.nft.json Normal file
View File

@@ -0,0 +1,693 @@
{
"nftables": [
{
"metainfo": {
"version": "1.1.6",
"release_name": "Commodore Bullmoose #7",
"json_schema_version": 1
}
},
{
"table": {
"family": "inet",
"name": "fwl"
}
},
{
"chain": {
"family": "inet",
"table": "fwl",
"name": "input",
"type": "filter",
"hook": "input",
"prio": 0,
"policy": "drop"
}
},
{
"chain": {
"family": "inet",
"table": "fwl",
"name": "forward",
"type": "filter",
"hook": "forward",
"prio": 0,
"policy": "drop"
}
},
{
"chain": {
"family": "inet",
"table": "fwl",
"name": "output",
"type": "filter",
"hook": "output",
"prio": 0,
"policy": "accept"
}
},
{
"chain": {
"family": "inet",
"table": "fwl",
"name": "nat_prerouting",
"type": "nat",
"hook": "prerouting",
"prio": -100,
"policy": "accept"
}
},
{
"chain": {
"family": "inet",
"table": "fwl",
"name": "nat_postrouting",
"type": "nat",
"hook": "postrouting",
"prio": 100,
"policy": "accept"
}
},
{
"set": {
"family": "inet",
"name": "rfc1918",
"table": "fwl",
"type": "ipv4_addr",
"flags": [
"interval"
],
"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
}
}
]
}
},
{
"set": {
"family": "inet",
"name": "open_ports",
"table": "fwl",
"type": "inet_service",
"elem": [
22
]
}
},
{
"set": {
"family": "inet",
"name": "forwards_v6",
"table": "fwl",
"type": [
"inet_proto",
"ipv6_addr",
"inet_service"
],
"elem": [
{
"concat": [
"tcp",
"2001:db8::1",
22000
]
}
]
}
},
{
"map": {
"family": "inet",
"name": "forwards",
"table": "fwl",
"type": [
"inet_proto",
"inet_service"
],
"map": [
"ipv4_addr",
"inet_service"
],
"elem": [
[
{
"concat": [
"tcp",
8080
]
},
{
"concat": [
"10.0.0.10",
80
]
}
]
]
}
},
{
"set": {
"family": "inet",
"name": "lan_zone",
"table": "fwl",
"type": "ifname",
"elem": [
"lan"
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "input",
"expr": [
{
"match": {
"op": "==",
"left": {
"ct": {
"key": "state"
}
},
"right": {
"set": [
"established",
"related"
]
}
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "input",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "iifname"
}
},
"right": "lo"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "input",
"expr": [
{
"match": {
"op": "==",
"left": {
"payload": {
"protocol": "ip6",
"field": "nexthdr"
}
},
"right": "ipv6-icmp"
}
},
{
"match": {
"op": "==",
"left": {
"payload": {
"protocol": "ip6",
"field": "saddr"
}
},
"right": {
"prefix": {
"addr": "fe80::",
"len": 10
}
}
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "input",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "nfproto"
}
},
"right": "ipv4"
}
},
{
"match": {
"op": "==",
"left": {
"payload": {
"protocol": "tcp",
"field": "dport"
}
},
"right": "@open_ports"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "input",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "nfproto"
}
},
"right": "ipv4"
}
},
{
"match": {
"op": "==",
"left": {
"payload": {
"protocol": "udp",
"field": "dport"
}
},
"right": 51944
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "forward",
"expr": [
{
"match": {
"op": "==",
"left": {
"ct": {
"key": "state"
}
},
"right": {
"set": [
"established",
"related"
]
}
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "forward",
"expr": [
{
"match": {
"op": "in",
"left": {
"ct": {
"key": "status"
}
},
"right": "dnat"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "forward",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "iifname"
}
},
"right": "@lan_zone"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "oifname"
}
},
"right": "wan"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "forward",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "iifname"
}
},
"right": "wan"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "oifname"
}
},
"right": "@lan_zone"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "nfproto"
}
},
"right": "ipv4"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "l4proto"
}
},
"right": {
"set": [
"tcp",
"udp"
]
}
}
},
{
"match": {
"op": "==",
"left": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"protocol": "th",
"field": "dport"
}
}
]
},
"right": "@forwards"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "forward",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "iifname"
}
},
"right": "wan"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "oifname"
}
},
"right": "@lan_zone"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "l4proto"
}
},
"right": {
"set": [
"tcp",
"udp"
]
}
}
},
{
"match": {
"op": "==",
"left": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"protocol": "ip6",
"field": "daddr"
}
},
{
"payload": {
"protocol": "th",
"field": "dport"
}
}
]
},
"right": "@forwards_v6"
}
},
{
"accept": null
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "nat_prerouting",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "nfproto"
}
},
"right": "ipv4"
}
},
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "l4proto"
}
},
"right": {
"set": [
"tcp",
"udp"
]
}
}
},
{
"match": {
"op": "==",
"left": {
"fib": {
"result": "type",
"flags": [
"daddr"
]
}
},
"right": "local"
}
},
{
"dnat": {
"family": "ip",
"addr": {
"map": {
"key": {
"concat": [
{
"meta": {
"key": "l4proto"
}
},
{
"payload": {
"protocol": "th",
"field": "dport"
}
}
]
},
"data": "@forwards"
}
}
}
}
]
}
},
{
"rule": {
"family": "inet",
"table": "fwl",
"chain": "nat_postrouting",
"expr": [
{
"match": {
"op": "==",
"left": {
"meta": {
"key": "oifname"
}
},
"right": "wan"
}
},
{
"match": {
"op": "==",
"left": {
"payload": {
"protocol": "ip",
"field": "saddr"
}
},
"right": "@rfc1918"
}
},
{
"masquerade": null
}
]
}
}
]
}

21
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
@@ -82,6 +86,7 @@ data Pat
| PTuple [Pat]
| PFrame (Maybe PathPat) Pat
| PBytes [ByteElem]
| POr Pat Pat
deriving (Show)
data FieldPat

34
src/FWL/Check.hs
View File

@@ -20,6 +20,7 @@ data CheckError
| PolicyNoContinue String -- policy name
| PatternCycle [String] -- cycle path
| DuplicateDecl String String -- kind, name
| OrPatternMismatch [String] [String]
deriving (Show, Eq)
type Env = Map.Map String DeclKind
@@ -49,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
@@ -69,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"
@@ -79,6 +84,8 @@ declKindStr (DPattern _ _ _) = "pattern"
declKindStr (DFlow _ _) = "flow"
declKindStr (DRule _ _ _) = "rule"
declKindStr (DPolicy _ _ _ _) = "policy"
declKindStr (DPortForward _ _ _ _) = "portforward"
declKindStr (DMasquerade _ _ _) = "masquerade"
-- ─── Name resolution ─────────────────────────────────────────────────────────
@@ -89,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]
@@ -117,6 +130,25 @@ checkPat env (PRecord _ fs) = concatMap (checkFP env) fs
checkPat env (PTuple ps) = concatMap (checkPat env) ps
checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner
checkPat _ (PBytes _) = []
checkPat env (POr p1 p2) =
let v1 = boundVars p1
v2 = boundVars p2
errs = if Set.fromList v1 == Set.fromList v2 then [] else [OrPatternMismatch v1 v2]
in errs ++ checkPat env p1 ++ checkPat env p2
boundVars :: Pat -> [String]
boundVars (PVar n) = [n]
boundVars (PCtor _ ps) = concatMap boundVars ps
boundVars (PRecord _ fs) = concatMap boundFP fs
boundVars (PTuple ps) = concatMap boundVars ps
boundVars (PFrame _ p) = boundVars p
boundVars (POr p1 p2) = boundVars p1
boundVars _ = []
boundFP :: FieldPat -> [String]
boundFP (FPBind n) = [n]
boundFP (FPAs _ v) = [v]
boundFP _ = []
checkFP :: Env -> FieldPat -> [CheckError]
checkFP _ _ = [] -- field names checked by type-checker later
@@ -153,6 +185,7 @@ addPat env (PFrame mp inner) =
in case md of Just (EPName n) -> Map.insert n KLet env1; _ -> env1
Nothing -> env
in addPat env' inner
addPat env (POr p1 _) = addPat env p1
addPat env _ = env
addFP :: Env -> FieldPat -> Env
@@ -211,6 +244,7 @@ checkPatternCycles decls =
refsInPat (PCtor _ ps) = concatMap refsInPat ps
refsInPat (PTuple ps) = concatMap refsInPat ps
refsInPat (PFrame _ p) = refsInPat p
refsInPat (POr p1 p2) = refsInPat p1 ++ refsInPat p2
refsInPat _ = []
findCycles :: Map.Map String [String] -> [[String]]

423
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, _, e) -> letToMapValue tbl n e) letDecls
-- ─── Table / Chain declarations ──────────────────────────────────────────────
@@ -98,18 +248,17 @@ armToRuleValues env tbl chain (Arm p mg body) =
case compileAction env body of
Nothing -> []
Just verdict ->
let patExprs = compilePat env p
guardExprs = maybe [] (compileGuard env) mg
allExprs = patExprs ++ guardExprs ++ [verdict]
let patExprsAlts = compilePat env p
guardExprs = maybe [] (compileGuard env) mg
in [ object
[ "rule" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "chain" .= chain
, "expr" .= toJSON allExprs
, "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict])
]
]
]
| patExprs <- patExprsAlts ]
-- ─── Pattern → [Value] ───────────────────────────────────────────────────────
@@ -118,84 +267,92 @@ 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 = []
compilePat _ (PVar _) = []
compilePat :: CompileEnv -> Pat -> [[Value]]
compilePat _ PWild = [[]]
compilePat _ (PVar _) = [[]]
compilePat env (PNamed n) = expandNamedPat env n
compilePat env (PFrame mp inner) =
maybe [] (compilePathPat env) mp ++ compilePat env inner
compilePat env (PFrame mp inner) = do
pathConds <- maybe [[]] (compilePathPat env) mp
innerConds <- compilePat env inner
return (pathConds ++ innerConds)
compilePat env (PCtor n ps) = compileCtorPat env n ps
compilePat _ (PRecord n fs) = compileRecordPat n fs
compilePat env (PTuple ps) = concatMap (compilePat env) ps
compilePat _ (PBytes _) = []
compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps))
compilePat _ (PBytes _) = [[]]
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
expandNamedPat :: CompileEnv -> Name -> [Value]
expandNamedPat :: CompileEnv -> Name -> [[Value]]
expandNamedPat env n =
case Map.lookup n env of
Just (DPattern _ _ p) -> compilePat env p
_ -> []
compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]]
compileCtorPat env ctor ps = case ctor of
"Ether" -> children
"IPv4" -> matchMeta "nfproto" "ipv4" : children
"IPv6" -> matchMeta "nfproto" "ipv6" : children
"TCP" -> matchPayload "th" "protocol" "tcp" : children
"UDP" -> matchPayload "th" "protocol" "udp" : children
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children
"IPv4" -> map (matchMeta "nfproto" "ipv4" :) children
"IPv6" -> map (matchMeta "nfproto" "ipv6" :) children
"TCP" -> map (matchMeta "l4proto" "tcp" :) children
"UDP" -> map (matchMeta "l4proto" "udp" :) children
"ICMPv6" -> map (matchPayload "ip6" "nexthdr" "ipv6-icmp" :) children
"ICMP" -> map (matchPayload "ip" "protocol" "icmp" :) children
_ -> children
where
children = concatMap (compilePat env) ps
children = map concat (sequence (map (compilePat env) ps))
compileRecordPat :: String -> [FieldPat] -> [Value]
compileRecordPat proto = mapMaybe go
compileRecordPat :: String -> [FieldPat] -> [[Value]]
compileRecordPat proto fs = [mapMaybe go fs]
where
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
go _ = Nothing
compilePathPat :: CompileEnv -> PathPat -> [Value]
compilePathPat _ (PathPat ms md) =
maybe [] (compileEndpoint "iifname") ms ++
maybe [] (compileEndpoint "oifname") md
compilePathPat :: CompileEnv -> PathPat -> [[Value]]
compilePathPat env (PathPat ms md) =
[ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint env "oifname") md ]
compileEndpoint :: String -> EndpointPat -> [Value]
compileEndpoint _ EPWild = []
compileEndpoint dir (EPName n) = [matchMeta dir n]
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]]
compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value]
compileEndpoint _ _ EPWild = []
compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint env dir (EPMember _ z) =
case Map.lookup z env of
Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
_ -> [matchInSet (metaVal dir) [A.String (toText z)]]
-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: CompileEnv -> Expr -> [Value]
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
compileGuard _ (EInfix OpIn l r) = [compileInExpr l r]
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)]
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal r)]
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
compileGuard _ _ = []
compileInExpr :: Expr -> Expr -> Value
compileInExpr :: CompileEnv -> Expr -> Expr -> Value
-- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element
-- EQual case to eliminate the overlapping pattern match warning.
compileInExpr (EQual ["ct", "state"]) (ESet vs) = ctMatch "state" vs
compileInExpr (EQual ["ct", "status"]) (ESet vs) = ctMatch "status" vs
compileInExpr l (ESet vs) =
matchExpr "in" (exprVal l) (setVal (map exprToStr vs))
compileInExpr l r =
matchExpr "==" (exprVal l) (exprVal r)
ctMatch :: String -> [Expr] -> Value
ctMatch key vs = matchExpr "in"
(object ["ct" .= object ["key" .= (key :: String)]])
(setVal (map exprToStr vs))
compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr env l (ESet vs) =
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
compileInExpr env l (EVar z)
| Just (DZone _ ns) <- Map.lookup z env =
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r)
-- ─── Action → Maybe Value ─────────────────────────────────────────────────────
@@ -206,37 +363,89 @@ compileAction _ (EVar "Continue") = Nothing
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null])
compileAction _ (EApp (EVar "DNAT") arg) =
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]]
compileAction _ (EApp (EVar "DNATMap") arg) =
compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
Just $ object ["dnat" .= object ["addr" .= object
[ "map" .= object [ "key" .= object ["concat" .= Array mempty]
, "data" .= exprToStr arg ]]]]
[ "map" .= object [ "key" .= exprVal env key
, "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]
compileAction env (EApp (EVar rn) _) =
case Map.lookup rn env of
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
_ -> Just (object ["accept" .= Null])
compileAction _ _ = Just (object ["accept" .= Null])
-- ─── Let → Map object ────────────────────────────────────────────────────────
letToMapValue :: String -> Name -> Expr -> Maybe Value
letToMapValue tbl n (EMap entries) = Just $ object
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
[ "map" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= ("inetproto . inetservice" :: String)
, "map" .= ("ipv4_addr . inetservice" :: String)
, "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= renderNftType (fwlTypeToNft tv)
, "elem" .= toJSON (map renderMapElem entries)
]
]
letToMapValue _ _ _ = Nothing
letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object
[ "set" .= object
( [ "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
fwlTypeToNft :: Type -> [String]
fwlTypeToNft (TName "Protocol" []) = ["inet_proto"]
fwlTypeToNft (TName "Port" []) = ["inet_service"]
fwlTypeToNft (TName "IP" []) = ["ipv4_addr"]
fwlTypeToNft (TName "IPv4" []) = ["ipv4_addr"]
fwlTypeToNft (TName "IPv6" []) = ["ipv6_addr"]
fwlTypeToNft (TTuple ts) = concatMap fwlTypeToNft ts
fwlTypeToNft _ = ["any"]
renderNftType :: [String] -> Value
renderNftType [t] = A.String (toText t)
renderNftType ts = toJSON ts
exprToVal :: Expr -> Value
exprToVal (ELit (LPort p)) = toJSON p
exprToVal (ELit (LInt n)) = toJSON n
exprToVal (ELit (LCIDR ip p))= object
[ "prefix" .= object
[ "addr" .= A.String (toText (renderLit ip))
, "len" .= p
]
]
exprToVal (ELit l) = A.String (toText (renderLit l))
exprToVal (EVar n) = A.String (toText n)
exprToVal (EQual ns) = A.String (toText (intercalate "." ns))
exprToVal _ = A.String "_"
exprToConcatList :: Expr -> [Value]
exprToConcatList (ETuple es) = concatMap exprToConcatList es
exprToConcatList e = [exprToVal e]
renderMapOrSetKey :: Expr -> Value
renderMapOrSetKey (ETuple es) = object ["concat" .= toJSON (exprToConcatList (ETuple es))]
renderMapOrSetKey e = exprToVal e
renderMapElem :: (Expr, Expr) -> Value
renderMapElem (k, v) = toJSON
[ object ["concat" .= toJSON [exprToStr k]]
, A.String (toText (exprToStr v))
[ renderMapOrSetKey k
, renderMapOrSetKey v
]
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
@@ -255,7 +464,7 @@ matchPayload :: String -> String -> String -> Value
matchPayload proto field val =
matchExpr "==" (payloadVal proto field) (A.String (toText val))
matchInSet :: Value -> [String] -> Value
matchInSet :: Value -> [Value] -> Value
matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
metaVal :: String -> Value
@@ -268,23 +477,57 @@ payloadVal proto field =
, "field" .= (field :: String)
]]
setVal :: [String] -> Value
setVal :: [Value] -> Value
setVal vs = object ["set" .= toJSON vs]
-- ─── Expression helpers ───────────────────────────────────────────────────────
isSetOrMapRef :: CompileEnv -> Name -> Bool
isSetOrMapRef env n = case Map.lookup n env of
Just (DLet _ _ _) -> True
Just (DImport _ _ _) -> True
_ -> False
mapField :: String -> String
mapField "src" = "saddr"
mapField "dst" = "daddr"
mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
exprVal :: Expr -> Value
exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
exprVal (EQual [p, f]) = payloadVal p f
exprVal (EQual ns) = A.String (toText (intercalate "." ns))
exprVal (EVar n) = metaVal n
exprVal (ELit l) = A.String (toText (renderLit l))
exprVal (ESet vs) = setVal (map exprToStr vs)
exprVal e = A.String (toText (exprToStr e))
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 ["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)
| n == "iif" = metaVal "iifname"
| n == "oif" = metaVal "oifname"
| n == "DNAT" = A.String "dnat"
| n == "Established" = A.String "established"
| n == "Related" = A.String "related"
| otherwise = metaVal n
exprVal _ (ELit (LCIDR ip p)) = object
[ "prefix" .= object
[ "addr" .= A.String (toText (renderLit ip))
, "len" .= p
]
]
exprVal _ (ELit l) = A.String (toText (renderLit l))
exprVal env (ESet vs) = setVal (map (exprVal env) vs)
exprVal env (ETuple es) = object ["concat" .= toJSON (map (exprVal env) es)]
exprVal _ e = A.String (toText (exprToStr e))
exprToStr :: Expr -> String
exprToStr (EVar n) = n
exprToStr (EVar n) = case n of
"Established" -> "established"
"Related" -> "related"
"DNAT" -> "dnat"
_ -> n
exprToStr (ELit l) = renderLit l
exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)

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"

78
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
@@ -225,7 +254,12 @@ arm = do
-- ─── Patterns ────────────────────────────────────────────────────────────────
pat :: Parser Pat
pat = wildcardPat
pat = Ex.buildExpressionParser patTable patAtom <?> "pattern"
where
patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ]
patAtom :: Parser Pat
patAtom = wildcardPat
<|> try framePat
<|> try tuplePat
<|> bytesPat

42
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
@@ -82,6 +105,7 @@ prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
prettyPat (PFrame mp inner)=
"Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")"
prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]"
prettyPat (POr p1 p2) = prettyPat p1 ++ " | " ++ prettyPat p2
prettyFP :: FieldPat -> String
prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l

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 ()