Compare commits
16 Commits
134cb06900
...
v2-1
| Author | SHA1 | Date | |
|---|---|---|---|
| 8b5191c8bf | |||
| e584d9ac2d | |||
|
6d96e2d159
|
|||
| 55c1d347e6 | |||
|
9390647f7a
|
|||
|
25f95996fb
|
|||
|
d79206440a
|
|||
|
d136bd62f7
|
|||
|
8a508ad7cc
|
|||
|
d01be7bc23
|
|||
|
2705f18e0f
|
|||
|
a0632d5263
|
|||
|
2a44095791
|
|||
|
30427521ca
|
|||
|
23ce29aece
|
|||
|
778cf13c40
|
225
AGENTS.md
Normal file
225
AGENTS.md
Normal file
@@ -0,0 +1,225 @@
|
||||
# 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
13
app/Main.hs
@@ -3,11 +3,12 @@ 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, compileProgram)
|
||||
import FWL.Compile (compileToJson)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@@ -32,9 +33,7 @@ runCheck fp = do
|
||||
let errs = checkProgram prog
|
||||
if null errs
|
||||
then putStrLn "OK" >> exitSuccess
|
||||
else do
|
||||
mapM_ (hPutStrLn stderr . show) errs
|
||||
exitFailure
|
||||
else mapM_ (hPutStrLn stderr . show) errs >> exitFailure
|
||||
|
||||
runCompile :: FilePath -> IO ()
|
||||
runCompile fp = do
|
||||
@@ -44,10 +43,8 @@ runCompile fp = do
|
||||
Right prog -> do
|
||||
let errs = checkProgram prog
|
||||
if null errs
|
||||
then putStrLn (compileToJson prog)
|
||||
else do
|
||||
mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs
|
||||
exitFailure
|
||||
then BL.putStrLn (compileToJson prog)
|
||||
else mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs >> exitFailure
|
||||
|
||||
runPretty :: FilePath -> IO ()
|
||||
runPretty fp = do
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
1
doc/ref/ruleset-1.json
Normal file
1
doc/ref/ruleset-1.json
Normal file
File diff suppressed because one or more lines are too long
163
doc/ref/ruleset-1.nft
Normal file
163
doc/ref/ruleset-1.nft
Normal file
@@ -0,0 +1,163 @@
|
||||
#!/usr/sbin/nft -f
|
||||
# Compiled from examples/router.fwl
|
||||
# Single inet table: fwl
|
||||
|
||||
flush ruleset
|
||||
|
||||
table inet fwl {
|
||||
|
||||
# ── Data: let rfc1918 ────────────────────────────────────────────────────
|
||||
set rfc1918 {
|
||||
type ipv4_addr
|
||||
flags interval
|
||||
elements = {
|
||||
10.0.0.0/8,
|
||||
172.16.0.0/12,
|
||||
192.168.0.0/16
|
||||
}
|
||||
}
|
||||
|
||||
# ── Data: let forwards ──────────────────────────────────────────────────
|
||||
map forwards {
|
||||
type inet_proto . inet_service : ipv4_addr . inet_service
|
||||
elements = {
|
||||
tcp . 8080 : 10.17.1.10 . 80,
|
||||
tcp . 2222 : 10.17.1.11 . 22
|
||||
}
|
||||
}
|
||||
|
||||
# ── WireGuard ct mark state machine ─────────────────────────────────────
|
||||
# Compiles: flow WireGuardHandshake = WGInitiation . WGResponse within 5s
|
||||
# State: ct mark 0 = Idle, 1 = SawInitiation, 2 = Confirmed
|
||||
#
|
||||
# WGInitiation: UDP, udp length == 156 (8 hdr + 148 payload), payload[0] == 0x01
|
||||
# WGResponse: UDP, udp length == 100 (8 hdr + 92 payload), payload[0] == 0x02
|
||||
# @th,64,8 = first byte of UDP payload (offset 64 bits past transport header start)
|
||||
|
||||
chain wg_flow {
|
||||
# Packet 1: Idle → SawInitiation
|
||||
ct state new ct mark 0 \
|
||||
meta l4proto udp udp length 156 \
|
||||
@th,64,8 0x01 \
|
||||
ct mark set 1 \
|
||||
return
|
||||
|
||||
# Packet 2: SawInitiation → Confirmed
|
||||
ct mark 1 \
|
||||
meta l4proto udp udp length 100 \
|
||||
@th,64,8 0x02 \
|
||||
ct mark set 2 \
|
||||
return
|
||||
}
|
||||
|
||||
# ── rule blockOutboundWG ─────────────────────────────────────────────────
|
||||
# Compiles: rule blockOutboundWG : Frame -> <FlowMatch, Log> Action
|
||||
# Called via jump from forward. Drops confirmed WG handshakes, returns otherwise.
|
||||
|
||||
chain blockOutboundWG {
|
||||
# Feed matching UDP into the WG state machine
|
||||
meta nfproto ipv4 meta l4proto udp \
|
||||
udp length 156 \
|
||||
@th,64,8 0x01 \
|
||||
jump wg_flow
|
||||
|
||||
# If handshake is now Confirmed (ct mark 2): log + drop
|
||||
ct mark 2 \
|
||||
log prefix "WG blocked: " level warn \
|
||||
drop
|
||||
|
||||
# Continue: return to forward chain (no verdict)
|
||||
return
|
||||
}
|
||||
|
||||
# ── policy input ─────────────────────────────────────────────────────────
|
||||
# hook = Input, table = Filter, priority = filter (0), default = drop
|
||||
|
||||
chain input {
|
||||
type filter hook input priority filter; policy drop;
|
||||
|
||||
# | _ if ct.state in { Established, Related } -> Allow
|
||||
ct state { established, related } accept
|
||||
|
||||
# | Frame(lo, _) -> Allow
|
||||
iifname "lo" accept
|
||||
|
||||
# | Frame(_, IPv6(ip6, ICMPv6(_, _))) if ip6.src in fe80::/10 -> Allow
|
||||
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
|
||||
|
||||
# | Frame(_, IPv4(_, TCP(tcp, _))) if tcp.dport == :22 -> Allow
|
||||
meta nfproto ipv4 meta l4proto tcp tcp dport 22 accept
|
||||
|
||||
# | Frame(_, IPv4(_, UDP(udp, _))) if udp.dport == :51944 -> Allow
|
||||
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
|
||||
|
||||
# | _ -> Drop (chain policy)
|
||||
}
|
||||
|
||||
# ── policy forward ───────────────────────────────────────────────────────
|
||||
# hook = Forward, table = Filter, priority = filter (0), default = drop
|
||||
|
||||
chain forward {
|
||||
type filter hook forward priority filter; policy drop;
|
||||
|
||||
# | _ if ct.state in { Established, Related } -> Allow
|
||||
ct state { established, related } accept
|
||||
|
||||
# | frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame)
|
||||
meta iifname { "lan", "wg0" } meta oifname "wan" jump blockOutboundWG
|
||||
|
||||
# | _ if ct.status == DNAT -> Allow
|
||||
ct status dnat accept
|
||||
|
||||
# | Frame(iif in lan_zone -> wan, _) -> Allow
|
||||
meta iifname { "lan", "wg0" } meta oifname "wan" accept
|
||||
|
||||
# | Frame(iif in lan_zone -> lan_zone, _) -> Allow
|
||||
meta iifname { "lan", "wg0" } meta oifname { "lan", "wg0" } accept
|
||||
|
||||
# | Frame(wan -> lan_zone, IPv4(ip, TCP|UDP)) if (proto, dport) in forwards -> Allow
|
||||
# Membership test only — the actual DNAT is done in nat_prerouting.
|
||||
meta iifname "wan" meta oifname { "lan", "wg0" } \
|
||||
meta nfproto ipv4 \
|
||||
meta l4proto { tcp, udp } \
|
||||
meta l4proto . th dport @forwards \
|
||||
accept
|
||||
|
||||
# | _ -> Drop (chain policy)
|
||||
}
|
||||
|
||||
# ── policy output ────────────────────────────────────────────────────────
|
||||
# hook = Output, table = Filter, priority = filter (0), default = accept
|
||||
|
||||
chain output {
|
||||
type filter hook output priority filter; policy accept;
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
|
||||
# ── policy nat_prerouting ────────────────────────────────────────────────
|
||||
# hook = Prerouting, table = NAT, priority = dstnat (-100), default = accept
|
||||
|
||||
chain nat_prerouting {
|
||||
type nat hook prerouting priority dstnat; policy accept;
|
||||
|
||||
# | Frame(_, IPv4(ip, TCP|UDP)) ->
|
||||
# if FIB.daddrLocal(ip.dst) then DNATMap((proto, dport), forwards) else Allow
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
fib daddr type local \
|
||||
dnat ip to meta l4proto . th dport map @forwards
|
||||
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
|
||||
# ── policy nat_postrouting ───────────────────────────────────────────────
|
||||
# hook = Postrouting, table = NAT, priority = srcnat (100), default = accept
|
||||
|
||||
chain nat_postrouting {
|
||||
type nat hook postrouting priority srcnat; policy accept;
|
||||
|
||||
# | Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade
|
||||
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
|
||||
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
}
|
||||
68
examples/router.fwl
Normal file
68
examples/router.fwl
Normal file
@@ -0,0 +1,68 @@
|
||||
-- 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
Normal file
37
examples/simple-router.fwl
Normal file
@@ -0,0 +1,37 @@
|
||||
interface wan : WAN { dynamic; };
|
||||
interface lan : LAN { cidr4 = { 10.0.0.0/24 }; };
|
||||
|
||||
zone lan_zone = { lan };
|
||||
|
||||
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
|
||||
|
||||
let open_ports : Set<Port> = { :22 };
|
||||
|
||||
let forwards_v6 : Set<(Protocol, IPv6, Port)> = {
|
||||
(tcp, 2001:db8::1, :22000)
|
||||
};
|
||||
|
||||
portforward wan_forwards
|
||||
on wan
|
||||
via Map<(Protocol, Port), (IPv4, Port)> = {
|
||||
(tcp, :8080) -> (10.0.0.10, :80)
|
||||
};
|
||||
|
||||
masquerade wan_snat
|
||||
on wan
|
||||
src rfc1918;
|
||||
|
||||
policy input : Frame hook Input = {
|
||||
| Frame(_, IPv4(_, TCP(tcp, _)))
|
||||
if tcp.dport in open_ports -> Allow;
|
||||
| Frame(_, IPv4(_, UDP(udp, _)))
|
||||
if udp.dport == :51944 -> Allow;
|
||||
| _ -> Drop;
|
||||
};
|
||||
|
||||
policy forward : Frame hook Forward = {
|
||||
| Frame(iif in lan_zone -> wan, _) -> Allow;
|
||||
| Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _)))
|
||||
if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow;
|
||||
| _ -> Drop;
|
||||
};
|
||||
734
examples/simple-router.fwl.json
Normal file
734
examples/simple-router.fwl.json
Normal file
@@ -0,0 +1,734 @@
|
||||
{
|
||||
"nftables": [
|
||||
{
|
||||
"metainfo": {
|
||||
"json_schema_version": 1
|
||||
}
|
||||
},
|
||||
{
|
||||
"table": {
|
||||
"family": "inet",
|
||||
"name": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"hook": "input",
|
||||
"name": "input",
|
||||
"policy": "drop",
|
||||
"prio": 0,
|
||||
"table": "fwl",
|
||||
"type": "filter"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"hook": "forward",
|
||||
"name": "forward",
|
||||
"policy": "drop",
|
||||
"prio": 0,
|
||||
"table": "fwl",
|
||||
"type": "filter"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"hook": "prerouting",
|
||||
"name": "wan_forwards_prerouting",
|
||||
"policy": "accept",
|
||||
"prio": -100,
|
||||
"table": "fwl",
|
||||
"type": "nat"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"hook": "postrouting",
|
||||
"name": "wan_snat_postrouting",
|
||||
"policy": "accept",
|
||||
"prio": 100,
|
||||
"table": "fwl",
|
||||
"type": "nat"
|
||||
}
|
||||
},
|
||||
{
|
||||
"map": {
|
||||
"elem": [
|
||||
[
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
8080
|
||||
]
|
||||
},
|
||||
{
|
||||
"concat": [
|
||||
"10.0.0.10",
|
||||
80
|
||||
]
|
||||
}
|
||||
]
|
||||
],
|
||||
"family": "inet",
|
||||
"map": [
|
||||
"ipv4_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"name": "wan_forwards",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"inet_service"
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"elem": [
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "10.0.0.0",
|
||||
"len": 8
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "172.16.0.0",
|
||||
"len": 12
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "192.168.0.0",
|
||||
"len": 16
|
||||
}
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"flags": [
|
||||
"interval"
|
||||
],
|
||||
"name": "rfc1918",
|
||||
"table": "fwl",
|
||||
"type": "ipv4_addr"
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"elem": [
|
||||
22
|
||||
],
|
||||
"family": "inet",
|
||||
"name": "open_ports",
|
||||
"table": "fwl",
|
||||
"type": "inet_service"
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"elem": [
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
"2001:db8:0:0:0:0:0:1",
|
||||
22000
|
||||
]
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"name": "forwards_v6",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"ipv6_addr",
|
||||
"inet_service"
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "lo"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"payload": {
|
||||
"field": "nexthdr",
|
||||
"protocol": "ip6"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv6-icmp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"payload": {
|
||||
"field": "saddr",
|
||||
"protocol": "ip6"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": {
|
||||
"prefix": {
|
||||
"addr": "fe80::",
|
||||
"len": 10
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "tcp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "tcp"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "@open_ports"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "udp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "udp"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "51944"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"drop": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "status"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": "dnat"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": {
|
||||
"set": [
|
||||
"lan"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": {
|
||||
"set": [
|
||||
"lan"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "tcp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"field": "daddr",
|
||||
"protocol": "ip6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "th"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"op": "==",
|
||||
"right": "@forwards_v6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": {
|
||||
"set": [
|
||||
"lan"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "udp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"field": "daddr",
|
||||
"protocol": "ip6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "th"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"op": "==",
|
||||
"right": "@forwards_v6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"drop": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "wan_forwards_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"fib": {
|
||||
"flags": [
|
||||
"daddr"
|
||||
],
|
||||
"result": "type"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "local"
|
||||
}
|
||||
},
|
||||
{
|
||||
"dnat": {
|
||||
"addr": {
|
||||
"map": {
|
||||
"data": "@wan_forwards",
|
||||
"key": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "th"
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
"family": "ip"
|
||||
}
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "wan_snat_postrouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"payload": {
|
||||
"field": "saddr",
|
||||
"protocol": "ip"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "@rfc1918"
|
||||
}
|
||||
},
|
||||
{
|
||||
"masquerade": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
98
examples/simple-router.nft
Normal file
98
examples/simple-router.nft
Normal file
@@ -0,0 +1,98 @@
|
||||
table inet fwl {
|
||||
|
||||
# ── let rfc1918 ──────────────────────────────────────────────────────────
|
||||
set rfc1918 {
|
||||
type ipv4_addr
|
||||
flags interval
|
||||
elements = {
|
||||
10.0.0.0/8,
|
||||
172.16.0.0/12,
|
||||
192.168.0.0/16
|
||||
}
|
||||
}
|
||||
|
||||
# ── let open_ports : Set<Port> ───────────────────────────────────────────
|
||||
set open_ports {
|
||||
type inet_service
|
||||
elements = { 22 }
|
||||
}
|
||||
|
||||
# ── let forwards_v6 : Set<(Protocol, IP, Port)> ──────────────────────────
|
||||
set forwards_v6 {
|
||||
type inet_proto . ipv6_addr . inet_service
|
||||
elements = {
|
||||
tcp . 2001:db8::1 . 22000
|
||||
}
|
||||
}
|
||||
|
||||
# ── let forwards : Map<(Protocol, Port), (IP, Port)> ────────────────────
|
||||
map forwards {
|
||||
type inet_proto . inet_service : ipv4_addr . inet_service
|
||||
elements = {
|
||||
tcp . 8080 : 10.0.0.10 . 80
|
||||
}
|
||||
}
|
||||
|
||||
# ── zone lan_zone = { lan } ──────────────────────────────────────────────
|
||||
# Zones compile to anonymous sets wherever referenced in iifname/oifname.
|
||||
# With a single member the set degenerates to a plain string match,
|
||||
# but we keep the set form so the compiler output is uniform regardless
|
||||
# of zone size.
|
||||
set lan_zone {
|
||||
type ifname
|
||||
elements = { "lan" }
|
||||
}
|
||||
|
||||
# ── policy input ─────────────────────────────────────────────────────────
|
||||
chain input {
|
||||
type filter hook input priority filter; policy drop;
|
||||
|
||||
ct state { established, related } accept
|
||||
iifname "lo" accept
|
||||
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
|
||||
meta nfproto ipv4 meta l4proto tcp tcp dport @open_ports accept
|
||||
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
|
||||
}
|
||||
|
||||
# ── policy forward ───────────────────────────────────────────────────────
|
||||
chain forward {
|
||||
type filter hook forward priority filter; policy drop;
|
||||
|
||||
ct state { established, related } accept
|
||||
ct status dnat accept
|
||||
|
||||
# | Frame(iif in lan_zone -> wan, _) -> Allow
|
||||
meta iifname @lan_zone meta oifname "wan" accept
|
||||
|
||||
# | Frame(wan -> iif in lan_zone, IPv4 TCP|UDP) if (proto,dport) in forwards
|
||||
meta iifname "wan" meta oifname @lan_zone \
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
meta l4proto . th dport @forwards accept
|
||||
|
||||
# | Frame(wan -> iif in lan_zone, IPv6 TCP|UDP) if (proto,dst,dport) in forwards_v6
|
||||
meta iifname "wan" meta oifname @lan_zone \
|
||||
meta nfproto ipv6 meta l4proto { tcp, udp } \
|
||||
meta l4proto . ip6 daddr . th dport @forwards_v6 accept
|
||||
}
|
||||
|
||||
# ── policy output ────────────────────────────────────────────────────────
|
||||
chain output {
|
||||
type filter hook output priority filter; policy accept;
|
||||
}
|
||||
|
||||
# ── policy nat_prerouting ────────────────────────────────────────────────
|
||||
chain nat_prerouting {
|
||||
type nat hook prerouting priority dstnat; policy accept;
|
||||
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
fib daddr type local \
|
||||
dnat ip to meta l4proto . th dport map @forwards
|
||||
}
|
||||
|
||||
# ── policy nat_postrouting ───────────────────────────────────────────────
|
||||
chain nat_postrouting {
|
||||
type nat hook postrouting priority srcnat; policy accept;
|
||||
|
||||
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
|
||||
}
|
||||
}
|
||||
693
examples/simple-router.nft.json
Normal file
693
examples/simple-router.nft.json
Normal file
@@ -0,0 +1,693 @@
|
||||
{
|
||||
"nftables": [
|
||||
{
|
||||
"metainfo": {
|
||||
"version": "1.1.6",
|
||||
"release_name": "Commodore Bullmoose #7",
|
||||
"json_schema_version": 1
|
||||
}
|
||||
},
|
||||
{
|
||||
"table": {
|
||||
"family": "inet",
|
||||
"name": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "input",
|
||||
"type": "filter",
|
||||
"hook": "input",
|
||||
"prio": 0,
|
||||
"policy": "drop"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "forward",
|
||||
"type": "filter",
|
||||
"hook": "forward",
|
||||
"prio": 0,
|
||||
"policy": "drop"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "output",
|
||||
"type": "filter",
|
||||
"hook": "output",
|
||||
"prio": 0,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "nat_prerouting",
|
||||
"type": "nat",
|
||||
"hook": "prerouting",
|
||||
"prio": -100,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "nat_postrouting",
|
||||
"type": "nat",
|
||||
"hook": "postrouting",
|
||||
"prio": 100,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "rfc1918",
|
||||
"table": "fwl",
|
||||
"type": "ipv4_addr",
|
||||
"flags": [
|
||||
"interval"
|
||||
],
|
||||
"elem": [
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "10.0.0.0",
|
||||
"len": 8
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "172.16.0.0",
|
||||
"len": 12
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "192.168.0.0",
|
||||
"len": 16
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "open_ports",
|
||||
"table": "fwl",
|
||||
"type": "inet_service",
|
||||
"elem": [
|
||||
22
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "forwards_v6",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"ipv6_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"elem": [
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
"2001:db8::1",
|
||||
22000
|
||||
]
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"map": {
|
||||
"family": "inet",
|
||||
"name": "forwards",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"inet_service"
|
||||
],
|
||||
"map": [
|
||||
"ipv4_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"elem": [
|
||||
[
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
8080
|
||||
]
|
||||
},
|
||||
{
|
||||
"concat": [
|
||||
"10.0.0.10",
|
||||
80
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "lan_zone",
|
||||
"table": "fwl",
|
||||
"type": "ifname",
|
||||
"elem": [
|
||||
"lan"
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "lo"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "nexthdr"
|
||||
}
|
||||
},
|
||||
"right": "ipv6-icmp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "saddr"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"prefix": {
|
||||
"addr": "fe80::",
|
||||
"len": 10
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "tcp",
|
||||
"field": "dport"
|
||||
}
|
||||
},
|
||||
"right": "@open_ports"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "udp",
|
||||
"field": "dport"
|
||||
}
|
||||
},
|
||||
"right": 51944
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "in",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "status"
|
||||
}
|
||||
},
|
||||
"right": "dnat"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"right": "@forwards"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "daddr"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"right": "@forwards_v6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "nat_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"fib": {
|
||||
"result": "type",
|
||||
"flags": [
|
||||
"daddr"
|
||||
]
|
||||
}
|
||||
},
|
||||
"right": "local"
|
||||
}
|
||||
},
|
||||
{
|
||||
"dnat": {
|
||||
"family": "ip",
|
||||
"addr": {
|
||||
"map": {
|
||||
"key": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"data": "@forwards"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "nat_postrouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip",
|
||||
"field": "saddr"
|
||||
}
|
||||
},
|
||||
"right": "@rfc1918"
|
||||
}
|
||||
},
|
||||
{
|
||||
"masquerade": null
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
20
fwl.cabal
20
fwl.cabal
@@ -36,3 +36,23 @@ 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
126
src/FWL/AST.hs
@@ -1,6 +1,7 @@
|
||||
module FWL.AST where
|
||||
|
||||
import Data.Word (Word8, Word16)
|
||||
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
|
||||
import Data.Word (Word8) -- Word8 still used for ByteElem/hex literals
|
||||
|
||||
type Name = String
|
||||
|
||||
@@ -27,8 +28,12 @@ data Decl
|
||||
| DLet Name Type Expr
|
||||
| DPattern Name Type Pat
|
||||
| DFlow Name FlowExpr
|
||||
| DRule Name Type Expr -- body must be ELam
|
||||
| DRule Name Type Expr
|
||||
| DPolicy Name Type PolicyMeta ArmBlock
|
||||
| DPortForward Name Name Type [(Expr, Expr)]
|
||||
-- ^ decl-name interface-name map-type map-entries
|
||||
| DMasquerade Name Name Name
|
||||
-- ^ decl-name interface-name src-set-name
|
||||
deriving (Show)
|
||||
|
||||
data PolicyMeta = PolicyMeta
|
||||
@@ -41,9 +46,22 @@ data Hook = HInput | HForward | HOutput | HPrerouting | HPostrouting
|
||||
deriving (Show, Eq)
|
||||
data TableName = TFilter | TNAT
|
||||
deriving (Show, Eq)
|
||||
data Priority = PFilter | PDstNat | PSrcNat | PMangle | PInt Int
|
||||
-- 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 }
|
||||
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)
|
||||
|
||||
@@ -53,23 +71,28 @@ 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 -- first-class named pattern ref
|
||||
| PCtor Name [Pat] -- IPv4(ip, ...), TCP(tcp, ...)
|
||||
| PRecord Name [FieldPat] -- udp { length = 156 }
|
||||
| PNamed Name
|
||||
| PCtor Name [Pat]
|
||||
| PRecord Name [FieldPat]
|
||||
| PTuple [Pat]
|
||||
| PFrame (Maybe PathPat) Pat -- Frame(path?, inner)
|
||||
| PFrame (Maybe PathPat) Pat
|
||||
| PBytes [ByteElem]
|
||||
| POr Pat Pat
|
||||
deriving (Show)
|
||||
|
||||
data FieldPat
|
||||
= FPEq Name Literal -- field = literal
|
||||
| FPBind Name -- bind field to same-named var
|
||||
| FPAs Name Name -- field as var
|
||||
= FPEq Name Literal
|
||||
| FPBind Name
|
||||
| FPAs Name Name
|
||||
deriving (Show)
|
||||
|
||||
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
|
||||
@@ -78,13 +101,13 @@ data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
|
||||
data EndpointPat
|
||||
= EPWild
|
||||
| EPName Name
|
||||
| EPMember Name Name -- iif `in` zone
|
||||
| EPMember Name Name
|
||||
deriving (Show)
|
||||
|
||||
data ByteElem
|
||||
= BEHex Word8
|
||||
| BEWild -- _ (one byte)
|
||||
| BEWildStar -- _* (zero or more)
|
||||
| BEWild
|
||||
| BEWildStar
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Flow ───────────────────────────────────────────────────────────────────
|
||||
@@ -95,8 +118,11 @@ 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)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ─── Types ──────────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -111,7 +137,7 @@ data Type
|
||||
|
||||
data Expr
|
||||
= EVar Name
|
||||
| EQual [Name] -- qualified name, e.g. Log.emit
|
||||
| EQual [Name]
|
||||
| ELit Literal
|
||||
| ELam Name Expr
|
||||
| EApp Expr Expr
|
||||
@@ -122,7 +148,7 @@ data Expr
|
||||
| ETuple [Expr]
|
||||
| ESet [Expr]
|
||||
| EMap [(Expr, Expr)]
|
||||
| EPerform [Name] [Expr] -- perform QualName(args)
|
||||
| EPerform [Name] [Expr]
|
||||
| EInfix InfixOp Expr Expr
|
||||
| ENot Expr
|
||||
deriving (Show)
|
||||
@@ -130,10 +156,10 @@ data Expr
|
||||
data InfixOp
|
||||
= OpAnd | OpOr
|
||||
| OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
|
||||
| OpIn -- `in` / `∈`
|
||||
| OpConcat -- ++
|
||||
| OpThen -- >>
|
||||
| OpBind -- >>=
|
||||
| OpIn
|
||||
| OpConcat
|
||||
| OpThen
|
||||
| OpBind
|
||||
deriving (Show, Eq)
|
||||
|
||||
data DoStmt
|
||||
@@ -142,19 +168,71 @@ data DoStmt
|
||||
deriving (Show)
|
||||
|
||||
type ArmBlock = [Arm]
|
||||
data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard?, body
|
||||
data Arm = Arm Pat (Maybe Expr) Expr
|
||||
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
|
||||
| LIPv4 (Word8,Word8,Word8,Word8)
|
||||
| LIPv6 [Word16]
|
||||
| LCIDR Literal Int
|
||||
| LIP IPVersion Integer -- unified IP address representation
|
||||
| LCIDR Literal Int -- base address + prefix length
|
||||
| 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
|
||||
|
||||
@@ -9,7 +9,7 @@ module FWL.Check
|
||||
, CheckError(..)
|
||||
) where
|
||||
|
||||
import Data.List (foldl', nub)
|
||||
import Data.List (nub)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@@ -20,6 +20,7 @@ data CheckError
|
||||
| PolicyNoContinue String -- policy name
|
||||
| PatternCycle [String] -- cycle path
|
||||
| DuplicateDecl String String -- kind, name
|
||||
| OrPatternMismatch [String] [String]
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Env = Map.Map String DeclKind
|
||||
@@ -43,12 +44,14 @@ 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 _ = m
|
||||
addDecl m (DPortForward n _ _ _) = Map.insert n KLet m
|
||||
addDecl m (DMasquerade n _ _) = Map.insert n KLet m
|
||||
|
||||
findDups :: [Decl] -> [CheckError]
|
||||
findDups decls = go [] Set.empty decls
|
||||
@@ -69,6 +72,8 @@ declName (DPattern n _ _) = n
|
||||
declName (DFlow n _) = n
|
||||
declName (DRule n _ _) = n
|
||||
declName (DPolicy n _ _ _) = n
|
||||
declName (DPortForward n _ _ _) = n
|
||||
declName (DMasquerade n _ _) = n
|
||||
|
||||
declKindStr :: Decl -> String
|
||||
declKindStr (DInterface _ _ _) = "interface"
|
||||
@@ -79,6 +84,8 @@ declKindStr (DPattern _ _ _) = "pattern"
|
||||
declKindStr (DFlow _ _) = "flow"
|
||||
declKindStr (DRule _ _ _) = "rule"
|
||||
declKindStr (DPolicy _ _ _ _) = "policy"
|
||||
declKindStr (DPortForward _ _ _ _) = "portforward"
|
||||
declKindStr (DMasquerade _ _ _) = "masquerade"
|
||||
|
||||
-- ─── Name resolution ─────────────────────────────────────────────────────────
|
||||
|
||||
@@ -89,6 +96,12 @@ checkDecl env (DFlow _ fe) = checkFlow env fe
|
||||
checkDecl env (DRule _ _ e) = checkExpr env e
|
||||
checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab
|
||||
checkDecl env (DLet _ _ e) = checkExpr env e
|
||||
checkDecl env (DPortForward _ iface _ entries) =
|
||||
checkName env "interface" iface ++
|
||||
concatMap (\(k,v) -> checkExpr env k ++ checkExpr env v) entries
|
||||
checkDecl env (DMasquerade _ iface srcSet) =
|
||||
checkName env "interface" iface ++
|
||||
checkName env "set" srcSet
|
||||
checkDecl _ _ = []
|
||||
|
||||
checkName :: Env -> String -> String -> [CheckError]
|
||||
@@ -100,11 +113,12 @@ checkName env kind n
|
||||
isBuiltin :: String -> Bool
|
||||
isBuiltin n = n `elem`
|
||||
[ "ct", "iif", "oif", "lo", "wan", "lan"
|
||||
, "tcp", "udp", "ip", "ip6", "eth"
|
||||
, "tcp", "udp", "ip", "ip6", "eth", "wg"
|
||||
, "Established", "Related", "DNAT"
|
||||
, "Allow", "Drop", "Continue", "Masquerade"
|
||||
, "Allow", "Drop", "Continue", "Masquerade", "DNATMap"
|
||||
, "Matched", "Unmatched"
|
||||
, "true", "false"
|
||||
, "matches", "flowOf", "Warn"
|
||||
]
|
||||
|
||||
checkPat :: Env -> Pat -> [CheckError]
|
||||
@@ -116,6 +130,25 @@ checkPat env (PRecord _ fs) = concatMap (checkFP env) fs
|
||||
checkPat env (PTuple ps) = concatMap (checkPat env) ps
|
||||
checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner
|
||||
checkPat _ (PBytes _) = []
|
||||
checkPat env (POr p1 p2) =
|
||||
let v1 = boundVars p1
|
||||
v2 = boundVars p2
|
||||
errs = if Set.fromList v1 == Set.fromList v2 then [] else [OrPatternMismatch v1 v2]
|
||||
in errs ++ checkPat env p1 ++ checkPat env p2
|
||||
|
||||
boundVars :: Pat -> [String]
|
||||
boundVars (PVar n) = [n]
|
||||
boundVars (PCtor _ ps) = concatMap boundVars ps
|
||||
boundVars (PRecord _ fs) = concatMap boundFP fs
|
||||
boundVars (PTuple ps) = concatMap boundVars ps
|
||||
boundVars (PFrame _ p) = boundVars p
|
||||
boundVars (POr p1 p2) = boundVars p1
|
||||
boundVars _ = []
|
||||
|
||||
boundFP :: FieldPat -> [String]
|
||||
boundFP (FPBind n) = [n]
|
||||
boundFP (FPAs _ v) = [v]
|
||||
boundFP _ = []
|
||||
|
||||
checkFP :: Env -> FieldPat -> [CheckError]
|
||||
checkFP _ _ = [] -- field names checked by type-checker later
|
||||
@@ -135,15 +168,36 @@ 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
|
||||
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
|
||||
|
||||
checkExpr :: Env -> Expr -> [CheckError]
|
||||
checkExpr env (EVar n) = checkName env "name" n
|
||||
checkExpr _ (EQual _) = [] -- qualified names: deferred
|
||||
checkExpr _ (ELit _) = []
|
||||
checkExpr env (ELam _ e) = checkExpr env e
|
||||
checkExpr env (ELam n e) = checkExpr (Map.insert n KLet 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]
|
||||
@@ -190,6 +244,7 @@ checkPatternCycles decls =
|
||||
refsInPat (PCtor _ ps) = concatMap refsInPat ps
|
||||
refsInPat (PTuple ps) = concatMap refsInPat ps
|
||||
refsInPat (PFrame _ p) = refsInPat p
|
||||
refsInPat (POr p1 p2) = refsInPat p1 ++ refsInPat p2
|
||||
refsInPat _ = []
|
||||
|
||||
findCycles :: Map.Map String [String] -> [[String]]
|
||||
|
||||
@@ -1,8 +1,13 @@
|
||||
{-# 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 — the compiler inserts protocol matches
|
||||
from whatever constructor the user wrote.
|
||||
to those that include it.
|
||||
|
||||
Phase 1: DRule declarations compile to regular (no-hook) chains.
|
||||
Phase 2: compileAction returns Maybe [Value] to support multi-step arms.
|
||||
Phase 3: Log.emit -> {"log": ...} effect statement.
|
||||
Phase 4: DFlow declarations -> ct mark state machines (_track chains).
|
||||
-}
|
||||
module FWL.Compile
|
||||
( compileProgram
|
||||
@@ -11,38 +16,384 @@ 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 qualified Data.Aeson as A
|
||||
import Data.Aeson ((.=), Value(..), object, toJSON)
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Aeson.Encode.Pretty as Pretty
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
|
||||
import FWL.AST
|
||||
|
||||
-- ─── Entry points ────────────────────────────────────────────────────────────
|
||||
|
||||
-- | Compile an FWL program and render to pretty-printed JSON bytes.
|
||||
compileToJson :: Program -> BL.ByteString
|
||||
compileToJson = Pretty.encodePretty . programToValue
|
||||
compileToJson = encodePretty . programToValue
|
||||
|
||||
-- | Compile an FWL program to an Aeson Value (the nftables JSON schema).
|
||||
programToValue :: Program -> Value
|
||||
programToValue prog@(Program cfg decls) =
|
||||
object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
|
||||
-- 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
|
||||
env = buildEnv decls
|
||||
declNameOf (DInterface n _ _) = n
|
||||
declNameOf (DZone n _) = n
|
||||
declNameOf (DPattern n _ _) = n
|
||||
declNameOf (DFlow n _) = n
|
||||
declNameOf (DRule n _ _) = n
|
||||
declNameOf (DPolicy n _ _ _) = n
|
||||
declNameOf (DLet n _ _) = n
|
||||
declNameOf (DImport n _ _) = n
|
||||
declNameOf (DPortForward n _ _ _) = n
|
||||
declNameOf (DMasquerade n _ _) = n
|
||||
|
||||
-- ─── Top-level program ───────────────────────────────────────────────────────
|
||||
|
||||
programToValue :: Program -> Value
|
||||
programToValue (Program cfg decls) =
|
||||
object [ "nftables" .= toJSON
|
||||
(metainfo : tableObj : allObjects) ]
|
||||
where
|
||||
-- Phase 4: allocate ct marks for all DFlow declarations
|
||||
ctMarks = allocateCtMarks cfg decls
|
||||
env = (buildEnv decls) { envCtMarks = ctMarks }
|
||||
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 ]
|
||||
chainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
|
||||
ruleObjs = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies
|
||||
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)
|
||||
|
||||
-- ── 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, _, e) -> letToMapValue tbl n e) letDecls
|
||||
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 _ _ _ = []
|
||||
|
||||
|
||||
-- ─── Table / Chain declarations ──────────────────────────────────────────────
|
||||
|
||||
@@ -60,7 +411,7 @@ chainDeclValue tbl n pm = object
|
||||
, "name" .= n
|
||||
, "type" .= chainTypeStr (pmTable pm)
|
||||
, "hook" .= hookStr (pmHook pm)
|
||||
, "prio" .= priorityStr (pmPriority pm)
|
||||
, "prio" .= priorityInt (pmPriority pm)
|
||||
, "policy" .= defaultPolicyStr (pmHook pm)
|
||||
]
|
||||
]
|
||||
@@ -76,14 +427,10 @@ hookStr HOutput = "output"
|
||||
hookStr HPrerouting = "prerouting"
|
||||
hookStr HPostrouting = "postrouting"
|
||||
|
||||
priorityStr :: Priority -> String
|
||||
priorityStr PFilter = "filter"
|
||||
priorityStr PDstNat = "dstnat"
|
||||
priorityStr PSrcNat = "srcnat"
|
||||
priorityStr PMangle = "mangle"
|
||||
priorityStr (PInt n) = show n
|
||||
-- Priority is emitted as an integer in nftables JSON.
|
||||
priorityInt :: Priority -> Int
|
||||
priorityInt = priorityValue
|
||||
|
||||
-- Input and Forward hooks default to drop; everything else to accept.
|
||||
defaultPolicyStr :: Hook -> String
|
||||
defaultPolicyStr HInput = "drop"
|
||||
defaultPolicyStr HForward = "drop"
|
||||
@@ -91,226 +438,359 @@ defaultPolicyStr _ = "accept"
|
||||
|
||||
-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
|
||||
|
||||
-- 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 -> String -> Name -> Arm -> [Value]
|
||||
armToRuleValues env tbl chain (Arm p mg body) =
|
||||
-- Phase 2: compileAction returns Maybe [Value]
|
||||
case compileAction env body of
|
||||
Nothing -> [] -- Continue: emit nothing
|
||||
Just verdict ->
|
||||
let patExprs = compilePat env p
|
||||
Nothing -> []
|
||||
Just verdicts ->
|
||||
let patExprsAlts = 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 allExprs
|
||||
]
|
||||
, "expr" .= toJSON (patExprs ++ guardExprs ++ verdicts)
|
||||
]
|
||||
]
|
||||
| patExprs <- patExprsAlts ]
|
||||
|
||||
-- ─── Pattern → [Value] ───────────────────────────────────────────────────────
|
||||
|
||||
type CompileEnv = Map.Map String Decl
|
||||
type CompileEnv = Map.Map String Decl -- kept for internal helpers that only
|
||||
-- need the decl map
|
||||
|
||||
buildEnv :: [Decl] -> CompileEnv
|
||||
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
|
||||
-- Convenience accessor
|
||||
declEnv :: Env -> CompileEnv
|
||||
declEnv = envDecls
|
||||
|
||||
compilePat :: CompileEnv -> Pat -> [Value]
|
||||
compilePat _ PWild = []
|
||||
compilePat _ (PVar _) = []
|
||||
compilePat :: Env -> Pat -> [[Value]]
|
||||
compilePat _ PWild = [[]]
|
||||
compilePat _ (PVar _) = [[]]
|
||||
compilePat env (PNamed n) = expandNamedPat env n
|
||||
compilePat env (PFrame mp inner) =
|
||||
maybe [] (compilePathPat env) mp ++ compilePat env inner
|
||||
compilePat env (PFrame mp inner) = do
|
||||
pathConds <- maybe [[]] (compilePathPat env) mp
|
||||
innerConds <- compilePat env inner
|
||||
return (pathConds ++ innerConds)
|
||||
compilePat env (PCtor n ps) = compileCtorPat env n ps
|
||||
compilePat _ (PRecord n fs) = compileRecordPat n fs
|
||||
compilePat env (PTuple ps) = concatMap (compilePat env) ps
|
||||
compilePat _ (PBytes _) = [] -- handled by flow/ct mark (future)
|
||||
compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps))
|
||||
compilePat _ (PBytes _) = [[]]
|
||||
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
|
||||
|
||||
-- Named patterns are inlined at compile time.
|
||||
expandNamedPat :: CompileEnv -> Name -> [Value]
|
||||
expandNamedPat :: Env -> Name -> [[Value]]
|
||||
expandNamedPat env n =
|
||||
case Map.lookup n env of
|
||||
case Map.lookup n (declEnv env) of
|
||||
Just (DPattern _ _ p) -> compilePat env p
|
||||
_ -> []
|
||||
|
||||
-- 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 -> String -> [Pat] -> [[Value]]
|
||||
compileCtorPat env ctor ps = case ctor of
|
||||
"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
|
||||
"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
|
||||
_ -> children
|
||||
where
|
||||
children = concatMap (compilePat env) ps
|
||||
children = map concat (sequence (map (compilePat env) ps))
|
||||
|
||||
-- Record patterns emit field equality matches, e.g. tcp { dport = :22 }.
|
||||
compileRecordPat :: String -> [FieldPat] -> [Value]
|
||||
compileRecordPat proto = mapMaybe go
|
||||
compileRecordPat :: String -> [FieldPat] -> [[Value]]
|
||||
compileRecordPat proto fs = [mapMaybe go fs]
|
||||
where
|
||||
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
|
||||
go _ = Nothing
|
||||
|
||||
-- Path patterns (iif/oif).
|
||||
compilePathPat :: CompileEnv -> PathPat -> [Value]
|
||||
compilePathPat _ (PathPat ms md) =
|
||||
maybe [] (compileEndpoint "iifname") ms ++
|
||||
maybe [] (compileEndpoint "oifname") md
|
||||
compilePathPat :: Env -> PathPat -> [[Value]]
|
||||
compilePathPat env (PathPat ms md) =
|
||||
[ maybe [] (compileEndpoint env "iifname") ms ++
|
||||
maybe [] (compileEndpoint env "oifname") md ]
|
||||
|
||||
compileEndpoint :: String -> EndpointPat -> [Value]
|
||||
compileEndpoint _ EPWild = []
|
||||
compileEndpoint dir (EPName n) = [matchMeta dir n]
|
||||
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]]
|
||||
-- zone membership: for MVP we emit the zone name as a set element.
|
||||
-- A later pass would expand zones to their member interface names.
|
||||
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)]]
|
||||
|
||||
-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
|
||||
|
||||
compileGuard :: CompileEnv -> Expr -> [Value]
|
||||
compileGuard :: Env -> Expr -> [Value]
|
||||
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
|
||||
compileGuard _ (EInfix OpIn l r) = [compileInExpr l r]
|
||||
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)]
|
||||
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal r)]
|
||||
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
|
||||
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
|
||||
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
|
||||
compileGuard _ _ = []
|
||||
|
||||
compileInExpr :: Expr -> Expr -> Value
|
||||
-- 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)
|
||||
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)
|
||||
|
||||
ctMatch :: String -> [Expr] -> Value
|
||||
ctMatch key vs = matchExpr "in"
|
||||
(object ["ct" .= object ["key" .= key]])
|
||||
(setVal (map exprToStr vs))
|
||||
-- ─── 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.
|
||||
|
||||
-- ─── 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 :: Env -> Expr -> Maybe [Value]
|
||||
-- Simple verdicts
|
||||
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 _ (EApp (EVar "DNATMap") arg) =
|
||||
Just $ object ["dnat" .= object ["addr" .= object
|
||||
["map" .= object ["key" .= object ["concat" .= Array mempty]
|
||||
,"data" .= exprToStr arg]]]]
|
||||
-- Rule invocation → jump
|
||||
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
|
||||
compileAction env (EApp (EVar rn) _) =
|
||||
case Map.lookup rn env of
|
||||
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
|
||||
_ -> Just (object ["accept" .= Null])
|
||||
compileAction _ _ = Just (object ["accept" .= Null])
|
||||
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]]
|
||||
|
||||
-- ─── Let → Map object ────────────────────────────────────────────────────────
|
||||
-- | 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)
|
||||
|
||||
letToMapValue :: String -> Name -> Expr -> Maybe Value
|
||||
letToMapValue tbl n (EMap entries) = Just $ object
|
||||
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
|
||||
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
|
||||
[ "map" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= ("inetproto . inetservice" :: String)
|
||||
, "map" .= ("ipv4_addr . inetservice" :: String)
|
||||
, "type" .= renderNftType (fwlTypeToNft tk)
|
||||
, "map" .= renderNftType (fwlTypeToNft tv)
|
||||
, "elem" .= toJSON (map renderMapElem entries)
|
||||
]
|
||||
]
|
||||
letToMapValue _ _ _ = Nothing
|
||||
letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object
|
||||
[ "set" .= object
|
||||
( [ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= renderNftType (fwlTypeToNft t)
|
||||
]
|
||||
++ (if any isCidrElem entries then ["flags" .= toJSON (["interval"] :: [String])] else [])
|
||||
++ [ "elem" .= toJSON (map renderSetElem entries) ]
|
||||
)
|
||||
]
|
||||
letToSetOrMapValue _ _ _ _ = Nothing
|
||||
|
||||
fwlTypeToNft :: Type -> [String]
|
||||
fwlTypeToNft (TName "Protocol" []) = ["inet_proto"]
|
||||
fwlTypeToNft (TName "Port" []) = ["inet_service"]
|
||||
fwlTypeToNft (TName "IP" []) = ["ipv4_addr"]
|
||||
fwlTypeToNft (TName "IPv4" []) = ["ipv4_addr"]
|
||||
fwlTypeToNft (TName "IPv6" []) = ["ipv6_addr"]
|
||||
fwlTypeToNft (TTuple ts) = concatMap fwlTypeToNft ts
|
||||
fwlTypeToNft _ = ["any"]
|
||||
|
||||
renderNftType :: [String] -> Value
|
||||
renderNftType [t] = A.String (toText t)
|
||||
renderNftType ts = toJSON ts
|
||||
|
||||
exprToVal :: Expr -> Value
|
||||
exprToVal (ELit (LPort p)) = toJSON p
|
||||
exprToVal (ELit (LInt n)) = toJSON n
|
||||
exprToVal (ELit (LCIDR ip p))= object
|
||||
[ "prefix" .= object
|
||||
[ "addr" .= A.String (toText (renderLit ip))
|
||||
, "len" .= p
|
||||
]
|
||||
]
|
||||
exprToVal (ELit l) = A.String (toText (renderLit l))
|
||||
exprToVal (EVar n) = A.String (toText n)
|
||||
exprToVal (EQual ns) = A.String (toText (intercalate "." ns))
|
||||
exprToVal _ = A.String "_"
|
||||
|
||||
exprToConcatList :: Expr -> [Value]
|
||||
exprToConcatList (ETuple es) = concatMap exprToConcatList es
|
||||
exprToConcatList e = [exprToVal e]
|
||||
|
||||
renderMapOrSetKey :: Expr -> Value
|
||||
renderMapOrSetKey (ETuple es) = object ["concat" .= toJSON (exprToConcatList (ETuple es))]
|
||||
renderMapOrSetKey e = exprToVal e
|
||||
|
||||
renderMapElem :: (Expr, Expr) -> Value
|
||||
renderMapElem (k, v) = toJSON
|
||||
[ object ["concat" .= toJSON [exprToStr k]]
|
||||
, exprToStr v
|
||||
[ renderMapOrSetKey k
|
||||
, renderMapOrSetKey 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
|
||||
[ "op" .= (op :: String)
|
||||
, "left" .= l
|
||||
, "right" .= r
|
||||
]
|
||||
]
|
||||
|
||||
matchMeta :: String -> String -> Value
|
||||
matchMeta key val = matchExpr "==" (metaVal key) (A.String (strText val))
|
||||
matchMeta key val = matchExpr "==" (metaVal key) (A.String (toText val))
|
||||
|
||||
matchPayload :: String -> String -> String -> Value
|
||||
matchPayload proto field val =
|
||||
matchExpr "==" (payloadVal proto field) (A.String (strText val))
|
||||
matchExpr "==" (payloadVal proto field) (A.String (toText val))
|
||||
|
||||
matchInSet :: Value -> [String] -> Value
|
||||
matchInSet lhs vals =
|
||||
matchExpr "in" lhs (setVal vals)
|
||||
matchInSet :: Value -> [Value] -> Value
|
||||
matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
|
||||
|
||||
metaVal :: String -> Value
|
||||
metaVal key = object ["meta" .= object ["key" .= key]]
|
||||
metaVal key = object ["meta" .= object ["key" .= (key :: String)]]
|
||||
|
||||
payloadVal :: String -> String -> Value
|
||||
payloadVal proto field =
|
||||
object ["payload" .= object ["protocol" .= proto, "field" .= field]]
|
||||
object ["payload" .= object
|
||||
[ "protocol" .= (proto :: String)
|
||||
, "field" .= (field :: String)
|
||||
]]
|
||||
|
||||
setVal :: [String] -> Value
|
||||
setVal :: [Value] -> Value
|
||||
setVal vs = object ["set" .= toJSON vs]
|
||||
|
||||
-- ─── Expression → Value helpers ──────────────────────────────────────────────
|
||||
-- ─── Expression helpers ───────────────────────────────────────────────────────
|
||||
|
||||
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))
|
||||
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))
|
||||
|
||||
exprToStr :: Expr -> String
|
||||
exprToStr (EVar n) = n
|
||||
exprToStr (EVar n) = case n of
|
||||
"Established" -> "established"
|
||||
"Related" -> "related"
|
||||
"DNAT" -> "dnat"
|
||||
_ -> n
|
||||
exprToStr (ELit l) = renderLit l
|
||||
exprToStr (EQual ns) = intercalate "." ns
|
||||
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
|
||||
exprToStr _ = "_"
|
||||
|
||||
strText :: String -> A.Text
|
||||
strText = \s -> read (show s) -- simple String→Text without extra dep
|
||||
toText :: String -> T.Text
|
||||
toText = T.pack
|
||||
|
||||
renderLit :: Literal -> String
|
||||
renderLit (LInt n) = show n
|
||||
renderLit (LString s) = s
|
||||
renderLit (LBool True) = "true"
|
||||
renderLit (LBool False) = "false"
|
||||
renderLit (LIPv4 (a,b,c,d)) =
|
||||
show a++"."++show b++"."++show c++"."++show d
|
||||
renderLit (LIPv6 _) = "::1"
|
||||
renderLit (LIP IPv4 n) = renderIPv4 n
|
||||
renderLit (LIP IPv6 n) = renderIPv6 n
|
||||
renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p
|
||||
renderLit (LPort p) = show p
|
||||
renderLit (LDuration n Seconds) = show n
|
||||
renderLit (LDuration n _) = show n
|
||||
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 (LHex b) = show b
|
||||
|
||||
-- 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)
|
||||
-- ─── 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
|
||||
|
||||
@@ -15,19 +15,21 @@ fwlDef = emptyDef
|
||||
, Tok.identStart = letter <|> char '_'
|
||||
, Tok.identLetter = alphaNum <|> char '_'
|
||||
, Tok.reservedNames =
|
||||
[ "config", "table"
|
||||
-- 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"
|
||||
, "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"
|
||||
, "Allow", "Drop", "Continue", "Masquerade", "DNAT", "DNATMap"
|
||||
, "Log", "Info", "Warn", "Error"
|
||||
, "Matched", "Unmatched"
|
||||
, "Frame", "FlowPattern"
|
||||
, "Filter", "NAT", "Mangle", "DstNat", "SrcNat", "Raw", "ConnTrack"
|
||||
, "true", "false"
|
||||
]
|
||||
, Tok.reservedOpNames =
|
||||
|
||||
@@ -3,15 +3,19 @@ module FWL.Parser
|
||||
, parseFile
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad (void, when)
|
||||
import Data.Bits ((.&.), (.|.), shiftL)
|
||||
import Data.List (foldl')
|
||||
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 ────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -34,7 +38,7 @@ program = do
|
||||
configBlock :: Parser Config
|
||||
configBlock = do
|
||||
reserved "config"
|
||||
props <- braces (semiSep configProp)
|
||||
props <- braces (endBy configProp semi)
|
||||
optional semi
|
||||
return $ foldr applyProp defaultConfig props
|
||||
where
|
||||
@@ -43,10 +47,10 @@ configBlock = do
|
||||
|
||||
configProp :: Parser (String, String)
|
||||
configProp = do
|
||||
reserved "table"
|
||||
n <- identifier -- "table" is no longer reserved
|
||||
reservedOp "="
|
||||
v <- stringLit
|
||||
return ("table", v)
|
||||
return (n, v)
|
||||
|
||||
-- ─── Declarations ────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -59,6 +63,8 @@ decl = interfaceDecl
|
||||
<|> flowDecl
|
||||
<|> ruleDecl
|
||||
<|> policyDecl
|
||||
<|> portforwardDecl
|
||||
<|> masqueradeDecl
|
||||
|
||||
interfaceDecl :: Parser Decl
|
||||
interfaceDecl = do
|
||||
@@ -66,8 +72,8 @@ interfaceDecl = do
|
||||
n <- identifier
|
||||
reservedOp ":"
|
||||
k <- ifaceKind
|
||||
ps <- braces (semiSep ifaceProp)
|
||||
semi
|
||||
ps <- braces (endBy ifaceProp semi)
|
||||
_ <- semi
|
||||
return (DInterface n k ps)
|
||||
|
||||
ifaceKind :: Parser IfaceKind
|
||||
@@ -90,7 +96,7 @@ zoneDecl = do
|
||||
n <- identifier
|
||||
reservedOp "="
|
||||
ns <- braces (commaSep1 identifier)
|
||||
semi
|
||||
_ <- semi
|
||||
return (DZone n ns)
|
||||
|
||||
importDecl :: Parser Decl
|
||||
@@ -101,7 +107,7 @@ importDecl = do
|
||||
t <- typeP
|
||||
reserved "from"
|
||||
s <- stringLit
|
||||
semi
|
||||
_ <- semi
|
||||
return (DImport n t s)
|
||||
|
||||
letDecl :: Parser Decl
|
||||
@@ -112,7 +118,7 @@ letDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
e <- expr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DLet n t e)
|
||||
|
||||
patternDecl :: Parser Decl
|
||||
@@ -123,7 +129,7 @@ patternDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
p <- pat
|
||||
semi
|
||||
_ <- semi
|
||||
return (DPattern n t p)
|
||||
|
||||
flowDecl :: Parser Decl
|
||||
@@ -134,7 +140,7 @@ flowDecl = do
|
||||
reserved "FlowPattern"
|
||||
reservedOp "="
|
||||
f <- flowExpr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DFlow n f)
|
||||
|
||||
ruleDecl :: Parser Decl
|
||||
@@ -145,7 +151,7 @@ ruleDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
e <- expr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DRule n t e)
|
||||
|
||||
policyDecl :: Parser Decl
|
||||
@@ -154,26 +160,31 @@ policyDecl = do
|
||||
n <- identifier
|
||||
reservedOp ":"
|
||||
t <- typeP
|
||||
reserved "on"
|
||||
pm <- braces policyMeta
|
||||
reserved "hook"
|
||||
h <- hookP
|
||||
mp <- optionMaybe (reserved "priority" >> priorityP)
|
||||
let tb = hookDefaultTable h
|
||||
pr = maybe (hookDefaultPriority h) id mp
|
||||
reservedOp "="
|
||||
ab <- armBlock
|
||||
semi
|
||||
return (DPolicy n t pm ab)
|
||||
_ <- semi
|
||||
return (DPolicy n t (PolicyMeta h tb pr) ab)
|
||||
|
||||
policyMeta :: Parser PolicyMeta
|
||||
policyMeta = do
|
||||
props <- commaSep1 metaProp
|
||||
let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props
|
||||
tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props
|
||||
pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) PFilter props
|
||||
return (PolicyMeta h tb pr)
|
||||
-- | Infer table from hook
|
||||
hookDefaultTable :: Hook -> TableName
|
||||
hookDefaultTable HInput = TFilter
|
||||
hookDefaultTable HForward = TFilter
|
||||
hookDefaultTable HOutput = TFilter
|
||||
hookDefaultTable HPrerouting = TNAT
|
||||
hookDefaultTable HPostrouting = TNAT
|
||||
|
||||
metaProp :: Parser (Either Hook (Either TableName Priority))
|
||||
metaProp
|
||||
= (reserved "hook" >> reservedOp "=" >> fmap (Left) hookP)
|
||||
<|> (reserved "table" >> reservedOp "=" >> fmap (Right . Left) tableNameP)
|
||||
<|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right) priorityP)
|
||||
-- | Default priority per hook
|
||||
hookDefaultPriority :: Hook -> Priority
|
||||
hookDefaultPriority HInput = pFilter
|
||||
hookDefaultPriority HForward = pFilter
|
||||
hookDefaultPriority HOutput = pFilter
|
||||
hookDefaultPriority HPrerouting = pDstNat
|
||||
hookDefaultPriority HPostrouting = pSrcNat
|
||||
|
||||
hookP :: Parser Hook
|
||||
hookP = (reserved "Input" >> return HInput)
|
||||
@@ -182,16 +193,48 @@ hookP = (reserved "Input" >> return HInput)
|
||||
<|> (reserved "Prerouting" >> return HPrerouting)
|
||||
<|> (reserved "Postrouting" >> return HPostrouting)
|
||||
|
||||
tableNameP :: Parser TableName
|
||||
tableNameP = (reserved "Filter" >> return TFilter)
|
||||
<|> (reserved "NAT" >> return TNAT)
|
||||
-- portforward <name> on <iface> via <MapType> = { entries };
|
||||
portforwardDecl :: Parser Decl
|
||||
portforwardDecl = do
|
||||
reserved "portforward"
|
||||
n <- identifier
|
||||
reserved "on"
|
||||
iface <- identifier
|
||||
reserved "via"
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
entries <- braces (commaSep mapEntry)
|
||||
_ <- semi
|
||||
return (DPortForward n iface t entries)
|
||||
|
||||
-- masquerade <name> on <iface> src <set-name>;
|
||||
masqueradeDecl :: Parser Decl
|
||||
masqueradeDecl = do
|
||||
reserved "masquerade"
|
||||
n <- identifier
|
||||
reserved "on"
|
||||
iface <- identifier
|
||||
reserved "src"
|
||||
srcSet <- identifier
|
||||
_ <- semi
|
||||
return (DMasquerade n iface srcSet)
|
||||
|
||||
priorityP :: Parser Priority
|
||||
priorityP = (reserved "Filter" >> return PFilter)
|
||||
<|> (reserved "DstNat" >> return PDstNat)
|
||||
<|> (reserved "SrcNat" >> return PSrcNat)
|
||||
<|> (reserved "Mangle" >> return PMangle)
|
||||
<|> (PInt . fromIntegral <$> natural)
|
||||
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)
|
||||
|
||||
-- ─── Arm blocks ──────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -200,19 +243,24 @@ 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 = wildcardPat
|
||||
<|> framePat
|
||||
pat = Ex.buildExpressionParser patTable patAtom <?> "pattern"
|
||||
where
|
||||
patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ]
|
||||
|
||||
patAtom :: Parser Pat
|
||||
patAtom = wildcardPat
|
||||
<|> try framePat
|
||||
<|> try tuplePat
|
||||
<|> bytesPat
|
||||
<|> try recordPat
|
||||
@@ -236,7 +284,7 @@ frameArgs = try withPath <|> withoutPath
|
||||
where
|
||||
withPath = do
|
||||
pp <- pathPat
|
||||
comma
|
||||
_ <- comma
|
||||
inner <- pat
|
||||
return (Just pp, inner)
|
||||
withoutPath = do
|
||||
@@ -271,7 +319,7 @@ tuplePat = do
|
||||
commaSep2 :: Parser a -> Parser [a]
|
||||
commaSep2 p = do
|
||||
x <- p
|
||||
comma
|
||||
_ <- comma
|
||||
xs <- commaSep1 p
|
||||
return (x:xs)
|
||||
|
||||
@@ -290,8 +338,9 @@ hexByte = do
|
||||
h1 <- hexDigit
|
||||
h2 <- hexDigit
|
||||
whiteSpace
|
||||
let [(v,"")] = readHex [h1,h2]
|
||||
return (fromIntegral v)
|
||||
case (readHex [h1,h2] :: [(Integer, String)]) of
|
||||
[(v,"")] -> return (fromIntegral v)
|
||||
_ -> fail "invalid hex byte"
|
||||
|
||||
-- Record pattern: ident { fields }
|
||||
recordPat :: Parser Pat
|
||||
@@ -303,17 +352,25 @@ recordPat = do
|
||||
fieldPat :: Parser FieldPat
|
||||
fieldPat = do
|
||||
n <- identifier
|
||||
try (reservedOp "=" >> FPEq n <$> literal)
|
||||
try (reservedOp "=" >> FPEq n <$> fieldLiteral)
|
||||
<|> try (reserved "as" >> FPAs n <$> identifier)
|
||||
<|> return (FPBind n)
|
||||
|
||||
-- Named pattern reference OR constructor: starts with uppercase-ish ident
|
||||
-- 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)
|
||||
|
||||
namedOrCtorPat :: Parser Pat
|
||||
namedOrCtorPat = do
|
||||
n <- identifier
|
||||
args <- optionMaybe (try (parens (commaSep pat)))
|
||||
case args of
|
||||
Nothing -> return (PNamed n) -- bare name = named pattern ref
|
||||
Nothing -> return $ if null n then PWild else if isUpper (head n) then PNamed n else PVar n
|
||||
Just ps -> return (PCtor n ps)
|
||||
|
||||
-- ─── Flow expressions ────────────────────────────────────────────────────────
|
||||
@@ -323,13 +380,17 @@ flowExpr = do
|
||||
first <- FAtom <$> identifier
|
||||
rest <- many (reservedOp "." >> identifier)
|
||||
mw <- optionMaybe (reserved "within" >> durationLit)
|
||||
return $ buildSeq (first : map FAtom rest) mw
|
||||
let chain = buildSeq (first : map FAtom rest)
|
||||
return $ case mw of
|
||||
Nothing -> chain
|
||||
Just w -> attach w chain
|
||||
where
|
||||
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"
|
||||
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)
|
||||
|
||||
durationLit :: Parser Duration
|
||||
durationLit = do
|
||||
@@ -518,7 +579,7 @@ mapEntry = do
|
||||
|
||||
literal :: Parser Literal
|
||||
literal
|
||||
= try cidrOrIpLit
|
||||
= try ipOrCidrLit
|
||||
<|> try hexLit
|
||||
<|> try (LBool True <$ reserved "true")
|
||||
<|> try (LBool False <$ reserved "false")
|
||||
@@ -528,26 +589,110 @@ literal
|
||||
hexLit :: Parser Literal
|
||||
hexLit = LHex <$> hexByte
|
||||
|
||||
cidrOrIpLit :: Parser Literal
|
||||
cidrOrIpLit = do
|
||||
a <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
b <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
c <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
d <- fromIntegral <$> natural
|
||||
whiteSpace
|
||||
-- ─── 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_
|
||||
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 <- cidrOrIpLit
|
||||
l <- ipOrCidrLit
|
||||
case l of
|
||||
LCIDR ip p -> return (ip, p)
|
||||
_ -> fail "expected CIDR notation"
|
||||
_ -> fail "expected CIDR notation (address/prefix)"
|
||||
|
||||
@@ -31,11 +31,22 @@ prettyDecl (DFlow n f) =
|
||||
prettyDecl (DRule n t e) =
|
||||
"rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";"
|
||||
prettyDecl (DPolicy n t pm ab) =
|
||||
"policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++
|
||||
" on { hook = " ++ prettyHook (pmHook pm) ++
|
||||
", table = " ++ prettyTable (pmTable pm) ++
|
||||
", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++
|
||||
"policy " ++ n ++ " : " ++ prettyType t ++
|
||||
" hook " ++ prettyHook (pmHook pm) ++
|
||||
(if pmPriority pm /= prettyDefaultPriority (pmHook pm)
|
||||
then " priority " ++ prettyNamedPriority (pmPriority pm)
|
||||
else "") ++ "\n" ++
|
||||
" = " ++ prettyArmBlock ab ++ ";"
|
||||
prettyDecl (DPortForward n iface t entries) =
|
||||
"portforward " ++ n ++ "\n" ++
|
||||
" on " ++ iface ++ "\n" ++
|
||||
" via " ++ prettyType t ++ " = {\n" ++
|
||||
concatMap (\(k,v) -> " " ++ prettyExpr k ++ " -> " ++ prettyExpr v ++ "\n") entries ++
|
||||
" };"
|
||||
prettyDecl (DMasquerade n iface srcSet) =
|
||||
"masquerade " ++ n ++ "\n" ++
|
||||
" on " ++ iface ++ "\n" ++
|
||||
" src " ++ srcSet ++ ";"
|
||||
|
||||
prettyKind :: IfaceKind -> String
|
||||
prettyKind IWan = "WAN"
|
||||
@@ -49,8 +60,6 @@ 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
|
||||
@@ -60,16 +69,24 @@ prettyHook HOutput = "Output"
|
||||
prettyHook HPrerouting = "Prerouting"
|
||||
prettyHook HPostrouting = "Postrouting"
|
||||
|
||||
prettyTable :: TableName -> String
|
||||
prettyTable TFilter = "Filter"
|
||||
prettyTable TNAT = "NAT"
|
||||
-- | Default priority for a hook (for round-trip: omit when at default)
|
||||
prettyDefaultPriority :: Hook -> Priority
|
||||
prettyDefaultPriority HInput = pFilter
|
||||
prettyDefaultPriority HForward = pFilter
|
||||
prettyDefaultPriority HOutput = pFilter
|
||||
prettyDefaultPriority HPrerouting = pDstNat
|
||||
prettyDefaultPriority HPostrouting = pSrcNat
|
||||
|
||||
prettyPriority :: Priority -> String
|
||||
prettyPriority PFilter = "Filter"
|
||||
prettyPriority PDstNat = "DstNat"
|
||||
prettyPriority PSrcNat = "SrcNat"
|
||||
prettyPriority PMangle = "Mangle"
|
||||
prettyPriority (PInt n)= show n
|
||||
-- | Emit a named priority constant when possible, otherwise decimal
|
||||
prettyNamedPriority :: Priority -> String
|
||||
prettyNamedPriority p
|
||||
| p == pFilter = "Filter"
|
||||
| p == pDstNat = "DstNat"
|
||||
| p == pSrcNat = "SrcNat"
|
||||
| p == pMangle = "Mangle"
|
||||
| p == pRaw = "Raw"
|
||||
| p == pConnTrack= "ConnTrack"
|
||||
| otherwise = show (priorityValue p)
|
||||
|
||||
prettyType :: Type -> String
|
||||
prettyType (TName n []) = n
|
||||
@@ -88,6 +105,7 @@ prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
|
||||
prettyPat (PFrame mp inner)=
|
||||
"Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")"
|
||||
prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]"
|
||||
prettyPat (POr p1 p2) = prettyPat p1 ++ " | " ++ prettyPat p2
|
||||
|
||||
prettyFP :: FieldPat -> String
|
||||
prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l
|
||||
@@ -182,9 +200,8 @@ prettyLit (LInt n) = show n
|
||||
prettyLit (LString s) = "\"" ++ s ++ "\""
|
||||
prettyLit (LBool True) = "true"
|
||||
prettyLit (LBool False) = "false"
|
||||
prettyLit (LIPv4 (a,b,c,d)) =
|
||||
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d
|
||||
prettyLit (LIPv6 _) = "<ipv6>"
|
||||
prettyLit (LIP IPv4 n) = renderIPv4 n
|
||||
prettyLit (LIP IPv6 n) = renderIPv6 n
|
||||
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
Normal file
210
test/CheckTests.hs
Normal file
@@ -0,0 +1,210 @@
|
||||
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
Normal file
457
test/CompileTests.hs
Normal file
@@ -0,0 +1,457 @@
|
||||
{-# 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
Normal file
44
test/FWL/Util.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
-- | 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
Normal file
550
test/ParserTests.hs
Normal file
@@ -0,0 +1,550 @@
|
||||
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
Normal file
15
test/Spec.hs
Normal file
@@ -0,0 +1,15 @@
|
||||
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
|
||||
]
|
||||
Reference in New Issue
Block a user