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

Compare commits

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

2 Commits
v2-1 ... master

Author SHA1 Message Date
Yuri Tatishchev
134cb06900 add agents rule file for docs 2026-05-03 02:02:17 -07:00
Yuri Tatishchev
0a84011f07 v1 perplexed 2026-05-03 01:44:14 -07:00
22 changed files with 866 additions and 4773 deletions
Expand all files Collapse all files

225
AGENTS.md
View File

@@ -1,225 +0,0 @@
# AGENTS.md
FWL (Firewall Language) is a Haskell DSL that compiles to nftables JSON.
Stack: GHC 9.10.3, Cabal, Parsec 3.x, Aeson 2.x, Tasty/HUnit for tests.
---
## Key Commands
```bash
cabal build # build everything
cabal test # run all test suites
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`.
---
## Project Structure
```
fwl/
├── AGENTS.md
├── doc/
│ ├── 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
├── examples/
│ ├── 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
└── test/
├── Main.hs
├── ParserTests.hs
├── TypeCheckTests.hs
└── CompileTests.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.
---
## Architecture
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)
```
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
**Only syntactic keywords belong in `reservedNames` in `Lexer.hs`.**
A word is a syntactic keyword if and only if `Parser.hs` uses `reserved "word"` for it.
Semantic values — action constructors (`Allow`, `Drop`, `Masquerade`),
effect labels (`Log`, `Warn`, `Error`), result constructors (`Matched`, `Unmatched`),
and type names (`Frame`, `FlowPattern`, `Action`) — must NOT be in `reservedNames`.
They are parsed as plain identifiers so they can appear in type, pattern,
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
IP addresses are stored as plain `Integer` in the AST (see `AST.hs`):
- **IPv4**: 32-bit value in the low 32 bits of `Integer`.
- **IPv6**: 128-bit value. All standard notations are supported including `::` compression
and embedded IPv4 (e.g. `::ffff:192.168.1.1`).
- **CIDR**: `(Literal, Int)` — base address literal + prefix length.
- **Validation**: host bits must be zero: `(addr .&. hostMask prefix bits) == 0`.
Use `ipv4Lit a b c d` from `AST.hs` to construct IPv4 literals in tests.
Never use tuple `(Word8, Word8, Word8, Word8)` — that type is gone.
---
## Priority
`Priority` is `newtype Priority = Priority { priorityValue :: Int }`.
Named constants are resolved at parse time in `priorityP`:
| Name | Value |
|-------------|-------|
| `Raw` | -300 |
| `ConnTrack` | -200 |
| `Mangle` | -150 |
| `DstNat` | -100 |
| `Filter` | 0 |
| `SrcNat` | 100 |
The compiler emits `"prio": <int>` — always an integer in the nftables JSON,
never a string. Do not use the old `priorityStr` function (deleted).
---
## Parser Conventions
- All blocks use explicit `{ }` delimiters with trailing `;` on each item.
`endBy p semi` (not `semiSep`) is used wherever trailing semicolons are expected.
- `mapLit` must be tried **before** `setLit` in `atom` — both start with `{`
and `mapLit` consumes `{ expr -> expr }` which `setLit` would misparse.
- `framePat` must be wrapped in `try` in the `pat` alternatives — it is a
reserved-word-prefixed parser that can fail after consuming input.
- Port literals (`:22`, `:8080`) in record field patterns use `fieldLiteral`,
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.
---
## Testing Conventions
- Test files use `{-# LANGUAGE OverloadedStrings #-}` — required because
`A.String` expects `Data.Text.Text`, not `String`.
- IP address assertions use `LIP IPv4 n` / `LIP IPv6 n`, not the old
`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).
---
## Boundaries
### ✅ Safe to do without asking
- Read any file, list directories
- Run `cabal build`, `cabal test`, `cabal run fwlc`
- 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/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

13
app/Main.hs
View File

@@ -3,12 +3,11 @@ module Main where
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStrLn, stderr)
import qualified Data.ByteString.Lazy.Char8 as BL
import FWL.Parser (parseFile)
import FWL.Pretty (prettyProgram)
import FWL.Check (checkProgram)
import FWL.Compile (compileToJson)
import FWL.Compile (compileToJson, compileProgram)
main :: IO ()
main = do
@@ -33,7 +32,9 @@ runCheck fp = do
let errs = checkProgram prog
if null errs
then putStrLn "OK" >> exitSuccess
else mapM_ (hPutStrLn stderr . show) errs >> exitFailure
else do
mapM_ (hPutStrLn stderr . show) errs
exitFailure
runCompile :: FilePath -> IO ()
runCompile fp = do
@@ -43,8 +44,10 @@ runCompile fp = do
Right prog -> do
let errs = checkProgram prog
if null errs
then BL.putStrLn (compileToJson prog)
else mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs >> exitFailure
then putStrLn (compileToJson prog)
else do
mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs
exitFailure
runPretty :: FilePath -> IO ()
runPretty fp = do

880
doc/fwl_grammar.md
View File

File diff suppressed because it is too large Load Diff

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

File diff suppressed because one or more lines are too long

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

@@ -1,163 +0,0 @@
#!/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)
}
}

68
examples/router.fwl
View File

@@ -1,68 +0,0 @@
-- Example: home router firewall in FWL
-- Compile with: fwlc compile examples/router.fwl
interface wan : WAN { dynamic; };
interface lan : LAN { cidr4 = { 10.17.1.0/24 }; };
interface wg0 : WireGuard {};
zone lan_zone = { lan, wg0 };
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
let open_ports : Set<Port> = { :22 };
-- WireGuard handshake detection (compiles to ct mark state machine)
pattern WGInitiation : (UDPHeader, Bytes) =
(udp { length = 156 }, [0x01 _*]);
pattern WGResponse : (UDPHeader, Bytes) =
(udp { length = 100 }, [0x02 _*]);
flow WireGuardHandshake : FlowPattern =
WGInitiation . WGResponse within 5s;
-- Block LAN clients from tunnelling out via WireGuard
rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
\frame ->
case frame of {
| Frame(iif in lan_zone -> wan, IPv4(ip, UDP(udp, payload)))
if matches(WGInitiation, (udp, payload)) ->
case perform FlowMatch.check(flowOf(ip, wg), WireGuardHandshake) of {
| Matched -> do {
perform Log.emit(Warn, "WG blocked");
Drop
};
| _ -> Continue;
};
| _ -> Continue;
};
-- Port-forward map: incoming proto+port -> internal addr+port
portforward wan_forwards
on wan
via Map<(Protocol, Port), (IPv4, Port)> = {
(tcp, :8080) -> (10.17.1.10, :80),
(tcp, :2222) -> (10.17.1.11, :22)
};
-- Masquerade outbound traffic from RFC1918 sources
masquerade wan_snat
on wan
src rfc1918;
-- Inbound to router
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;
};
-- Forwarded traffic
policy forward : Frame hook Forward = {
| frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame);
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| _ -> Drop;
};

37
examples/simple-router.fwl
View File

@@ -1,37 +0,0 @@
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
View File

@@ -1,734 +0,0 @@
{
"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
View File

@@ -1,98 +0,0 @@
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
View File

@@ -1,693 +0,0 @@
{
"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
}
]
}
}
]
}

20
fwl.cabal
View File

@@ -36,23 +36,3 @@ executable fwlc
hs-source-dirs: app
build-depends:
base, fwl, text, aeson-pretty, bytestring
test-suite fwl-tests
import: shared
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
other-modules:
FWL.Util
, ParserTests
, CheckTests
, CompileTests
build-depends:
base, fwl
, tasty >= 1.4
, tasty-hunit >= 0.10
, aeson >= 2.0
, aeson-pretty >= 0.8
, bytestring >= 0.11
, parsec >= 3.1
, vector >= 0.12

126
src/FWL/AST.hs
View File

@@ -1,7 +1,6 @@
module FWL.AST where
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.Word (Word8) -- Word8 still used for ByteElem/hex literals
import Data.Word (Word8, Word16)
type Name = String
@@ -28,12 +27,8 @@ data Decl
| DLet Name Type Expr
| DPattern Name Type Pat
| DFlow Name FlowExpr
| DRule Name Type Expr
| DRule Name Type Expr -- body must be ELam
| 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
@@ -46,22 +41,9 @@ data Hook = HInput | HForward | HOutput | HPrerouting | HPostrouting
deriving (Show, Eq)
data TableName = TFilter | TNAT
deriving (Show, Eq)
-- Priority is always an integer in the nftables JSON.
-- Named constants are resolved to their numeric values at parse time.
newtype Priority = Priority { priorityValue :: Int }
data Priority = PFilter | PDstNat | PSrcNat | PMangle | PInt Int
deriving (Show, Eq)
-- Standard nftables priority constants
pRaw, pConnTrackDefrag, pConnTrack, pMangle, pDstNat, pFilter, pSecurity, pSrcNat :: Priority
pRaw = Priority (-300)
pConnTrackDefrag = Priority (-400)
pConnTrack = Priority (-200)
pMangle = Priority (-150)
pDstNat = Priority (-100)
pFilter = Priority 0
pSecurity = Priority 50
pSrcNat = Priority 100
data IfaceKind = IWan | ILan | IWireGuard | IUser Name
deriving (Show)
@@ -71,28 +53,23 @@ data IfaceProp
| IPCidr6 [CIDR]
deriving (Show)
-- | A CIDR block: base address literal paired with prefix length.
-- e.g. (LIPv4 (10,0,0,0), 8) represents 10.0.0.0/8
type CIDR = (Literal, Int)
-- ─── Patterns ───────────────────────────────────────────────────────────────
data Pat
= PWild
| PVar Name
| PNamed Name
| PCtor Name [Pat]
| PRecord Name [FieldPat]
| PNamed Name -- first-class named pattern ref
| PCtor Name [Pat] -- IPv4(ip, ...), TCP(tcp, ...)
| PRecord Name [FieldPat] -- udp { length = 156 }
| PTuple [Pat]
| PFrame (Maybe PathPat) Pat
| PFrame (Maybe PathPat) Pat -- Frame(path?, inner)
| PBytes [ByteElem]
| POr Pat Pat
deriving (Show)
data FieldPat
= FPEq Name Literal
| FPBind Name
| FPAs Name Name
= FPEq Name Literal -- field = literal
| FPBind Name -- bind field to same-named var
| FPAs Name Name -- field as var
deriving (Show)
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
@@ -101,13 +78,13 @@ data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
data EndpointPat
= EPWild
| EPName Name
| EPMember Name Name
| EPMember Name Name -- iif `in` zone
deriving (Show)
data ByteElem
= BEHex Word8
| BEWild
| BEWildStar
| BEWild -- _ (one byte)
| BEWildStar -- _* (zero or more)
deriving (Show)
-- ─── Flow ───────────────────────────────────────────────────────────────────
@@ -118,11 +95,8 @@ data FlowExpr
deriving (Show)
type Duration = (Int, TimeUnit)
-- Fix 1: TimeUnit must derive Eq because Literal (which embeds it via
-- LDuration) derives Eq, requiring all constituent types to also have Eq.
data TimeUnit = Seconds | Millis | Minutes | Hours
deriving (Show, Eq)
deriving (Show)
-- ─── Types ──────────────────────────────────────────────────────────────────
@@ -137,7 +111,7 @@ data Type
data Expr
= EVar Name
| EQual [Name]
| EQual [Name] -- qualified name, e.g. Log.emit
| ELit Literal
| ELam Name Expr
| EApp Expr Expr
@@ -148,7 +122,7 @@ data Expr
| ETuple [Expr]
| ESet [Expr]
| EMap [(Expr, Expr)]
| EPerform [Name] [Expr]
| EPerform [Name] [Expr] -- perform QualName(args)
| EInfix InfixOp Expr Expr
| ENot Expr
deriving (Show)
@@ -156,10 +130,10 @@ data Expr
data InfixOp
= OpAnd | OpOr
| OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
| OpIn
| OpConcat
| OpThen
| OpBind
| OpIn -- `in` / `∈`
| OpConcat -- ++
| OpThen -- >>
| OpBind -- >>=
deriving (Show, Eq)
data DoStmt
@@ -168,71 +142,19 @@ data DoStmt
deriving (Show)
type ArmBlock = [Arm]
data Arm = Arm Pat (Maybe Expr) Expr
data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard?, body
deriving (Show)
-- ─── Literals ───────────────────────────────────────────────────────────────
-- IP addresses are stored as plain Integers for easy arithmetic,
-- CIDR validation (mask host bits), and future subnet math.
-- IPv4: 32-bit value in the low 32 bits.
-- IPv6: 128-bit value.
-- CIDR host-bit validation: (addr .&. hostMask prefix bits) == 0
data IPVersion = IPv4 | IPv6
deriving (Show, Eq)
data Literal
= LInt Int
| LString String
| LBool Bool
| LIP IPVersion Integer -- unified IP address representation
| LCIDR Literal Int -- base address + prefix length
| LIPv4 (Word8,Word8,Word8,Word8)
| LIPv6 [Word16]
| LCIDR Literal Int
| LPort Int
| LDuration Int TimeUnit
| LHex Word8
deriving (Show, Eq)
-- ─── IP address helpers ──────────────────────────────────────────────────────
-- | Build an IPv4 literal from four octets.
ipv4Lit :: Int -> Int -> Int -> Int -> Literal
ipv4Lit a b c d =
LIP IPv4 (fromIntegral a `shiftL` 24
.|. fromIntegral b `shiftL` 16
.|. fromIntegral c `shiftL` 8
.|. fromIntegral d)
-- | Check that a CIDR has no host bits set.
cidrHostBitsZero :: Integer -> Int -> Int -> Bool
cidrHostBitsZero addr prefix bits =
let hostBits = bits - prefix
hostMask = (1 `shiftL` hostBits) - 1
in (addr .&. hostMask) == 0
-- | Render an IPv4 integer as a dotted-decimal string.
renderIPv4 :: Integer -> String
renderIPv4 n =
show ((n `shiftR` 24) .&. 0xff) ++ "." ++
show ((n `shiftR` 16) .&. 0xff) ++ "." ++
show ((n `shiftR` 8) .&. 0xff) ++ "." ++
show (n .&. 0xff)
-- | Render an IPv6 integer as a condensed colon-hex string.
renderIPv6 :: Integer -> String
renderIPv6 n =
let groups = [ fromIntegral ((n `shiftR` (i * 16)) .&. 0xffff) :: Int
| i <- [7,6..0] ]
hexGroups = map (`showHex` "") groups
in concatIntersperse ":" hexGroups
where
showHex x s = let h = showHexInt x in h ++ s
showHexInt x
| x == 0 = "0"
| otherwise = reverse (go x)
where go 0 = []
go v = let (q,r) = v `divMod` 16
c = "0123456789abcdef" !! r
in c : go q
concatIntersperse _ [] = ""
concatIntersperse _ [x] = x
concatIntersperse s (x:xs) = x ++ s ++ concatIntersperse s xs

69
src/FWL/Check.hs
View File

@@ -9,7 +9,7 @@ module FWL.Check
, CheckError(..)
) where
import Data.List (nub)
import Data.List (foldl', nub)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
@@ -20,7 +20,6 @@ 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
@@ -44,14 +43,12 @@ buildEnv = foldl' addDecl Map.empty
where
addDecl m (DInterface n _ _) = Map.insert n KInterface m
addDecl m (DZone n _) = Map.insert n KZone m
addDecl m (DImport n _ _) = Map.insert n KLet m
addDecl m (DLet n _ _) = Map.insert n KLet m
addDecl m (DPattern n _ _) = Map.insert n KPattern m
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
addDecl m _ = m
findDups :: [Decl] -> [CheckError]
findDups decls = go [] Set.empty decls
@@ -72,8 +69,6 @@ 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"
@@ -84,8 +79,6 @@ declKindStr (DPattern _ _ _) = "pattern"
declKindStr (DFlow _ _) = "flow"
declKindStr (DRule _ _ _) = "rule"
declKindStr (DPolicy _ _ _ _) = "policy"
declKindStr (DPortForward _ _ _ _) = "portforward"
declKindStr (DMasquerade _ _ _) = "masquerade"
-- ─── Name resolution ─────────────────────────────────────────────────────────
@@ -96,12 +89,6 @@ 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]
@@ -113,12 +100,11 @@ checkName env kind n
isBuiltin :: String -> Bool
isBuiltin n = n `elem`
[ "ct", "iif", "oif", "lo", "wan", "lan"
, "tcp", "udp", "ip", "ip6", "eth", "wg"
, "tcp", "udp", "ip", "ip6", "eth"
, "Established", "Related", "DNAT"
, "Allow", "Drop", "Continue", "Masquerade", "DNATMap"
, "Allow", "Drop", "Continue", "Masquerade"
, "Matched", "Unmatched"
, "true", "false"
, "matches", "flowOf", "Warn"
]
checkPat :: Env -> Pat -> [CheckError]
@@ -130,25 +116,6 @@ 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
@@ -168,36 +135,15 @@ checkFlow env (FSeq a b _) = checkFlow env a ++ checkFlow env b
checkArm :: Env -> Arm -> [CheckError]
checkArm env (Arm p mg e) =
let env' = addPat env p in
checkPat env p ++
maybe [] (checkExpr env') mg ++
checkExpr env' e
addPat :: Env -> Pat -> Env
addPat env (PVar n) = Map.insert n KLet env
addPat env (PCtor _ ps) = foldl' addPat env ps
addPat env (PTuple ps) = foldl' addPat env ps
addPat env (PRecord _ fs) = foldl' addFP env fs
addPat env (PFrame mp inner) =
let env' = case mp of
Just (PathPat ms md) ->
let env1 = case ms of Just (EPName n) -> Map.insert n KLet env; _ -> env
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
addFP env (FPBind n) = Map.insert n KLet env
addFP env (FPAs _ v) = Map.insert v KLet env
addFP env _ = env
maybe [] (checkExpr env) mg ++
checkExpr env e
checkExpr :: Env -> Expr -> [CheckError]
checkExpr env (EVar n) = checkName env "name" n
checkExpr _ (EQual _) = [] -- qualified names: deferred
checkExpr _ (ELit _) = []
checkExpr env (ELam n e) = checkExpr (Map.insert n KLet env) e
checkExpr env (ELam _ e) = checkExpr env e
checkExpr env (EApp f x) = checkExpr env f ++ checkExpr env x
checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab
checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f]
@@ -244,7 +190,6 @@ 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]]

776
src/FWL/Compile.hs
View File

@@ -1,13 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Compile a checked FWL program to nftables JSON using Aeson.
All policies (Filter and NAT) go into one table named by Config.
Layer stripping: Frame patterns that omit Ether compile identically
to those that include it.
Phase 1: DRule declarations compile to regular (no-hook) chains.
Phase 2: compileAction returns Maybe [Value] to support multi-step arms.
Phase 3: Log.emit -> {"log": ...} effect statement.
Phase 4: DFlow declarations -> ct mark state machines (_track chains).
to those that include it — the compiler inserts protocol matches
from whatever constructor the user wrote.
-}
module FWL.Compile
( compileProgram
@@ -16,384 +11,38 @@ module FWL.Compile
import Data.List (intercalate)
import Data.Maybe (mapMaybe)
import Data.Word (Word32)
import Numeric (showHex)
import qualified Data.Map.Strict as Map
import Data.Aeson ((.=), Value(..), object, toJSON)
import qualified Data.Aeson as A
import qualified Data.Text as T
import Data.Aeson ((.=), Value(..), object, toJSON)
import qualified Data.Aeson.Key as K
import qualified Data.ByteString.Lazy as BL
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.Aeson.Encode.Pretty as Pretty
import FWL.AST
-- ─── Entry points ────────────────────────────────────────────────────────────
-- | Compile an FWL program and render to pretty-printed JSON bytes.
compileToJson :: Program -> BL.ByteString
compileToJson = encodePretty . programToValue
-- exposed for tests
compileProgram :: Program -> Value
compileProgram = programToValue
-- ─── Compile environment ─────────────────────────────────────────────────────
-- | Per-compile environment threaded through all helpers.
data Env = Env
{ envDecls :: Map.Map String Decl
-- ^ all top-level declarations, keyed by name
, envCtMarks :: Map.Map String (Word32, Word32)
-- ^ flow-name -> (inProgress mark, confirmed mark)
-- populated in Phase 4; empty for Phases 1-3
}
buildEnv :: [Decl] -> Env
buildEnv decls = Env
{ envDecls = Map.fromList [ (declNameOf d, d) | d <- decls ]
, envCtMarks = Map.empty
}
where
declNameOf (DInterface n _ _) = n
declNameOf (DZone n _) = n
declNameOf (DPattern n _ _) = n
declNameOf (DFlow n _) = n
declNameOf (DRule n _ _) = n
declNameOf (DPolicy n _ _ _) = n
declNameOf (DLet n _ _) = n
declNameOf (DImport n _ _) = n
declNameOf (DPortForward n _ _ _) = n
declNameOf (DMasquerade n _ _) = n
-- ─── Top-level program ───────────────────────────────────────────────────────
compileToJson = Pretty.encodePretty . programToValue
-- | Compile an FWL program to an Aeson Value (the nftables JSON schema).
programToValue :: Program -> Value
programToValue (Program cfg decls) =
object [ "nftables" .= toJSON
(metainfo : tableObj : allObjects) ]
programToValue prog@(Program cfg decls) =
object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
where
-- Phase 4: allocate ct marks for all DFlow declarations
ctMarks = allocateCtMarks cfg decls
env = (buildEnv decls) { envCtMarks = ctMarks }
env = buildEnv decls
tbl = configTable cfg
metainfo = object [ "metainfo" .= object
[ "json_schema_version" .= (1 :: Int) ] ]
metainfo = object [ "metainfo" .= object [ "json_schema_version" .= (1 :: Int) ] ]
tableObj = object [ "table" .= tableValue tbl ]
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
portfwds = [ d | d@(DPortForward {}) <- decls ]
masqs = [ d | d@(DMasquerade {}) <- decls ]
rules = [ (n, e) | DRule n _ e <- decls ] -- Phase 1
flows = [ (n, fe) | DFlow n fe <- decls ] -- Phase 4
hasPortFwd = not (null portfwds)
chainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
ruleObjs = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies
-- ── Chain declarations ──────────────────────────────────────────────
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
masqChainObjs = concatMap (masqChainValue tbl) masqs
-- Phase 1: one regular chain per DRule
ruleChainObjs = map (\(n, _) -> regularChainValue tbl n) rules
-- Phase 4: one _track chain per DFlow + optional ct timeout objects
flowChainObjs = concatMap (flowTrackChainValue tbl ctMarks) flows
flowTimeoutObjs = concatMap (flowTimeoutValue tbl) flows
-- ── Rules ───────────────────────────────────────────────────────────
policyRuleObjs = concatMap
(\(n, pm, ab) ->
injectFilterRules env tbl n pm hasPortFwd ++
concatMap (armToRuleValues env tbl n) ab)
policies
-- Phase 1: compile the lambda body of each DRule into its chain
ruleRuleObjs = concatMap (\(n, e) -> ruleBodyToValues env tbl n e) rules
pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
-- Phase 4: synthesise _track chain rules
flowTrackRules = concatMap (flowTrackRuleValues tbl ctMarks) flows
-- Sets / maps from let-bindings
letDecls = [ (n, t, e) | DLet n t e <- decls ]
mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls
-- Synthesised maps from portforward decls
pfMapObjs = concatMap (portfwdMapValue tbl) portfwds
allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs
++ ruleChainObjs -- Phase 1
++ flowTimeoutObjs ++ flowChainObjs -- Phase 4
++ pfMapObjs ++ mapObjs
++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs
++ ruleRuleObjs -- Phase 1
++ flowTrackRules -- Phase 4
-- ─── Phase 1: Regular chain declarations ─────────────────────────────────────
-- | Emit a *regular* chain (no type/hook/prio/policy) for a DRule.
regularChainValue :: String -> Name -> Value
regularChainValue tbl n = object
[ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
]
]
-- | Compile the body of a DRule (a lambda / case expression) into rules
-- belonging to the rule's own chain.
ruleBodyToValues :: Env -> String -> Name -> Expr -> [Value]
ruleBodyToValues env tbl chain expr =
case expr of
ELam _ body -> ruleBodyToValues env tbl chain body
ECase _ ab -> concatMap (armToRuleValues env tbl chain) ab
_ -> [] -- bare expressions are not yet compilable here
-- ─── Phase 4: ct mark allocation ─────────────────────────────────────────────
-- | Allocate (inProgress, confirmed) ct mark pairs for every DFlow decl.
-- Marks are in the range [prefix+1, prefix+2n] where prefix = 0xfee10000
-- (or the value from config { ct_mark_prefix = 0x????; }).
allocateCtMarks :: Config -> [Decl] -> Map.Map String (Word32, Word32)
allocateCtMarks cfg decls =
Map.fromList (zipWith mk flowNames [0..])
where
flowNames = [ n | DFlow n _ <- decls ]
base :: Word32
base = fromIntegral (configCtMarkPrefix cfg) `shiftL32` 16
mk n (i :: Word32) = (n, (base + 2*i + 1, base + 2*i + 2))
-- Portable left-shift for Word32 (avoids importing Data.Bits at top level)
shiftL32 :: Word32 -> Int -> Word32
shiftL32 w n = w * (2 ^ n)
-- ─── Phase 4: _track chain + rules ───────────────────────────────────────────
-- | Emit the regular _track chain declaration for a DFlow.
flowTrackChainValue :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackChainValue tbl _ctMarks (n, _) =
[ regularChainValue tbl (n ++ "_track") ]
-- | Emit the ct timeout object for a DFlow that has a `within` clause.
flowTimeoutValue :: String -> (Name, FlowExpr) -> [Value]
flowTimeoutValue tbl (n, fe) =
case withinDuration fe of
Nothing -> []
Just (secs, _) ->
[ object
[ "ct timeout" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_timeout")
, "protocol" .= ("udp" :: String)
, "state" .= object
[ "untracked" .= (show secs ++ "s" :: String) ]
]
]
]
where
withinDuration (FSeq _ _ (Just d)) = Just d
withinDuration (FSeq a b Nothing) =
case withinDuration a of
Just d -> Just d
Nothing -> withinDuration b
withinDuration _ = Nothing
-- | Synthesise the two tracking rules inside the _track chain.
-- Rule 1: ct mark 0 + init-pattern-match -> set mark to inProgress, return
-- Rule 2: ct mark inProgress + resp-match -> set mark to confirmed, return
flowTrackRuleValues :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackRuleValues tbl ctMarks (n, fe) =
case Map.lookup n ctMarks of
Nothing -> []
Just (inProg, confirmed) ->
let chain = n ++ "_track"
(initAtom, respAtom) = flowAtoms fe
rule1 = ruleValue tbl chain $
[ ctMarkMatch "==" 0 ] ++
atomMatchExprs initAtom ++
[ ctMangleExpr inProg
, object ["return" .= Null]
]
rule2 = ruleValue tbl chain $
[ ctMarkMatch "==" inProg ] ++
atomMatchExprs respAtom ++
[ ctMangleExpr confirmed
, object ["return" .= Null]
]
in [rule1, rule2]
-- | Extract (init, response) atoms from a FlowExpr.
flowAtoms :: FlowExpr -> (Name, Name)
flowAtoms (FAtom n) = (n, n)
flowAtoms (FSeq (FAtom a) b _)= let (_, r) = flowAtoms b in (a, r)
flowAtoms (FSeq a _ _) = let (i, _) = flowAtoms a in (i, i)
-- | Pattern-match expressions for a known flow atom.
-- WGInitiation -> meta l4proto udp + @th,0,8 == 0x01
-- WGResponse -> meta l4proto udp + @th,0,8 == 0x02
atomMatchExprs :: Name -> [Value]
atomMatchExprs "WGInitiation" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 1
]
atomMatchExprs "WGResponse" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 2
]
atomMatchExprs _ = [] -- unknown atom: no-op (comment only in real impl)
-- | Match on @th,<offset>,<len> (raw transport-header bits).
rawBitsMatch :: Int -> Int -> Int -> Value
rawBitsMatch offset len val = matchExpr "=="
(object ["payload" .= object
[ "base" .= ("transport" :: String)
, "offset" .= offset
, "len" .= len
]])
(toJSON val)
-- | Match ct mark with operator and numeric value.
ctMarkMatch :: String -> Word32 -> Value
ctMarkMatch op val = matchExpr op
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON val)
-- | Mangle (set) ct mark to a value.
ctMangleExpr :: Word32 -> Value
ctMangleExpr val = object
[ "mangle" .= object
[ "key" .= object ["ct" .= object ["key" .= ("mark" :: String)]]
, "value" .= toJSON val
]
]
-- ─── Implicit filter-hook rule injection ─────────────────────────────────────
-- | Prepend implicit rules for filter-hook chains (Input/Forward/Output).
injectFilterRules :: Env -> String -> Name -> PolicyMeta -> Bool -> [Value]
injectFilterRules env tbl chain pm hasPortFwd =
case pmHook pm of
HInput -> [statefulRule, loopbackRule, ndpRule]
HForward -> statefulRule : if hasPortFwd then [ctDnatRule] else []
HOutput -> [statefulRule]
_ -> []
where
statefulRule = ruleValue tbl chain
[ matchExpr "==" (object ["ct" .= object ["key" .= ("state" :: String)]])
(setVal [A.String "established", A.String "related"])
, object ["accept" .= Null]
]
loopbackRule = ruleValue tbl chain
[ matchMeta "iifname" "lo"
, object ["accept" .= Null]
]
ndpRule = ruleValue tbl chain
[ matchPayload "ip6" "nexthdr" "ipv6-icmp"
, matchExpr "==" (payloadVal "ip6" "saddr")
(object ["prefix" .= object ["addr" .= A.String "fe80::", "len" .= (10 :: Int)]])
, object ["accept" .= Null]
]
ctDnatRule = ruleValue tbl chain
[ matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]])
(A.String "dnat")
, object ["accept" .= Null]
]
_ = env -- silence unused warning
ruleValue :: String -> String -> [Value] -> Value
ruleValue tbl chain exprs = object
[ "rule" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "chain" .= chain
, "expr" .= toJSON exprs
]
]
-- ─── DPortForward compilation ─────────────────────────────────────────────────
portfwdMapValue :: String -> Decl -> [Value]
portfwdMapValue tbl (DPortForward n _ t entries) =
case t of
TName "Map" [tk, tv] ->
[ object [ "map" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= renderNftType (fwlTypeToNft tv)
, "elem" .= toJSON (map renderMapElem entries)
] ]
]
_ -> []
portfwdMapValue _ _ = []
portfwdChainValue :: String -> Decl -> [Value]
portfwdChainValue tbl (DPortForward n _ _ _) =
[ object [ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_prerouting")
, "type" .= ("nat" :: String)
, "hook" .= ("prerouting" :: String)
, "prio" .= priorityInt pDstNat
, "policy" .= ("accept" :: String)
] ]
]
portfwdChainValue _ _ = []
portfwdRuleValues :: Env -> String -> Decl -> [Value]
portfwdRuleValues _ tbl (DPortForward n _ _ _) =
let chainName = n ++ "_prerouting"
in [ ruleValue tbl chainName
[ matchMeta "nfproto" "ipv4"
, matchInSet (metaVal "l4proto") [A.String "tcp", A.String "udp"]
, matchExpr "==" (object ["fib" .= object ["result" .= ("type" :: String), "flags" .= toJSON (["daddr"] :: [String])]])
(A.String "local")
, object ["dnat" .= object
[ "family" .= ("ip" :: String)
, "addr" .= object
[ "map" .= object
[ "key" .= object ["concat" .= toJSON
[ metaVal "l4proto"
, payloadVal "th" "dport"
]]
, "data" .= A.String (toText ("@" ++ n))
]
]
]]
]
]
portfwdRuleValues _ _ _ = []
-- ─── DMasquerade compilation ──────────────────────────────────────────────────
masqChainValue :: String -> Decl -> [Value]
masqChainValue tbl (DMasquerade n _ _) =
[ object [ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_postrouting")
, "type" .= ("nat" :: String)
, "hook" .= ("postrouting" :: String)
, "prio" .= priorityInt pSrcNat
, "policy" .= ("accept" :: String)
] ]
]
masqChainValue _ _ = []
masqRuleValues :: Env -> String -> Decl -> [Value]
masqRuleValues _ tbl (DMasquerade n iface srcSet) =
let chainName = n ++ "_postrouting"
in [ ruleValue tbl chainName
[ matchMeta "oifname" iface
, matchExpr "==" (payloadVal "ip" "saddr")
(A.String (toText ("@" ++ srcSet)))
, object ["masquerade" .= Null]
]
]
masqRuleValues _ _ _ = []
mapObjs = mapMaybe (\(n, _, e) -> letToMapValue tbl n e) letDecls
-- ─── Table / Chain declarations ──────────────────────────────────────────────
@@ -411,7 +60,7 @@ chainDeclValue tbl n pm = object
, "name" .= n
, "type" .= chainTypeStr (pmTable pm)
, "hook" .= hookStr (pmHook pm)
, "prio" .= priorityInt (pmPriority pm)
, "prio" .= priorityStr (pmPriority pm)
, "policy" .= defaultPolicyStr (pmHook pm)
]
]
@@ -427,10 +76,14 @@ hookStr HOutput = "output"
hookStr HPrerouting = "prerouting"
hookStr HPostrouting = "postrouting"
-- Priority is emitted as an integer in nftables JSON.
priorityInt :: Priority -> Int
priorityInt = priorityValue
priorityStr :: Priority -> String
priorityStr PFilter = "filter"
priorityStr PDstNat = "dstnat"
priorityStr PSrcNat = "srcnat"
priorityStr PMangle = "mangle"
priorityStr (PInt n) = show n
-- Input and Forward hooks default to drop; everything else to accept.
defaultPolicyStr :: Hook -> String
defaultPolicyStr HInput = "drop"
defaultPolicyStr HForward = "drop"
@@ -438,359 +91,226 @@ defaultPolicyStr _ = "accept"
-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
armToRuleValues :: Env -> String -> Name -> Arm -> [Value]
-- Each policy arm becomes zero or more nftables rule objects.
-- An arm whose action is Continue compiles to zero rules.
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value]
armToRuleValues env tbl chain (Arm p mg body) =
-- Phase 2: compileAction returns Maybe [Value]
case compileAction env body of
Nothing -> []
Just verdicts ->
let patExprsAlts = compilePat env p
Nothing -> [] -- Continue: emit nothing
Just verdict ->
let patExprs = compilePat env p
guardExprs = maybe [] (compileGuard env) mg
allExprs = patExprs ++ guardExprs ++ [verdict]
in [ object
[ "rule" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "chain" .= chain
, "expr" .= toJSON (patExprs ++ guardExprs ++ verdicts)
, "expr" .= toJSON allExprs
]
]
]
| patExprs <- patExprsAlts ]
-- ─── Pattern → [Value] ───────────────────────────────────────────────────────
type CompileEnv = Map.Map String Decl -- kept for internal helpers that only
-- need the decl map
type CompileEnv = Map.Map String Decl
-- Convenience accessor
declEnv :: Env -> CompileEnv
declEnv = envDecls
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
compilePat :: Env -> 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) = do
pathConds <- maybe [[]] (compilePathPat env) mp
innerConds <- compilePat env inner
return (pathConds ++ innerConds)
compilePat env (PFrame mp inner) =
maybe [] (compilePathPat env) mp ++ compilePat env inner
compilePat env (PCtor n ps) = compileCtorPat env n ps
compilePat _ (PRecord n fs) = compileRecordPat n fs
compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps))
compilePat _ (PBytes _) = [[]]
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
compilePat env (PTuple ps) = concatMap (compilePat env) ps
compilePat _ (PBytes _) = [] -- handled by flow/ct mark (future)
expandNamedPat :: Env -> Name -> [[Value]]
-- Named patterns are inlined at compile time.
expandNamedPat :: CompileEnv -> Name -> [Value]
expandNamedPat env n =
case Map.lookup n (declEnv env) of
case Map.lookup n env of
Just (DPattern _ _ p) -> compilePat env p
_ -> []
compileCtorPat :: Env -> String -> [Pat] -> [[Value]]
-- Layer stripping: Ether is transparent; IPv4/IPv6/TCP/UDP/ICMPv6 each emit
-- the appropriate protocol-selector match then recurse into their children.
-- Omitting Ether produces identical output.
compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
compileCtorPat env ctor ps = case ctor of
"Ether" -> 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
"Ether" -> children -- transparent layer
"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
_ -> children
where
children = map concat (sequence (map (compilePat env) ps))
children = concatMap (compilePat env) ps
compileRecordPat :: String -> [FieldPat] -> [[Value]]
compileRecordPat proto fs = [mapMaybe go fs]
-- Record patterns emit field equality matches, e.g. tcp { dport = :22 }.
compileRecordPat :: String -> [FieldPat] -> [Value]
compileRecordPat proto = mapMaybe go
where
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
go _ = Nothing
compilePathPat :: Env -> PathPat -> [[Value]]
compilePathPat env (PathPat ms md) =
[ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint env "oifname") md ]
-- Path patterns (iif/oif).
compilePathPat :: CompileEnv -> PathPat -> [Value]
compilePathPat _ (PathPat ms md) =
maybe [] (compileEndpoint "iifname") ms ++
maybe [] (compileEndpoint "oifname") md
compileEndpoint :: Env -> String -> EndpointPat -> [Value]
compileEndpoint _ _ EPWild = []
compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint env dir (EPMember _ z) =
case Map.lookup z (declEnv env) of
Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
_ -> [matchInSet (metaVal dir) [A.String (toText z)]]
compileEndpoint :: String -> EndpointPat -> [Value]
compileEndpoint _ EPWild = []
compileEndpoint dir (EPName n) = [matchMeta dir n]
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]]
-- zone membership: for MVP we emit the zone name as a set element.
-- A later pass would expand zones to their member interface names.
-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: Env -> Expr -> [Value]
compileGuard :: CompileEnv -> Expr -> [Value]
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal 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 _ _ = []
compileInExpr :: Env -> Expr -> Expr -> Value
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 (declEnv env) =
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r)
compileInExpr :: Expr -> Expr -> Value
-- ct.state in { Established, Related }
compileInExpr (EQual ["ct","state"]) (ESet vs) = ctMatch "state" vs
compileInExpr (EQual ["ct","status"]) (ESet vs) = ctMatch "status" vs
-- generic set membership
compileInExpr l (ESet vs) = matchExpr "in" (exprVal l) (setVal (map exprToStr vs))
compileInExpr l r = matchExpr "==" (exprVal l) (exprVal r)
-- ─── Action → Maybe [Value] (Phase 2) ───────────────────────────────────────
--
-- Returns Nothing for Continue (arm is silently dropped).
-- Returns Just [..] for everything else.
-- Single-verdict arms return a one-element list.
-- Multi-step do-block arms return a multi-element list.
ctMatch :: String -> [Expr] -> Value
ctMatch key vs = matchExpr "in"
(object ["ct" .= object ["key" .= key]])
(setVal (map exprToStr vs))
compileAction :: Env -> Expr -> Maybe [Value]
-- Simple verdicts
compileAction _ (EVar "Allow") = Just [object ["accept" .= Null]]
compileAction _ (EVar "Drop") = Just [object ["drop" .= Null]]
-- ─── Action → Maybe Value (Nothing = Continue = no rule) ─────────────────────
compileAction :: CompileEnv -> Expr -> Maybe Value
compileAction _ (EVar "Allow") = Just (object ["accept" .= Null])
compileAction _ (EVar "Drop") = Just (object ["drop" .= Null])
compileAction _ (EVar "Continue") = Nothing
compileAction _ (EVar "Masquerade") = Just [object ["masquerade" .= Null]]
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null])
compileAction _ (EApp (EVar "DNAT") arg) =
Just [object ["dnat" .= object ["addr" .= exprToStr arg]]]
compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
Just [object ["dnat" .= object ["addr" .= object
[ "map" .= object [ "key" .= exprVal env key
, "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]]
-- Phase 1: rule call -> jump
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]]
compileAction _ (EApp (EVar "DNATMap") arg) =
Just $ object ["dnat" .= object ["addr" .= object
["map" .= object ["key" .= object ["concat" .= Array mempty]
,"data" .= exprToStr arg]]]]
-- Rule invocation → jump
compileAction env (EApp (EVar rn) _) =
case Map.lookup rn (declEnv env) of
Just (DRule _ _ _) -> Just [object ["jump" .= object ["target" .= rn]]]
_ -> Just [object ["accept" .= Null]]
-- Phase 3: Log.emit effect
compileAction env (EPerform ["Log", "emit"] [levelExpr, msgExpr]) =
let lvl = case levelExpr of
EVar "Warn" -> "warn"
EVar "Info" -> "info"
EVar "Debug" -> "debug"
_ -> "warn"
msg = case msgExpr of
ELit (LString s) -> s
_ -> exprToStr msgExpr
logStmt = object ["log" .= object
[ "prefix" .= A.String (toText msg)
, "level" .= A.String (toText lvl)
]]
in Just [logStmt] -- single statement; do-block handles sequencing
compileAction _ (EPerform ["Log", "emit"] _) =
Just [object ["log" .= object ["prefix" .= A.String ""]]]
-- Phase 4: FlowMatch.check effect
compileAction env (EPerform ["FlowMatch", "check"] (EVar flowName : _)) =
case Map.lookup flowName (envCtMarks env) of
Just (_inProg, confirmed) ->
Just
[ object ["jump" .= object ["target" .= (flowName ++ "_track")]]
, matchExpr "=="
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON confirmed)
]
Nothing ->
-- flow not found; emit jump only
Just [object ["jump" .= object ["target" .= (flowName ++ "_track")]]]
compileAction _ (EPerform ["FlowMatch", "check"] _) =
Just [object ["accept" .= Null]]
-- do-block: sequence statements, collecting all effects + final verdict
compileAction env (EDo stmts) = compileDo env stmts
-- Fallback
compileAction _ _ = Just [object ["accept" .= Null]]
case Map.lookup rn env of
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
_ -> Just (object ["accept" .= Null])
compileAction _ _ = Just (object ["accept" .= Null])
-- | Compile a do-block: each DSExpr is compiled and its [Value] contributions
-- are concatenated in order. DSBind is ignored for now.
compileDo :: Env -> [DoStmt] -> Maybe [Value]
compileDo _ [] = Nothing
compileDo env stmts =
let results = concatMap compileStmt stmts
in if null results then Nothing else Just results
where
compileStmt (DSBind _ e) = maybe [] id (compileAction env e)
compileStmt (DSExpr e) = maybe [] id (compileAction env e)
-- ─── Let → Map object ────────────────────────────────────────────────────────
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
letToMapValue :: String -> Name -> Expr -> Maybe Value
letToMapValue tbl n (EMap entries) = Just $ object
[ "map" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
, "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= renderNftType (fwlTypeToNft tv)
, "type" .= ("inetproto . inetservice" :: String)
, "map" .= ("ipv4_addr . inetservice" :: String)
, "elem" .= toJSON (map renderMapElem entries)
]
]
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
letToMapValue _ _ _ = Nothing
renderMapElem :: (Expr, Expr) -> Value
renderMapElem (k, v) = toJSON
[ renderMapOrSetKey k
, renderMapOrSetKey v
[ object ["concat" .= toJSON [exprToStr k]]
, exprToStr v
]
renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey
isCidrElem :: Expr -> Bool
isCidrElem (ELit (LCIDR _ _)) = True
isCidrElem _ = False
-- ─── Aeson building blocks ───────────────────────────────────────────────────
-- { "match": { "op": op, "left": left, "right": right } }
matchExpr :: String -> Value -> Value -> Value
matchExpr op l r = object
[ "match" .= object
[ "op" .= (op :: String)
[ "op" .= op
, "left" .= l
, "right" .= r
]
]
matchMeta :: String -> String -> Value
matchMeta key val = matchExpr "==" (metaVal key) (A.String (toText val))
matchMeta key val = matchExpr "==" (metaVal key) (A.String (strText val))
matchPayload :: String -> String -> String -> Value
matchPayload proto field val =
matchExpr "==" (payloadVal proto field) (A.String (toText val))
matchExpr "==" (payloadVal proto field) (A.String (strText val))
matchInSet :: Value -> [Value] -> Value
matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
matchInSet :: Value -> [String] -> Value
matchInSet lhs vals =
matchExpr "in" lhs (setVal vals)
metaVal :: String -> Value
metaVal key = object ["meta" .= object ["key" .= (key :: String)]]
metaVal key = object ["meta" .= object ["key" .= key]]
payloadVal :: String -> String -> Value
payloadVal proto field =
object ["payload" .= object
[ "protocol" .= (proto :: String)
, "field" .= (field :: String)
]]
object ["payload" .= object ["protocol" .= proto, "field" .= field]]
setVal :: [Value] -> Value
setVal :: [String] -> Value
setVal vs = object ["set" .= toJSON vs]
-- ─── Expression helpers ───────────────────────────────────────────────────────
-- ─── Expression → Value helpers ──────────────────────────────────────────────
isSetOrMapRef :: Env -> Name -> Bool
isSetOrMapRef env n = case Map.lookup n (declEnv env) of
Just (DLet _ _ _) -> True
Just (DImport _ _ _) -> True
_ -> False
mapField :: String -> String
mapField "src" = "saddr"
mapField "dst" = "daddr"
mapField f = f
exprVal :: Env -> 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"
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 (declEnv 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))
exprVal :: Expr -> Value
exprVal (EQual [p, f]) = payloadVal p f
exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= k]]
exprVal (EVar n) = metaVal n
exprVal (ELit l) = A.String (strText (renderLit l))
exprVal (ESet vs) = setVal (map exprToStr vs)
exprVal e = A.String (strText (exprToStr e))
exprToStr :: Expr -> String
exprToStr (EVar n) = case n of
"Established" -> "established"
"Related" -> "related"
"DNAT" -> "dnat"
_ -> n
exprToStr (EVar n) = n
exprToStr (ELit l) = renderLit l
exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
exprToStr _ = "_"
toText :: String -> T.Text
toText = T.pack
strText :: String -> A.Text
strText = \s -> read (show s) -- simple String→Text without extra dep
renderLit :: Literal -> String
renderLit (LInt n) = show n
renderLit (LString s) = s
renderLit (LBool True) = "true"
renderLit (LBool False) = "false"
renderLit (LIP IPv4 n) = renderIPv4 n
renderLit (LIP IPv6 n) = renderIPv6 n
renderLit (LIPv4 (a,b,c,d)) =
show a++"."++show b++"."++show c++"."++show d
renderLit (LIPv6 _) = "::1"
renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p
renderLit (LPort p) = show p
renderLit (LDuration n Seconds) = show n ++ "s"
renderLit (LDuration n Millis) = show n ++ "ms"
renderLit (LDuration n Minutes) = show n ++ "m"
renderLit (LDuration n Hours) = show n ++ "h"
renderLit (LDuration n Seconds) = show n
renderLit (LDuration n _) = show n
renderLit (LHex b) = show b
-- ─── Hex rendering helper (for ct mark values in comments) ───────────────────
hex32 :: Word32 -> String
hex32 w = "0x" ++ showHex w ""
-- silence unused warning for hex32 (used in potential debug output)
_ = hex32
-- Data.Aeson.Key helper (aeson >= 2.0 uses Key, not Text, for object keys)
(.=) :: A.ToJSON v => String -> v -> A.Pair
k .= v = (K.fromString k, toJSON v)

14
src/FWL/Lexer.hs
View File

@@ -15,21 +15,19 @@ fwlDef = emptyDef
, Tok.identStart = letter <|> char '_'
, Tok.identLetter = alphaNum <|> char '_'
, Tok.reservedNames =
-- Only genuine syntactic keywords belong here.
-- Semantic values used as constructors, actions, type names, or
-- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must
-- NOT be reserved so that `identifier` can consume them in those
-- positions.
[ "config"
[ "config", "table"
, "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"
, "WAN", "LAN", "WireGuard"
, "Input", "Forward", "Output", "Prerouting", "Postrouting"
, "Filter", "NAT", "Mangle", "DstNat", "SrcNat", "Raw", "ConnTrack"
, "Filter", "NAT", "Mangle", "DstNat", "SrcNat"
, "Allow", "Drop", "Continue", "Masquerade", "DNAT", "DNATMap"
, "Log", "Info", "Warn", "Error"
, "Matched", "Unmatched"
, "Frame", "FlowPattern"
, "true", "false"
]
, Tok.reservedOpNames =

279
src/FWL/Parser.hs
View File

@@ -3,19 +3,15 @@ module FWL.Parser
, parseFile
) where
import Control.Monad (void, when)
import Data.Bits ((.&.), (.|.), shiftL)
import Data.List (foldl')
import Control.Monad (void)
import Data.Word (Word8)
import Numeric (readHex)
import Text.Parsec
import Text.Parsec.String (Parser)
import Data.Functor.Identity (Identity)
import qualified Text.Parsec.Expr as Ex
import FWL.AST
import FWL.Lexer
import Data.Char (isUpper)
-- ─── Entry points ────────────────────────────────────────────────────────────
@@ -38,7 +34,7 @@ program = do
configBlock :: Parser Config
configBlock = do
reserved "config"
props <- braces (endBy configProp semi)
props <- braces (semiSep configProp)
optional semi
return $ foldr applyProp defaultConfig props
where
@@ -47,10 +43,10 @@ configBlock = do
configProp :: Parser (String, String)
configProp = do
n <- identifier -- "table" is no longer reserved
reserved "table"
reservedOp "="
v <- stringLit
return (n, v)
return ("table", v)
-- ─── Declarations ────────────────────────────────────────────────────────────
@@ -63,8 +59,6 @@ decl = interfaceDecl
<|> flowDecl
<|> ruleDecl
<|> policyDecl
<|> portforwardDecl
<|> masqueradeDecl
interfaceDecl :: Parser Decl
interfaceDecl = do
@@ -72,8 +66,8 @@ interfaceDecl = do
n <- identifier
reservedOp ":"
k <- ifaceKind
ps <- braces (endBy ifaceProp semi)
_ <- semi
ps <- braces (semiSep ifaceProp)
semi
return (DInterface n k ps)
ifaceKind :: Parser IfaceKind
@@ -96,7 +90,7 @@ zoneDecl = do
n <- identifier
reservedOp "="
ns <- braces (commaSep1 identifier)
_ <- semi
semi
return (DZone n ns)
importDecl :: Parser Decl
@@ -107,7 +101,7 @@ importDecl = do
t <- typeP
reserved "from"
s <- stringLit
_ <- semi
semi
return (DImport n t s)
letDecl :: Parser Decl
@@ -118,7 +112,7 @@ letDecl = do
t <- typeP
reservedOp "="
e <- expr
_ <- semi
semi
return (DLet n t e)
patternDecl :: Parser Decl
@@ -129,7 +123,7 @@ patternDecl = do
t <- typeP
reservedOp "="
p <- pat
_ <- semi
semi
return (DPattern n t p)
flowDecl :: Parser Decl
@@ -140,7 +134,7 @@ flowDecl = do
reserved "FlowPattern"
reservedOp "="
f <- flowExpr
_ <- semi
semi
return (DFlow n f)
ruleDecl :: Parser Decl
@@ -151,7 +145,7 @@ ruleDecl = do
t <- typeP
reservedOp "="
e <- expr
_ <- semi
semi
return (DRule n t e)
policyDecl :: Parser Decl
@@ -160,31 +154,26 @@ policyDecl = do
n <- identifier
reservedOp ":"
t <- typeP
reserved "hook"
h <- hookP
mp <- optionMaybe (reserved "priority" >> priorityP)
let tb = hookDefaultTable h
pr = maybe (hookDefaultPriority h) id mp
reserved "on"
pm <- braces policyMeta
reservedOp "="
ab <- armBlock
_ <- semi
return (DPolicy n t (PolicyMeta h tb pr) ab)
semi
return (DPolicy n t pm ab)
-- | Infer table from hook
hookDefaultTable :: Hook -> TableName
hookDefaultTable HInput = TFilter
hookDefaultTable HForward = TFilter
hookDefaultTable HOutput = TFilter
hookDefaultTable HPrerouting = TNAT
hookDefaultTable HPostrouting = TNAT
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)
-- | Default priority per hook
hookDefaultPriority :: Hook -> Priority
hookDefaultPriority HInput = pFilter
hookDefaultPriority HForward = pFilter
hookDefaultPriority HOutput = pFilter
hookDefaultPriority HPrerouting = pDstNat
hookDefaultPriority HPostrouting = pSrcNat
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)
hookP :: Parser Hook
hookP = (reserved "Input" >> return HInput)
@@ -193,48 +182,16 @@ hookP = (reserved "Input" >> return HInput)
<|> (reserved "Prerouting" >> return HPrerouting)
<|> (reserved "Postrouting" >> return HPostrouting)
-- 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)
tableNameP :: Parser TableName
tableNameP = (reserved "Filter" >> return TFilter)
<|> (reserved "NAT" >> return TNAT)
priorityP :: Parser Priority
priorityP
= (reserved "Filter" >> return pFilter)
<|> (reserved "DstNat" >> return pDstNat)
<|> (reserved "SrcNat" >> return pSrcNat)
<|> (reserved "Mangle" >> return pMangle)
<|> (reserved "Raw" >> return pRaw)
<|> (reserved "ConnTrack" >> return pConnTrack)
<|> (Priority . fromIntegral <$> integerP)
where
-- Accept optional leading minus for negative priorities
integerP = do
neg <- option 1 (char '-' >> return (-1))
n <- natural
whiteSpace
return (neg * fromIntegral n)
priorityP = (reserved "Filter" >> return PFilter)
<|> (reserved "DstNat" >> return PDstNat)
<|> (reserved "SrcNat" >> return PSrcNat)
<|> (reserved "Mangle" >> return PMangle)
<|> (PInt . fromIntegral <$> natural)
-- ─── Arm blocks ──────────────────────────────────────────────────────────────
@@ -243,24 +200,19 @@ armBlock = braces (many arm)
arm :: Parser Arm
arm = do
_ <- symbol "|"
symbol "|"
p <- pat
g <- optionMaybe (reserved "if" >> expr)
reservedOp "->"
e <- expr
_ <- semi
semi
return (Arm p g e)
-- ─── Patterns ────────────────────────────────────────────────────────────────
pat :: Parser Pat
pat = Ex.buildExpressionParser patTable patAtom <?> "pattern"
where
patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ]
patAtom :: Parser Pat
patAtom = wildcardPat
<|> try framePat
pat = wildcardPat
<|> framePat
<|> try tuplePat
<|> bytesPat
<|> try recordPat
@@ -284,7 +236,7 @@ frameArgs = try withPath <|> withoutPath
where
withPath = do
pp <- pathPat
_ <- comma
comma
inner <- pat
return (Just pp, inner)
withoutPath = do
@@ -319,7 +271,7 @@ tuplePat = do
commaSep2 :: Parser a -> Parser [a]
commaSep2 p = do
x <- p
_ <- comma
comma
xs <- commaSep1 p
return (x:xs)
@@ -338,9 +290,8 @@ hexByte = do
h1 <- hexDigit
h2 <- hexDigit
whiteSpace
case (readHex [h1,h2] :: [(Integer, String)]) of
[(v,"")] -> return (fromIntegral v)
_ -> fail "invalid hex byte"
let [(v,"")] = readHex [h1,h2]
return (fromIntegral v)
-- Record pattern: ident { fields }
recordPat :: Parser Pat
@@ -352,25 +303,17 @@ recordPat = do
fieldPat :: Parser FieldPat
fieldPat = do
n <- identifier
try (reservedOp "=" >> FPEq n <$> fieldLiteral)
try (reservedOp "=" >> FPEq n <$> literal)
<|> try (reserved "as" >> FPAs n <$> identifier)
<|> return (FPBind n)
-- Port literals (:22) are valid in record field position as well as plain literals.
fieldLiteral :: Parser Literal
fieldLiteral = try portLit <|> literal
where
portLit = do
void (char ':')
n <- fromIntegral <$> natural
return (LPort n)
-- Named pattern reference OR constructor: starts with uppercase-ish ident
namedOrCtorPat :: Parser Pat
namedOrCtorPat = do
n <- identifier
args <- optionMaybe (try (parens (commaSep pat)))
case args of
Nothing -> return $ if null n then PWild else if isUpper (head n) then PNamed n else PVar n
Nothing -> return (PNamed n) -- bare name = named pattern ref
Just ps -> return (PCtor n ps)
-- ─── Flow expressions ────────────────────────────────────────────────────────
@@ -380,17 +323,13 @@ flowExpr = do
first <- FAtom <$> identifier
rest <- many (reservedOp "." >> identifier)
mw <- optionMaybe (reserved "within" >> durationLit)
let chain = buildSeq (first : map FAtom rest)
return $ case mw of
Nothing -> chain
Just w -> attach w chain
return $ buildSeq (first : map FAtom rest) mw
where
buildSeq [x] = x
buildSeq (x:xs) = FSeq x (buildSeq xs) Nothing
buildSeq [] = error "impossible"
attach w (FSeq a b _) = FSeq a b (Just w)
attach w x = FSeq x x (Just w)
buildSeq [x] mw = case mw of
Nothing -> x
Just w -> FSeq x x (Just w) -- degenerate
buildSeq (x:xs) mw = FSeq x (buildSeq xs mw) mw
buildSeq [] _ = error "impossible"
durationLit :: Parser Duration
durationLit = do
@@ -579,7 +518,7 @@ mapEntry = do
literal :: Parser Literal
literal
= try ipOrCidrLit
= try cidrOrIpLit
<|> try hexLit
<|> try (LBool True <$ reserved "true")
<|> try (LBool False <$ reserved "false")
@@ -589,110 +528,26 @@ literal
hexLit :: Parser Literal
hexLit = LHex <$> hexByte
-- ─── IP / CIDR parsing ───────────────────────────────────────────────────────
-- | Parse an IPv4 or IPv6 address, optionally followed by /prefix.
-- Tries IPv6 first (it can start with hex digits too), then IPv4.
ipOrCidrLit :: Parser Literal
ipOrCidrLit = do
ip <- try ipv6Lit <|> ipv4Lit_
cidrOrIpLit :: Parser Literal
cidrOrIpLit = do
a <- fromIntegral <$> natural
void (char '.')
b <- fromIntegral <$> natural
void (char '.')
c <- fromIntegral <$> natural
void (char '.')
d <- fromIntegral <$> natural
whiteSpace
mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural)
whiteSpace
let ip = LIPv4 (a,b,c,d)
return $ case mPrefix of
Nothing -> ip
Just p -> LCIDR ip p
-- | IPv4: four decimal octets separated by dots → LIP IPv4 (32-bit Integer)
ipv4Lit_ :: Parser Literal
ipv4Lit_ = do
a <- octet
void (char '.')
b <- octet
void (char '.')
c <- octet
void (char '.')
d <- octet
return $ LIP IPv4
( fromIntegral a `shiftL` 24
.|. fromIntegral b `shiftL` 16
.|. fromIntegral c `shiftL` 8
.|. fromIntegral d)
where
octet = do
n <- fromIntegral <$> natural
if n > 255 then fail "octet out of range" else return n
-- | IPv6: full notation, :: abbreviation, and optional embedded IPv4.
-- Stores as LIP IPv6 (128-bit Integer).
ipv6Lit :: Parser Literal
ipv6Lit = do
(left, hasDbl, right) <- ipv6Groups
let missing = 8 - length left - length right
when (missing < 0) $ fail "too many groups in IPv6 address"
when (not hasDbl && missing /= 0) $ fail "invalid IPv6 address (must have 8 groups or use ::)"
let groups = left ++ replicate missing 0 ++ right
when (length groups /= 8) $ fail "invalid IPv6 address"
let val = foldl' (\acc g -> (acc `shiftL` 16) .|. fromIntegral g) (0::Integer) groups
return (LIP IPv6 val)
-- Returns (left-of-::, has_dbl_colon, right-of-::).
-- If no :: present, left has all 8 groups and right is empty.
ipv6Groups :: Parser ([Int], Bool, [Int])
ipv6Groups = do
-- must start with a hex digit or ':' (for ::)
ahead <- lookAhead (hexDigit <|> char ':')
case ahead of
':' -> do
void (string "::")
right <- ipv6RightGroups
return ([], True, right)
_ -> do
left <- ipv6LeftGroups
mDbl <- optionMaybe (try (string "::"))
case mDbl of
Nothing -> return (left, False, [])
Just _ -> do
right <- ipv6RightGroups
return (left, True, right)
-- Parse a run of hex16:hex16:... stopping before :: or end
ipv6LeftGroups :: Parser [Int]
ipv6LeftGroups = do
first <- hex16
rest <- many (try (char ':' >> notFollowedBy (char ':') >> hex16))
return (first : rest)
-- Parse groups to the right of ::, including optional embedded IPv4
ipv6RightGroups :: Parser [Int]
ipv6RightGroups = option [] $
try ipv4EmbeddedGroups <|> ipv6LeftGroups
-- IPv4-mapped groups: e.g. ffff:192.168.1.1 -> [0xffff, 0xc0a8, 0x0101]
ipv4EmbeddedGroups :: Parser [Int]
ipv4EmbeddedGroups = do
prefix <- many (try (hex16 <* char ':' <* lookAhead digit))
a <- octet_; void (char '.')
b <- octet_; void (char '.')
c <- octet_; void (char '.')
d <- octet_
let hi = (a `shiftL` 8) .|. b
lo = (c `shiftL` 8) .|. d
return (prefix ++ [hi, lo])
where
octet_ = do
n <- fromIntegral <$> natural
if n > 255 then fail "IPv4 octet out of range" else return n
hex16 :: Parser Int
hex16 = do
digits <- many1 hexDigit
case (reads ("0x" ++ digits)) :: [(Int,String)] of
[(v,"")] -> if v > 0xffff then fail "hex16 out of range" else return v
_ -> fail "invalid hex group"
cidrLit :: Parser CIDR
cidrLit = do
l <- ipOrCidrLit
l <- cidrOrIpLit
case l of
LCIDR ip p -> return (ip, p)
_ -> fail "expected CIDR notation (address/prefix)"
_ -> fail "expected CIDR notation"

53
src/FWL/Pretty.hs
View File

@@ -31,22 +31,11 @@ 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 ++
" hook " ++ prettyHook (pmHook pm) ++
(if pmPriority pm /= prettyDefaultPriority (pmHook pm)
then " priority " ++ prettyNamedPriority (pmPriority pm)
else "") ++ "\n" ++
"policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++
" on { hook = " ++ prettyHook (pmHook pm) ++
", table = " ++ prettyTable (pmTable pm) ++
", priority = " ++ prettyPriority (pmPriority pm) ++ " }\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"
@@ -60,6 +49,8 @@ prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr
prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }"
prettyCidr :: CIDR -> String
prettyCidr (LIPv4 (a,b,c,d), p) =
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ "/" ++ show p
prettyCidr (ip, p) = prettyLit ip ++ "/" ++ show p
prettyHook :: Hook -> String
@@ -69,24 +60,16 @@ prettyHook HOutput = "Output"
prettyHook HPrerouting = "Prerouting"
prettyHook HPostrouting = "Postrouting"
-- | 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
prettyTable :: TableName -> String
prettyTable TFilter = "Filter"
prettyTable TNAT = "NAT"
-- | 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)
prettyPriority :: Priority -> String
prettyPriority PFilter = "Filter"
prettyPriority PDstNat = "DstNat"
prettyPriority PSrcNat = "SrcNat"
prettyPriority PMangle = "Mangle"
prettyPriority (PInt n)= show n
prettyType :: Type -> String
prettyType (TName n []) = n
@@ -105,7 +88,6 @@ 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
@@ -200,8 +182,9 @@ prettyLit (LInt n) = show n
prettyLit (LString s) = "\"" ++ s ++ "\""
prettyLit (LBool True) = "true"
prettyLit (LBool False) = "false"
prettyLit (LIP IPv4 n) = renderIPv4 n
prettyLit (LIP IPv6 n) = renderIPv6 n
prettyLit (LIPv4 (a,b,c,d)) =
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d
prettyLit (LIPv6 _) = "<ipv6>"
prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p
prettyLit (LPort p) = ":" ++ show p
prettyLit (LDuration n u) = show n ++ prettyUnit u

210
test/CheckTests.hs
View File

@@ -1,210 +0,0 @@
module CheckTests (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import FWL.Check
import FWL.Util
tests :: TestTree
tests = testGroup "Check"
[ undefinedNameTests
, duplicateTests
, policyTerminationTests
, patternCycleTests
, cleanProgramTests
]
-- ─── Helper ──────────────────────────────────────────────────────────────────
checkSrc :: String -> IO [CheckError]
checkSrc src = do
p <- parseOk src
return (checkProgram p)
assertNoErrors :: String -> IO ()
assertNoErrors src = do
errs <- checkSrc src
case errs of
[] -> return ()
_ -> assertFailure ("Unexpected errors: " ++ show errs)
assertHasError :: (CheckError -> Bool) -> String -> IO ()
assertHasError p src = do
errs <- checkSrc src
if any p errs
then return ()
else assertFailure ("Expected error not found. Got: " ++ show errs)
isUndefined :: String -> CheckError -> Bool
isUndefined n (UndefinedName _ m) = m == n
isUndefined _ _ = False
isDuplicate :: String -> CheckError -> Bool
isDuplicate n (DuplicateDecl _ m) = m == n
isDuplicate _ _ = False
isNoContinue :: String -> CheckError -> Bool
isNoContinue n (PolicyNoContinue m) = m == n
isNoContinue _ _ = False
isCycle :: CheckError -> Bool
isCycle (PatternCycle _) = True
isCycle _ = False
-- ─── Undefined name tests ────────────────────────────────────────────────────
undefinedNameTests :: TestTree
undefinedNameTests = testGroup "undefined names"
[ testCase "zone references unknown interface" $
assertHasError (isUndefined "ghost")
"zone bad_zone = { lan, ghost };"
, testCase "zone references known interface — no error" $
assertNoErrors
"interface lan : LAN {}; \
\zone good = { lan };"
, testCase "pattern references undefined named pattern" $
assertHasError (isUndefined "Undefined")
"pattern Bad : Frame = Frame(_, IPv4(ip, Undefined));"
, testCase "pattern references known named pattern — no error" $
assertNoErrors
"pattern WGInit : (UDPHeader,Bytes) = (udp { length = 156 }, [0x01 _*]); \
\pattern Compound : Frame = Frame(_, IPv4(ip, WGInit));"
, testCase "flow references undefined pattern" $
assertHasError (isUndefined "Ghost")
"flow Bad : FlowPattern = Ghost;"
, testCase "flow references known pattern — no error" $
assertNoErrors
"pattern P : T = udp { length = 1 }; \
\flow F : FlowPattern = P;"
, testCase "policy guard references undeclared zone" $
-- 'unknown_zone' not declared; check should flag it
assertHasError (isUndefined "unknown_zone")
"policy fwd : Frame hook Forward \
\ = { | Frame(iif in unknown_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
, testCase "policy references known zone — no error" $
assertNoErrors
"interface lan : LAN {}; \
\zone trusted = { lan }; \
\policy fwd : Frame hook Forward \
\ = { | Frame(iif in trusted -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
]
-- ─── Duplicate declaration tests ─────────────────────────────────────────────
duplicateTests :: TestTree
duplicateTests = testGroup "duplicates"
[ testCase "duplicate interface" $
assertHasError (isDuplicate "lan")
"interface lan : LAN {}; \
\interface lan : WAN {};"
, testCase "duplicate zone" $
assertHasError (isDuplicate "z")
"zone z = { a }; \
\zone z = { b };"
, testCase "duplicate pattern" $
assertHasError (isDuplicate "P")
"pattern P : T = udp { length = 1 }; \
\pattern P : T = udp { length = 2 };"
, testCase "duplicate policy" $
assertHasError (isDuplicate "input")
"policy input : Frame hook Input \
\ = { | _ -> Allow; }; \
\policy input : Frame hook Input \
\ = { | _ -> Drop; };"
, testCase "distinct names — no error" $
assertNoErrors
"interface lan : LAN {}; \
\interface wan : WAN { dynamic; }; \
\zone z = { lan };"
]
-- ─── Policy termination tests ────────────────────────────────────────────────
policyTerminationTests :: TestTree
policyTerminationTests = testGroup "policy termination"
[ testCase "last arm is Continue — error" $
assertHasError (isNoContinue "bad_policy")
"policy bad_policy : Frame hook Input = { | _ -> Continue; };"
, testCase "last arm is Drop — ok" $
assertNoErrors
"policy good : Frame hook Input \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
, testCase "last arm is Allow — ok" $
assertNoErrors
"policy output : Frame hook Output = { | _ -> Allow; };"
, testCase "Continue in non-last arm is fine" $
assertNoErrors
"rule r : Frame -> Action = \
\ \\f -> case f of { \
\ | Frame(_, IPv4(ip, _)) -> Continue; \
\ | _ -> Drop; \
\ };"
, testCase "empty policy body — error" $
assertHasError (isNoContinue "empty")
"policy empty : Frame hook Output = {};"
]
-- ─── Pattern cycle tests ─────────────────────────────────────────────────────
patternCycleTests :: TestTree
patternCycleTests = testGroup "pattern cycles"
[ testCase "direct self-reference — cycle error" $
assertHasError isCycle
"pattern Loop : T = Frame(_, Loop);"
, testCase "mutual cycle — cycle error" $
assertHasError isCycle
"pattern A : T = Frame(_, B); \
\pattern B : T = Frame(_, A);"
, testCase "linear chain — no cycle" $
assertNoErrors
"pattern Base : T = udp { length = 1 }; \
\pattern Mid : T = Frame(_, Base); \
\pattern Top : T = Frame(_, Mid);"
]
-- ─── Clean full programs ──────────────────────────────────────────────────────
cleanProgramTests :: TestTree
cleanProgramTests = testGroup "clean programs"
[ testCase "minimal router skeleton" $
assertNoErrors
"interface wan : WAN { dynamic; }; \
\interface lan : LAN { cidr4 = { 10.17.1.0/24 }; }; \
\interface wg0 : WireGuard {}; \
\zone lan_zone = { lan, wg0 }; \
\policy input : Frame hook Input \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ }; \
\policy output : Frame hook Output = { | _ -> Allow; };"
, testCase "pattern and flow declarations" $
assertNoErrors
"pattern WGInit : (UDPHeader,Bytes) = (udp { length = 156 }, [0x01 _*]); \
\pattern WGResp : (UDPHeader,Bytes) = (udp { length = 100 }, [0x02 _*]); \
\flow WGHandshake : FlowPattern = WGInit . WGResp within 5s;"
]

457
test/CompileTests.hs
View File

@@ -1,457 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module CompileTests (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as AK
import qualified Data.Aeson.KeyMap as AKM
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy.Char8 as BL8
import FWL.AST
import FWL.Compile
import FWL.Util
tests :: TestTree
tests = testGroup "Compile"
[ jsonStructureTests
, chainTests
, ruleExprTests
, verdictTests
, layerStrippingTests
, continueTests
, configTests
, filterInjectionTests
, portforwardCompileTests
, masqueradeCompileTests
]
-- ─── Helpers ─────────────────────────────────────────────────────────────────
compileToValue :: String -> IO A.Value
compileToValue src = do
p <- parseOk src
case A.decode (compileToJson p) of
Nothing -> assertFailure "Compiled output is not valid JSON" >> undefined
Just v -> return v
-- Navigate a Value by a list of string keys / numeric indices.
at :: [String] -> A.Value -> Maybe A.Value
at [] v = Just v
at (k:ks) (A.Object o) =
case AKM.lookup (AK.fromString k) o of
Nothing -> Nothing
Just v -> at ks v
at (k:ks) (A.Array arr) =
case reads k of
[(i,"")] | i < V.length arr -> at ks (arr V.! i)
_ -> Nothing
at _ _ = Nothing
nftArr :: A.Value -> IO [A.Value]
nftArr v =
case at ["nftables"] v of
Just (A.Array arr) -> return (V.toList arr)
_ -> assertFailure "Missing top-level 'nftables' array" >> undefined
withKey :: String -> [A.Value] -> [A.Value]
withKey k = filter (\v -> case at [k] v of Just _ -> True; _ -> False)
-- ─── JSON structure tests ────────────────────────────────────────────────────
jsonStructureTests :: TestTree
jsonStructureTests = testGroup "JSON structure"
[ testCase "output is valid JSON" $ do
_ <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
return ()
, testCase "top-level nftables array present" $ do
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
_ <- nftArr v
return ()
, testCase "metainfo is first element" $ do
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case arr of
(first:_) -> case at ["metainfo"] first of
Just _ -> return ()
Nothing -> assertFailure "First element is not metainfo"
[] -> assertFailure "Empty nftables array"
, testCase "table object present" $ do
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 hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "fwl")
[] -> assertFailure "No table object"
, testCase "custom table name respected" $ do
v <- compileToValue
"config { table = \"custom\"; } \
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "custom")
[] -> assertFailure "No table object"
]
-- ─── Chain declaration tests ─────────────────────────────────────────────────
chainTests :: TestTree
chainTests = testGroup "chain declarations"
[ testCase "filter input chain has correct hook" $ do
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 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 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 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 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 hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","name"] c @?= Just (A.String "my_input")
[] -> assertFailure "No chain"
, testCase "two policies produce two chains" $ do
v <- compileToValue
"policy input : Frame hook Input = { | _ -> Drop; }; \
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "chain" arr) @?= 2
]
-- ─── Rule expression tests ───────────────────────────────────────────────────
ruleExprs :: [A.Value] -> [A.Value]
ruleExprs arr =
[ e | r <- withKey "rule" arr
, Just (A.Array es) <- [at ["rule","expr"] r]
, e <- V.toList es ]
ruleExprTests :: TestTree
ruleExprTests = testGroup "rule expressions"
[ testCase "arm without guard produces rule" $ do
v <- compileToValue
"policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Should have at least one rule" (not (null (withKey "rule" arr)))
, testCase "rule expr array is present" $ do
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "rule" arr of
(r:_) -> case at ["rule","expr"] r of
Just (A.Array _) -> return ()
_ -> assertFailure "Missing or non-array 'expr'"
[] -> assertFailure "No rule"
, testCase "IPv4 ctor emits nfproto match" $ do
v <- compileToValue
"policy input : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
hasNfp = any (\m ->
at ["match","left","meta","key"] m == Just (A.String "nfproto"))
matches
assertBool "Expected nfproto match for IPv4 ctor" hasNfp
, testCase "record field pat emits payload match" $ do
v <- compileToValue
"policy input : Frame hook Input = \
\ { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
hasPort = any (\m ->
at ["match","right"] m == Just (A.String "22"))
matches
assertBool "Expected port 22 payload match" hasPort
]
-- ─── Verdict tests ───────────────────────────────────────────────────────────
allExprs :: [A.Value] -> [A.Value]
allExprs arr =
concatMap (\r -> case at ["rule","expr"] r of
Just (A.Array es) -> V.toList es; _ -> [])
(withKey "rule" arr)
verdictTests :: TestTree
verdictTests = testGroup "verdicts"
[ testCase "Allow compiles to accept" $ do
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 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 hook Postrouting = { | _ -> Masquerade; };"
arr <- nftArr v
assertBool "Expected masquerade verdict"
(not (null (withKey "masquerade" (allExprs arr))))
, testCase "rule call compiles to jump" $ do
v <- compileToValue
"rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \
\policy fwd : Frame hook Forward = { | frame -> blockAll(frame); };"
arr <- nftArr v
assertBool "Expected jump verdict for rule call"
(not (null (withKey "jump" (allExprs arr))))
]
-- ─── Layer stripping tests ───────────────────────────────────────────────────
layerStrippingTests :: TestTree
layerStrippingTests = testGroup "layer stripping"
[ testCase "Frame with and without Ether both emit nfproto match" $ do
let withEther =
"policy p1 : Frame hook Input = \
\ { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
\ };"
withoutEther =
"policy p1 : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
v1 <- compileToValue withEther
v2 <- compileToValue withoutEther
arr1 <- nftArr v1
arr2 <- nftArr v2
let nfp arr = filter
(\m -> at ["match","left","meta","key"] m == Just (A.String "nfproto"))
(withKey "match" (ruleExprs arr))
assertBool "Both should produce nfproto matches"
(not (null (nfp arr1)) && not (null (nfp arr2)))
]
-- ─── Continue tests ───────────────────────────────────────────────────────────
continueTests :: TestTree
continueTests = testGroup "Continue"
[ testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy input : Frame hook Input = \
\ { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
assertBool "Should have rules for non-Continue arms"
(not (null (withKey "rule" arr)))
]
-- ─── Config tests ─────────────────────────────────────────────────────────────
configTests :: TestTree
configTests = testGroup "config"
[ testCase "all rule objects reference correct table" $ do
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 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
]

44
test/FWL/Util.hs
View File

@@ -1,44 +0,0 @@
-- | Shared test utilities.
module FWL.Util where
import Test.Tasty.HUnit
import Text.Parsec.String (Parser)
import Text.Parsec (parse)
import FWL.Parser (parseProgram)
import FWL.AST
-- | Assert a parser succeeds and return the result.
shouldParse :: (Show a) => Parser a -> String -> IO a
shouldParse p input =
case parse p "<test>" input of
Left err -> assertFailure ("Unexpected parse error:\n" ++ show err)
>> undefined
Right v -> return v
-- | Assert a parser fails.
shouldFailParse :: (Show a) => Parser a -> String -> IO ()
shouldFailParse p input =
case parse p "<test>" input of
Left _ -> return ()
Right v -> assertFailure ("Expected parse failure but got: " ++ show v)
-- | Parse a full program, asserting success.
parseOk :: String -> IO Program
parseOk src =
case parseProgram "<test>" src of
Left err -> assertFailure ("Parse error:\n" ++ show err) >> undefined
Right p -> return p
-- | Parse a full program, asserting failure.
parseFail :: String -> IO ()
parseFail src =
case parseProgram "<test>" src of
Left _ -> return ()
Right p -> assertFailure ("Expected parse failure, got:\n" ++ show p)
-- | Extract the single declaration from a one-decl program.
singleDecl :: Program -> IO Decl
singleDecl (Program _ [d]) = return d
singleDecl (Program _ ds) =
assertFailure ("Expected 1 decl, got " ++ show (length ds)) >> undefined

550
test/ParserTests.hs
View File

@@ -1,550 +0,0 @@
module ParserTests (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import FWL.AST
import FWL.Util
tests :: TestTree
tests = testGroup "Parser"
[ interfaceTests
, zoneTests
, importTests
, letTests
, patternTests
, flowTests
, typeTests
, exprTests
, policyTests
, portforwardTests
, masqueradeTests
, ruleTests
, configTests
, errorTests
]
-- ─── Interface ───────────────────────────────────────────────────────────────
interfaceTests :: TestTree
interfaceTests = testGroup "interface"
[ testCase "WAN dynamic" $ do
p <- parseOk "interface wan : WAN { dynamic; };"
d <- singleDecl p
case d of
DInterface "wan" IWan [IPDynamic] -> return ()
_ -> assertFailure (show d)
, testCase "LAN with cidr4" $ do
p <- parseOk "interface lan : LAN { cidr4 = { 10.0.0.0/8 }; };"
d <- singleDecl p
case d of
DInterface "lan" ILan [IPCidr4 [(ip, 8)]] | ip == ipv4Lit 10 0 0 0 -> return ()
_ -> assertFailure (show d)
, testCase "LAN with cidr4 and cidr6" $ do
p <- parseOk
"interface lan : LAN { \
\ cidr4 = { 10.17.1.0/24 }; \
\ cidr6 = { 192.168.0.0/16 }; \
\};"
d <- singleDecl p
case d of
DInterface "lan" ILan [IPCidr4 _, IPCidr6 _] -> return ()
_ -> assertFailure (show d)
, testCase "WireGuard interface" $ do
p <- parseOk "interface wg0 : WireGuard {};"
d <- singleDecl p
case d of
DInterface "wg0" IWireGuard [] -> return ()
_ -> assertFailure (show d)
, testCase "user-defined kind" $ do
p <- parseOk "interface eth0 : Bridge {};"
d <- singleDecl p
case d of
DInterface "eth0" (IUser "Bridge") [] -> return ()
_ -> assertFailure (show d)
, testCase "multiple CIDRs in set" $ do
p <- parseOk
"interface lan : LAN { \
\ cidr4 = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 }; \
\};"
d <- singleDecl p
case d of
DInterface _ _ [IPCidr4 cidrs] -> length cidrs @?= 3
_ -> assertFailure (show d)
]
-- ─── Zone ────────────────────────────────────────────────────────────────────
zoneTests :: TestTree
zoneTests = testGroup "zone"
[ testCase "single member" $ do
p <- parseOk "zone trusted = { lan };"
d <- singleDecl p
case d of
DZone "trusted" ["lan"] -> return ()
_ -> assertFailure (show d)
, testCase "multiple members" $ do
p <- parseOk "zone lan_zone = { lan, wg0, vlan10 };"
d <- singleDecl p
case d of
DZone "lan_zone" ["lan","wg0","vlan10"] -> return ()
_ -> assertFailure (show d)
]
-- ─── Import ──────────────────────────────────────────────────────────────────
importTests :: TestTree
importTests = testGroup "import"
[ testCase "basic import" $ do
p <- parseOk "import rfc1918 : CIDRSet from \"builtin:rfc1918\";"
d <- singleDecl p
case d of
DImport "rfc1918" (TName "CIDRSet" []) "builtin:rfc1918" -> return ()
_ -> assertFailure (show d)
]
-- ─── Let ─────────────────────────────────────────────────────────────────────
letTests :: TestTree
letTests = testGroup "let"
[ testCase "simple integer" $ do
p <- parseOk "let timeout : Int = 30;"
d <- singleDecl p
case d of
DLet "timeout" (TName "Int" []) (ELit (LInt 30)) -> return ()
_ -> assertFailure (show d)
, testCase "map literal" $ do
p <- parseOk
"let forwards : Map<(Protocol,Port),(IP,Port)> = { \
\ (tcp, :8080) -> (10.0.0.1, :80) \
\};"
d <- singleDecl p
case d of
DLet "forwards" _ (EMap [_]) -> return ()
_ -> assertFailure (show d)
, testCase "string literal" $ do
p <- parseOk "let name : String = \"hello\";"
d <- singleDecl p
case d of
DLet "name" _ (ELit (LString "hello")) -> return ()
_ -> assertFailure (show d)
]
-- ─── Pattern ─────────────────────────────────────────────────────────────────
patternTests :: TestTree
patternTests = testGroup "pattern"
[ testCase "tuple with record field" $ do
p <- parseOk
"pattern WGInitiation : (UDPHeader, Bytes) = \
\ (udp { length = 156 }, [0x01 _*]);"
d <- singleDecl p
case d of
DPattern "WGInitiation" _ (PTuple [PRecord "udp" _, PBytes _]) -> return ()
_ -> assertFailure (show d)
, testCase "byte pattern elements" $ do
p <- parseOk
"pattern WGResponse : (UDPHeader, Bytes) = \
\ (udp { length = 100 }, [0x02 _ _*]);"
d <- singleDecl p
case d of
DPattern "WGResponse" _ (PTuple [_, PBytes [BEHex 0x02, BEWild, BEWildStar]]) ->
return ()
_ -> assertFailure (show d)
, testCase "named pattern reference in ctor" $ do
p <- parseOk
"pattern Complex : Frame = \
\ Frame(_, IPv4(ip, WGInitiation));"
d <- singleDecl p
case d of
DPattern "Complex" _ (PFrame (Just _) (PCtor "IPv4" [PVar "ip", PNamed "WGInitiation"])) ->
return ()
_ -> assertFailure (show d)
, testCase "record with field bind" $ do
p <- parseOk "pattern HasTCP : TCP = tcp { dport };"
d <- singleDecl p
case d of
DPattern "HasTCP" _ (PRecord "tcp" [FPBind "dport"]) -> return ()
_ -> assertFailure (show d)
, testCase "record with field equality" $ do
p <- parseOk "pattern SSH : TCP = tcp { dport = :22 };"
d <- singleDecl p
case d of
DPattern "SSH" _ (PRecord "tcp" [FPEq "dport" (LPort 22)]) -> return ()
_ -> assertFailure (show d)
]
-- ─── Flow ────────────────────────────────────────────────────────────────────
flowTests :: TestTree
flowTests = testGroup "flow"
[ testCase "two-step sequence with within" $ do
p <- parseOk
"flow WireGuardHandshake : FlowPattern = \
\ WGInitiation . WGResponse within 5s;"
d <- singleDecl p
case d of
DFlow "WireGuardHandshake" (FSeq (FAtom "WGInitiation") (FAtom "WGResponse") (Just (5, Seconds))) ->
return ()
_ -> assertFailure (show d)
, testCase "single atom flow" $ do
p <- parseOk "flow Simple : FlowPattern = Ping;"
d <- singleDecl p
case d of
DFlow "Simple" (FAtom "Ping") -> return ()
_ -> assertFailure (show d)
, testCase "duration in milliseconds" $ do
p <- parseOk "flow Fast : FlowPattern = A . B within 500ms;"
d <- singleDecl p
case d of
DFlow "Fast" (FSeq _ _ (Just (500, Millis))) -> return ()
_ -> assertFailure (show d)
]
-- ─── Types ───────────────────────────────────────────────────────────────────
typeTests :: TestTree
typeTests = testGroup "types"
[ testCase "simple name" $ do
p <- parseOk "let x : Frame = Allow;"
d <- singleDecl p
case d of
DLet _ (TName "Frame" []) _ -> return ()
_ -> assertFailure (show d)
, testCase "generic type" $ do
p <- parseOk "let x : Map<Int, String> = Allow;"
d <- singleDecl p
case d of
DLet _ (TName "Map" [TName "Int" [], TName "String" []]) _ -> return ()
_ -> assertFailure (show d)
, testCase "function type" $ do
p <- parseOk "let x : Frame -> Action = Allow;"
d <- singleDecl p
case d of
DLet _ (TFun (TName "Frame" []) (TName "Action" [])) _ -> return ()
_ -> assertFailure (show d)
, testCase "effect type" $ do
p <- parseOk "let x : <Log, FlowMatch> Action = Allow;"
d <- singleDecl p
case d of
DLet _ (TEffect ["Log","FlowMatch"] (TName "Action" [])) _ -> return ()
_ -> assertFailure (show d)
, testCase "tuple type" $ do
p <- parseOk "let x : (Int, String) = Allow;"
d <- singleDecl p
case d of
DLet _ (TTuple [TName "Int" [], TName "String" []]) _ -> return ()
_ -> assertFailure (show d)
, testCase "function with effects" $ do
p <- parseOk "let x : Frame -> <Log> Action = Allow;"
d <- singleDecl p
case d of
DLet _ (TFun _ (TEffect ["Log"] _)) _ -> return ()
_ -> assertFailure (show d)
]
-- ─── Expressions ─────────────────────────────────────────────────────────────
exprTests :: TestTree
exprTests = testGroup "expressions"
[ testCase "boolean and" $ do
p <- parseOk "let x : Bool = a && b;"
d <- singleDecl p
case d of
DLet _ _ (EInfix OpAnd (EVar "a") (EVar "b")) -> return ()
_ -> assertFailure (show d)
, testCase "set membership with 'in'" $ do
p <- parseOk "let x : Bool = ct.state in { Established, Related };"
d <- singleDecl p
case d of
DLet _ _ (EInfix OpIn (EQual ["ct","state"]) (ESet _)) -> return ()
_ -> assertFailure (show d)
, testCase "equality comparison" $ do
p <- parseOk "let x : Bool = tcp.dport == :22;"
d <- singleDecl p
case d of
DLet _ _ (EInfix OpEq (EQual ["tcp","dport"]) (ELit (LPort 22))) -> return ()
_ -> assertFailure (show d)
, testCase "if-then-else" $ do
p <- parseOk "let x : Action = if a then Allow else Drop;"
d <- singleDecl p
case d of
DLet _ _ (EIf (EVar "a") (EVar "Allow") (EVar "Drop")) -> return ()
_ -> assertFailure (show d)
, testCase "perform expression" $ do
p <- parseOk "let x : Action = perform Log.emit(Info, \"msg\");"
d <- singleDecl p
case d of
DLet _ _ (EPerform ["Log","emit"] [ELit (LString "Info"), ELit (LString "msg")]) -> return ()
DLet _ _ (EPerform ["Log","emit"] _) -> return () -- arg parsing flexible
_ -> assertFailure (show d)
, testCase "do block" $ do
p <- parseOk "let x : Action = do { y <- foo; y };"
d <- singleDecl p
case d of
DLet _ _ (EDo [DSBind "y" _, DSExpr (EVar "y")]) -> return ()
_ -> assertFailure (show d)
, testCase "nested case" $ do
p <- parseOk
"let x : Action = case e of { \
\ | a -> Allow; \
\ | _ -> Drop; \
\};"
d <- singleDecl p
case d of
DLet _ _ (ECase (EVar "e") [Arm (PVar "a") Nothing _, Arm PWild Nothing _]) -> return ()
_ -> assertFailure (show d)
, testCase "lambda" $ do
p <- parseOk "let x : Frame -> Action = \\frame -> Allow;"
d <- singleDecl p
case d of
DLet _ _ (ELam "frame" (EVar "Allow")) -> return ()
_ -> assertFailure (show d)
, testCase "string concat" $ do
p <- parseOk "let x : String = \"hello\" ++ \" world\";"
d <- singleDecl p
case d of
DLet _ _ (EInfix OpConcat _ _) -> return ()
_ -> assertFailure (show d)
, testCase "negation" $ do
p <- parseOk "let x : Bool = !flag;"
d <- singleDecl p
case d of
DLet _ _ (ENot (EVar "flag")) -> return ()
_ -> assertFailure (show d)
, testCase "set literal" $ do
p <- parseOk "let x : Set<Int> = { 22, 80, 443 };"
d <- singleDecl p
case d of
DLet _ _ (ESet [ELit (LInt 22), ELit (LInt 80), ELit (LInt 443)]) -> return ()
_ -> assertFailure (show d)
]
-- ─── Policy ──────────────────────────────────────────────────────────────────
policyTests :: TestTree
policyTests = testGroup "policy"
[ testCase "compact hook Input syntax" $ do
p <- parseOk "policy input : Frame hook Input = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy "input" _ (PolicyMeta HInput TFilter (Priority 0)) [_] -> return ()
_ -> assertFailure (show d)
, testCase "hook Prerouting priority Mangle" $ do
p <- parseOk
"policy pre : Frame hook Prerouting priority Mangle = { | _ -> Drop; };"
d <- singleDecl p
case d of
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 hook Input = { \
\ | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
d <- singleDecl p
case d of
DPolicy _ _ _ [Arm PWild (Just _) _, Arm PWild Nothing _] -> return ()
_ -> assertFailure (show d)
, testCase "Frame pattern with path" $ do
p <- parseOk
"policy forward : Frame hook Forward = { \
\ | Frame(iif in lan_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
d <- singleDecl p
case d of
DPolicy _ _ _ (Arm (PFrame (Just _) _) Nothing _ : _) -> return ()
_ -> assertFailure (show d)
, testCase "Frame pattern without Ether (layer stripping)" $ do
p <- parseOk
"policy input : Frame hook Input = { \
\ | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \
\ | _ -> Drop; \
\ };"
d <- singleDecl p
case d of
DPolicy _ _ _ (Arm (PFrame (Just _) (PCtor "IPv4" _)) _ _ : _) -> return ()
_ -> assertFailure (show d)
, testCase "policy arm calls rule" $ do
p <- parseOk
"policy forward : Frame hook Forward = { \
\ | frame -> blockOutboundWG(frame); \
\ };"
d <- singleDecl p
case d of
DPolicy _ _ _ [Arm (PVar "frame") Nothing (EApp (EVar "blockOutboundWG") _)] ->
return ()
_ -> assertFailure (show d)
, testCase "Continue arm is parsed" $ do
p <- parseOk
"rule r : Frame -> Action = \
\ \\frame -> case frame of { \
\ | _ -> Continue; \
\ };"
d <- singleDecl p
case d of
DRule _ _ _ -> return ()
_ -> 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
ruleTests = testGroup "rule"
[ testCase "simple rule" $ do
p <- parseOk
"rule blockAll : Frame -> Action = \
\ \\frame -> case frame of { | _ -> Drop; };"
d <- singleDecl p
case d of
DRule "blockAll" _ (ELam "frame" (ECase _ _)) -> return ()
_ -> assertFailure (show d)
, testCase "rule with effects in type" $ do
p <- parseOk
"rule logged : Frame -> <Log> Action = \
\ \\f -> case f of { | _ -> Allow; };"
d <- singleDecl p
case d of
DRule "logged" (TFun _ (TEffect ["Log"] _)) _ -> return ()
_ -> assertFailure (show d)
, testCase "nested case in rule" $ do
p <- parseOk
"rule check : Frame -> <FlowMatch> Action = \
\ \\frame -> \
\ case frame of { \
\ | Frame(_, IPv4(ip, UDP(udp, _))) -> \
\ case perform FlowMatch.check(ip, wg) of { \
\ | Matched -> Drop; \
\ | _ -> Continue; \
\ }; \
\ | _ -> Continue; \
\ };"
d <- singleDecl p
case d of
DRule "check" _ (ELam _ (ECase _ _)) -> return ()
_ -> assertFailure (show d)
]
-- ─── Config ──────────────────────────────────────────────────────────────────
configTests :: TestTree
configTests = testGroup "config"
[ testCase "default table name" $ do
p <- parseOk "interface wan : WAN {};"
configTable (progConfig p) @?= "fwl"
, testCase "custom table name" $ do
p <- parseOk "config { table = \"myrules\"; } interface wan : WAN {};"
configTable (progConfig p) @?= "myrules"
]
-- ─── Error cases ─────────────────────────────────────────────────────────────
errorTests :: TestTree
errorTests = testGroup "parse errors"
[ testCase "missing semicolon" $
parseFail "interface wan : WAN {}"
, testCase "old on-brace policy syntax is a parse error" $
parseFail
"policy p : Frame \
\ 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 hook Output = {};"
d <- singleDecl p
case d of
DPolicy _ _ _ [] -> return ()
_ -> assertFailure (show d)
, testCase "CIDR without prefix fails" $
parseFail "interface lan : LAN { cidr4 = { 10.0.0.1 }; };"
]

15
test/Spec.hs
View File

@@ -1,15 +0,0 @@
module Main where
import Test.Tasty
import Test.Tasty.HUnit
import qualified ParserTests
import qualified CheckTests
import qualified CompileTests
main :: IO ()
main = defaultMain $ testGroup "FWL"
[ ParserTests.tests
, CheckTests.tests
, CompileTests.tests
]