Compare commits

..

12 Commits

Author SHA1 Message Date
9390647f7a add more ruleset examples 2026-05-04 01:47:10 -07:00
25f95996fb I don't even know rn 2026-05-04 01:44:11 -07:00
d79206440a stupid compilation 2026-05-04 00:41:52 -07:00
d136bd62f7 more compiler fixes 2026-05-04 00:14:47 -07:00
8a508ad7cc gemini fixes nft json compilation 2026-05-03 19:01:02 -07:00
d01be7bc23 gemini fix checker 2026-05-03 18:29:09 -07:00
2705f18e0f gemini fixes 2026-05-03 18:15:59 -07:00
a0632d5263 add AGENTS.md 2026-05-03 17:54:46 -07:00
2a44095791 v2 perplexed 2026-05-03 17:46:52 -07:00
30427521ca grammar doc updates 2026-05-03 17:45:40 -07:00
23ce29aece add agents rule file for docs 2026-05-03 14:47:18 -07:00
778cf13c40 add dist-newstyle to gitignore 2026-05-03 14:47:05 -07:00
22 changed files with 4269 additions and 821 deletions

166
AGENTS.md Normal file
View File

@@ -0,0 +1,166 @@
# 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/router.fwl # parse + type-check a source file
cabal run fwlc -- compile examples/router.fwl # emit nftables JSON to stdout
cabal run fwlc -- pretty examples/router.fwl # pretty-print the parsed AST
```
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/
│ └── router.fwl ← canonical example; must parse and compile cleanly
├── 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 `docs/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.
---
## 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.
---
## 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`.
---
## 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.
---
## Boundaries
### ✅ Safe to do without asking
- Read any file, list directories
- Run `cabal build`, `cabal test`, `cabal run fwlc`
- Edit `src/`, `test/`, `examples/`, `docs/`
- Add new test cases to existing test files
### ⚠️ Ask first
- Add or remove Cabal dependencies (`fwl.cabal`)
- Rename or delete source modules
- Change the nftables JSON schema emitted by `Compile.hs`
- Modify `examples/router.fwl` in ways that change its semantics
### 🚫 Never
- Add semantic value names (`Allow`, `Drop`, `Log`, etc.) to `reservedNames`
- Break the `cabal test` suite
- Emit nftables `"prio"` as a string — it must always be an integer

View File

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

View File

@@ -1,49 +1,27 @@
# FWL Grammar Specification (MVP) # FWL Grammar Specification
## Overview > **Version:** MVP
> **Last updated:** May 2026
FWL is a typed, functional DSL that compiles to nftables JSON. Programs are > This document is the authoritative grammar reference for the Firewall Language (FWL).
sequences of top-level declarations. The grammar uses explicit braces and > It supersedes the syntax examples in `proposal.md` and reflects the current parser implementation.
semicolons throughout — no indentation sensitivity. Types are mandatory on all
top-level declarations for MVP; inference is deferred to a later version.
The target nftables table is a single table named `fwl` by default
(configurable via a top-level `config` declaration). Both filter and NAT
policies compile into this one table.
--- ---
## Notation ## Design Principles
``` - **Explicit delimiters everywhere** — all blocks use `{` `}` with trailing `;` on each item. No layout/indentation sensitivity.
::= production - **Syntactic keywords are reserved** — only words that structurally delimit declarations or expressions are in `reservedNames`. Semantic values (action names, effect labels, constructors) are plain identifiers.
| alternative - **Types are explicit** — top-level declarations carry full type annotations in the MVP.
{ x } zero or more repetitions of x - **Patterns vs. guards are strictly separated** — structural decomposition happens in patterns; boolean predicates over bound names happen in guards.
[ x ] optional x - **IP addresses are integers** — IPv4 is a 32-bit value; IPv6 is a 128-bit value. Named priority constants (`Filter`, `SrcNat`, etc.) lower to their canonical integer values at parse time.
```
String terminals are written in `"double quotes"`. Regex-like character classes
use `[a-z]`, etc.
--- ---
## Top-Level Structure ## Top-Level Program
```ebnf ```ebnf
program ::= { config } { decl } program ::= { decl }
config ::= "config" "{" { configProp ";" } "}"
configProp ::= "table" "=" stringLit
```
Every non-`config` declaration is terminated by `";"`.
---
## Declarations
```ebnf
decl ::= interfaceDecl decl ::= interfaceDecl
| zoneDecl | zoneDecl
| importDecl | importDecl
@@ -54,7 +32,9 @@ decl ::= interfaceDecl
| policyDecl | policyDecl
``` ```
### Interface ---
## Declarations
```ebnf ```ebnf
interfaceDecl ::= "interface" ident ":" ifaceKind "{" { ifaceProp ";" } "}" ";" interfaceDecl ::= "interface" ident ":" ifaceKind "{" { ifaceProp ";" } "}" ";"
@@ -66,429 +46,324 @@ ifaceProp ::= "dynamic"
| "cidr6" "=" cidrSet | "cidr6" "=" cidrSet
cidrSet ::= "{" cidrLit { "," cidrLit } "}" cidrSet ::= "{" cidrLit { "," cidrLit } "}"
```
### Zone
```ebnf
zoneDecl ::= "zone" ident "=" "{" ident { "," ident } "}" ";" zoneDecl ::= "zone" ident "=" "{" ident { "," ident } "}" ";"
```
### Import
```ebnf
importDecl ::= "import" ident ":" type "from" stringLit ";" importDecl ::= "import" ident ":" type "from" stringLit ";"
```
### Let
```ebnf
letDecl ::= "let" ident ":" type "=" expr ";" letDecl ::= "let" ident ":" type "=" expr ";"
```
### Pattern patternDecl ::= "pattern" ident ":" type "=" pat ";"
Named patterns are first-class; they may appear anywhere a structural pattern
appears, including nested inside constructor patterns, `Frame(...)`, and other
named patterns.
```ebnf
patternDecl ::= "pattern" ident ":" type "=" packetPat ";"
```
Named patterns are resolved during type-checking, not by macro-expanding at
parse time. Recursive named patterns are a type error.
### Flow
```ebnf
flowDecl ::= "flow" ident ":" "FlowPattern" "=" flowExpr ";" flowDecl ::= "flow" ident ":" "FlowPattern" "=" flowExpr ";"
flowExpr ::= ident
| ident "." ident "within" duration
flowExpr ::= seqExpr
seqExpr ::= flowAtom
| flowAtom "." seqExpr
| flowAtom "." seqExpr "within" duration
```
A `within` clause applies to the entire sequence to its left and binds most
tightly to the innermost `.`. For MVP, `within` is only valid at the top level
of a `flowExpr`.
```ebnf
flowAtom ::= ident
```
### Rule
Rules are reusable, named packet-processing functions. They receive a `Frame`
and return an `Action` (possibly via effects).
```ebnf
ruleDecl ::= "rule" ident ":" type "=" lambdaExpr ";" ruleDecl ::= "rule" ident ":" type "=" lambdaExpr ";"
lambdaExpr ::= "\" ident "->" expr
```
A `rule` body must be a lambda at the top level for MVP.
### Policy
Policies are the entry points tied to nftables hooks. A policy body is a
bare arm-block (no `case ... of` wrapper; the matched value is always the
bound `Frame`-like parameter of the policy).
```ebnf
policyDecl ::= "policy" ident ":" type policyDecl ::= "policy" ident ":" type
"on" "{" hookSpec "}" "on" "{"
"hook" "=" hook ","
"table" "=" tableName ","
"priority" "=" priority
"}"
"=" armBlock ";" "=" armBlock ";"
```
hookSpec ::= hookProp "," hookProp "," hookProp ### Policy Metadata
| hookProp "," hookProp "," hookProp "," -- trailing comma OK
hookProp ::= "hook" "=" hook
| "table" "=" tableName
| "priority" "=" priority
```ebnf
hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting" hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting"
tableName ::= "Filter" | "NAT"
priority ::= "Filter" | "DstNat" | "SrcNat" | "Mangle" | intLit tableName ::= "Filter" | "NAT" | ident
-- Priority is always an integer in nftables JSON.
-- Named constants are resolved at parse time:
-- Raw = -300, ConnTrack = -200, Mangle = -150,
-- DstNat = -100, Filter = 0, SrcNat = 100
priority ::= "Filter" | "DstNat" | "SrcNat" | "Mangle"
| "Raw" | "ConnTrack"
| [ "-" ] nat
``` ```
--- ---
## Arm Blocks
Used uniformly inside `rule` bodies (via `case`) and `policy` bodies.
```ebnf
armBlock ::= "{" { arm } "}"
arm ::= "|" pat guardOpt "->" expr ";"
guardOpt ::= ε
| "if" expr
```
---
## Patterns
Patterns describe packet structure and bind names. All membership/comparison
predicates are guards (see § Expressions), not patterns — except for field
constraints inside record patterns, which are written as field predicates.
```ebnf
pat ::= "_" -- wildcard
| ident -- variable binding
| namedPat -- first-class named pattern
| ctorPat -- e.g., IPv4(ip, ...)
| recordPat -- e.g., tcp { dport = :22 }
| tuplePat -- e.g., (udp, payload)
| framePat -- Frame(path, inner)
| bytePat -- e.g., [0x01 _*]
-- A named pattern reference; resolved at type-check time.
-- Binds NO additional names itself (names are bound in the pattern's definition).
namedPat ::= ident -- must refer to a declared pattern
ctorPat ::= ident "(" patList ")"
patList ::= pat { "," pat }
recordPat ::= ident "{" [ fieldPatList ] "}"
fieldPatList::= fieldPat { "," fieldPat }
fieldPat ::= ident "=" literal -- equality constraint
| ident -- bind field to same-named variable
| ident "as" ident -- bind field to fresh variable
tuplePat ::= "(" pat { "," pat } ")"
-- Frame pattern: optional interface-path specifier, then inner packet pattern.
framePat ::= "Frame" "(" [ pathPat "," ] pat ")"
-- Interface-path: source, destination, or both.
pathPat ::= endpointPat
| endpointPat "->" endpointPat
endpointPat ::= "_"
| ident -- exact interface name
| ident "in" ident -- interface is member of zone
```
**Note on `∈`:** the parser accepts both the Unicode `∈` and the ASCII keyword
`in` as synonyms in all positions. The AST stores a single `MemberOf`
constructor.
### Byte Patterns
Used in `pattern` declarations for payload matching.
```ebnf
bytePat ::= "[" { byteElem } "]"
byteElem ::= hexByte -- e.g., 0x01
| "_" -- any single byte
| "_*" -- zero or more bytes
```
---
## Expressions
```ebnf
expr ::= letExpr
| ifExpr
| doExpr
| caseExpr
| infixExpr
letExpr ::= "let" ident "=" expr "in" expr
ifExpr ::= "if" expr "then" expr "else" expr
doExpr ::= "do" "{" doStmt { ";" doStmt } "}"
doStmt ::= ident "<-" expr -- effectful bind
| expr -- effectful sequence
caseExpr ::= "case" expr "of" armBlock
infixExpr ::= prefixExpr { infixOp prefixExpr }
prefixExpr ::= appExpr
| "!" prefixExpr
appExpr ::= atom { atom } -- function application
atom ::= ident
| qualName
| literal
| tupleLit
| setLit
| mapLit
| performExpr
| "(" expr ")"
performExpr ::= "perform" qualName "(" [ argList ] ")"
tupleLit ::= "(" expr "," expr { "," expr } ")"
setLit ::= "{" [ expr { "," expr } ] "}"
mapLit ::= "{" mapEntry { "," mapEntry } "}"
mapEntry ::= expr "->" expr
argList ::= expr { "," expr }
qualName ::= ident { "." ident }
infixOp ::= "&&" | "||"
| "==" | "!=" | "<" | "<=" | ">" | ">="
| "in" | "∈" -- set/zone membership
| "++" -- string/list concat
| ">>" -- effect sequencing
| ">>=" -- monadic bind
```
**Operator precedence** (high to low):
| Level | Operators | Assoc |
|-------|-----------------------|-------|
| 7 | application | left |
| 6 | `==` `!=` `<` `<=` `>` `>=` `in` `∈` | none |
| 5 | `&&` | right |
| 4 | `\|\|` | right |
| 3 | `++` | right |
| 2 | `>>=` | left |
| 1 | `>>` | left |
---
## Types ## Types
```ebnf ```ebnf
type ::= funType type ::= simpleType
| simpleType "->" type -- function type
| "<" effectList ">" type -- effectful function type
funType ::= effectType simpleType ::= ident -- type name (Frame, Action, IP, etc.)
| effectType "->" funType | ident "<" typeList ">" -- generic: Map<K,V>, Bytes<{}>
effectType ::= "<" [ ident { "," ident } ] ">" simpleType
| simpleType
simpleType ::= ident [ "<" typeList ">" ] -- parameterised type
| "(" type { "," type } ")" -- tuple type | "(" type { "," type } ")" -- tuple type
| "(" type ")" -- grouped
typeList ::= type { "," type } typeList ::= type { "," type }
effectList ::= ident { "," ident }
``` ```
Effect rows use angle brackets: `<FlowMatch, Log> Action`. > **Note:** `Frame`, `FlowPattern`, and all action/effect type names (`Action`, `CIDRSet`, etc.)
> are plain identifiers in the type parser — they are **not** reserved keywords.
For MVP, effect annotations are required on `rule` declarations that contain
`perform` expressions and are optional on `policy` declarations.
--- ---
## Actions ## Expressions
`Action` is a built-in type. Its constructors are:
```ebnf ```ebnf
action ::= "Allow" lambdaExpr ::= "\" ident "->" expr
| "Drop" | expr
| "Continue"
| "Masquerade"
| "DNAT" "(" expr ")"
| "DNATMap" "(" expr ")"
| "Log" "(" logLevel "," expr ")"
logLevel ::= "Info" | "Warn" | "Error" expr ::= ifExpr
| doExpr
| infixExpr
ifExpr ::= "if" expr "then" expr "else" expr
doExpr ::= "do" "{" stmt { ";" stmt } "}"
stmt ::= "let" ident "=" expr
| ident "<-" expr
| expr
infixExpr ::= prefixExpr { infixOp prefixExpr }
infixOp ::= "&&" | "||" | "==" | "!=" | "<" | "<=" | ">" | ">="
| "++" | ">>" | ">>=" | "∈" | "in"
prefixExpr ::= "!" prefixExpr | appExpr
appExpr ::= atom { atom }
atom ::= performExpr
| mapLit -- { expr -> expr, ... } tried before setLit
| setLit -- { expr, ... }
| tupleLit -- ( expr, expr, ... ) requires 2
| "(" expr ")"
| literal
| portLit -- :22 :8080
| qualName -- foo foo.bar foo.bar.baz
performExpr ::= "perform" qualName "(" argList? ")"
argList ::= expr { "," expr }
mapLit ::= "{" mapEntry { "," mapEntry } "}"
mapEntry ::= expr "->" expr
setLit ::= "{" expr { "," expr } "}"
tupleLit ::= "(" expr "," expr { "," expr } ")"
qualName ::= ident { "." ident }
``` ```
`Continue` is a legal action value and compiles to nothing (a no-op pass-
through). It is used to make exhaustive arm blocks typecheck when earlier arms
handle all interesting cases. A policy arm that returns `Continue` as the last
arm is a type error (unreachable or missing terminator); a `rule` arm may
return `Continue` to signal "pass control back to the caller."
--- ---
## Effects ## Patterns
The built-in effects available for MVP are: ```ebnf
pat ::= wildcardPat -- _
| framePat -- Frame(...)
| tuplePat -- (p, p, ...) requires 2
| bytesPat -- [ byteElem* ]
| recordPat -- Ctor { field = lit, ... }
| namedOrCtorPat -- Ctor(p,...) or bare identifier
| pat "|" pat -- Or-pattern
| Effect | Operations | wildcardPat ::= "_"
|------------|---------------------------------------------------| framePat ::= "Frame" "(" frameArgs ")"
| `FlowMatch`| `FlowMatch.check(flowId, pattern) : MatchResult` | frameArgs ::= pathPat "," pat -- with explicit path
| `Log` | `Log.emit(level, msg) : ()` | | pat -- path inferred
| `FIB` | `FIB.daddrLocal(ip) : Bool` |
`MatchResult` constructors: `Matched`, `Unmatched`. pathPat ::= endpointPat? ( "->" endpointPat? )?
endpointPat ::= "_"
| ident "in" ident -- iif in lan_zone
| ident "∈" ident
| ident
Additional effects may be declared by the user in a future version. tuplePat ::= "(" pat "," pat { "," pat } ")"
bytesPat ::= "[" byteElem* "]"
byteElem ::= hexByte -- 0xff
| "_" -- any byte
| "_" "*" -- zero or more bytes
recordPat ::= ident "{" fieldPat { "," fieldPat } "}"
fieldPat ::= ident "=" fieldLit -- exact match
| ident "in" expr -- membership
| ident "∈" expr
| ident "as" ident -- bind with alias
| ident -- bind to same name
-- fieldLit extends literal with port syntax
fieldLit ::= ":" nat | literal
namedOrCtorPat ::= ident "(" pat { "," pat } ")" -- constructor with args
| ident -- variable or nullary ctor
```
---
## Case Arms
```ebnf
armBlock ::= "{" { arm } "}"
arm ::= "|" pat ( "if" expr )? "->" expr ";"
```
--- ---
## Literals ## Literals
```ebnf ```ebnf
literal ::= intLit literal ::= ipOrCidrLit
| stringLit | hexByte -- 0xff
| boolLit
| ipv4Lit
| ipv6Lit
| cidrLit
| portLit
| durationLit
| hexByte
intLit ::= ["-"] digit+
stringLit ::= '"' { strChar } '"'
boolLit ::= "true" | "false"
ipv4Lit ::= octet "." octet "." octet "." octet
ipv6Lit ::= -- standard IPv6 notation including "::" compression
cidrLit ::= (ipv4Lit | ipv6Lit) "/" digit+
portLit ::= ":" digit+ -- e.g., :22, :8080
durationLit ::= digit+ timeUnit
timeUnit ::= "s" | "ms" | "m" | "h"
hexByte ::= "0x" hexDigit hexDigit
octet ::= digit+ -- 0-255
```
---
## Lexical Rules
```ebnf
ident ::= letter { letter | digit | "_" }
-- must not be a reserved word
reserved ::= "config" | "interface" | "zone" | "import" | "let" | "in"
| "pattern" | "flow" | "rule" | "policy" | "on"
| "case" | "of" | "if" | "then" | "else" | "do"
| "perform" | "within" | "as"
| "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"
| "dynamic" | "cidr4" | "cidr6" | "table" | "hook" | "priority"
| "true" | "false" | "true" | "false"
| "FlowPattern" | "Frame" | stringLit -- "..."
| nat -- decimal integer
comment ::= "--" { any char except newline } portLit ::= ":" nat -- :22, :8080, :51944
| "{-" { any char } "-}"
whitespace ::= space | tab | newline | comment ipOrCidrLit ::= ipLit ( "/" nat )? -- optional prefix → CIDR
ipLit ::= ipv6Lit | ipv4Lit
-- IPv4: four decimal octets 0-255
ipv4Lit ::= octet "." octet "." octet "." octet
octet ::= nat -- 0..255
-- IPv6: full or compressed notation, optional embedded IPv4
-- All standard forms are supported:
-- full: 2001:0db8:85a3:0000:0000:8a2e:0370:7334
-- compressed: 2001:db8::8a2e:370:7334
-- loopback: ::1
-- any: ::
-- link-local: fe80::1
-- IPv4-mapped: ::ffff:192.168.1.1
ipv6Lit ::= ipv6Groups
ipv6Groups ::= "::" ipv6RightGroups? -- starts with ::
| ipv6LeftGroups ( "::" ipv6RightGroups? )?
ipv6LeftGroups ::= hex16 { ":" hex16 } -- stops before ::
ipv6RightGroups ::= ipv4EmbeddedGroups | ipv6LeftGroups
ipv4EmbeddedGroups ::= { hex16 ":" } octet "." octet "." octet "." octet
hex16 ::= hexDigit+ -- 1-4 hex digits, value 0x0000..0xffff
cidrLit ::= ipLit "/" nat -- must be a CIDR (prefix required)
hexByte ::= "0x" hexDigit hexDigit
duration ::= nat timeUnit
timeUnit ::= "s" | "ms" | "m" | "h"
``` ```
Identifiers beginning with an uppercase letter are treated as constructor ### Internal IP Representation
names by convention; those beginning with lowercase are variables. The lexer
does not enforce this — it is a naming convention only, checked during IP addresses are stored as plain `Integer` values, not tuples or byte arrays:
type-checking.
| Type | Storage | Range |
|-------|----------|------------------|
| IPv4 | 32-bit `Integer` | `0x00000000`..`0xFFFFFFFF` |
| IPv6 | 128-bit `Integer` | `0x0`..`0xFFFF...FFFF` |
CIDR host-bit validation: `(addr .&. hostMask) == 0` where `hostMask = (1 << (bits - prefix)) - 1`.
--- ---
## Resolved Inconsistencies from Proposal ## Reserved Keywords
The following decisions were made to normalize the proposal's syntax: Only these words are reserved (i.e. `identifier` will reject them):
| Topic | Proposal state | MVP decision | ```
|-------|---------------|--------------| config table interface zone import from
| Interface body | Multiline, no delimiters | Braced block with `;` separators | let in pattern flow rule policy on
| Policy body | `where` with indented arms | `=` followed by arm-block | case of if then else do perform
| Rule body | `\frame -> case frame of \| ...` | `\ident -> expr`; `case` is a normal expression | within as dynamic cidr4 cidr6
| Policy vs rule | Distinct surface syntax | Policies use a bare arm-block; rules use `case` explicitly | hook priority
| `Frame<{}>` | Unclear `<{}>` parameter | Parsed but ignored for MVP; written as `Frame` in practice | WAN LAN WireGuard
| Named patterns in sub-positions | Unclear | First-class everywhere; resolved at type-check time | Input Forward Output Prerouting Postrouting
| `∈` operator | Unicode only | Both `∈` and `in` accepted everywhere | Filter NAT Mangle DstNat SrcNat
| `Continue` | Unclear semantics | Legal `Action` constructor; compiles to nothing; type error if last arm of a policy block | Raw ConnTrack
| Single nftables table | Not specified | Default table name `fwl`; configurable via `config { table = "name"; }` | true false
| `handle` syntax | Mentioned but unspecified | Deferred; MVP only has `perform` | ```
| Effect annotations | Inconsistent (`<>` vs `{}`) | Angle brackets `<Eff1, Eff2>` everywhere |
| Guard vs pattern membership | Mixed | Structural matching in patterns only; `in`/`∈` in guards only (except `fieldPat`) | The following are **not** reserved and parse as plain identifiers in all positions
(type names, constructors, action values, effect labels):
```
Frame FlowPattern
Allow Drop Continue Masquerade DNAT DNATMap
Log Info Warn Error
Matched Unmatched
Action Packet IP Port Protocol
CIDRSet Map Bytes
```
---
## Priority Constants
Named priorities resolve to integers at parse time:
| Name | Integer value |
|-------------|---------------|
| `Raw` | -300 |
| `ConnTrack` | -200 |
| `Mangle` | -150 |
| `DstNat` | -100 |
| `Filter` | 0 |
| `SrcNat` | 100 |
Arbitrary integers (including negative, e.g. `-150`) are also accepted.
---
## Operator Precedence
From lowest to highest binding:
| Level | Operators | Associativity |
|-------|------------------------|---------------|
| 1 | `if … then … else` | — |
| 2 | `\|\|` | left |
| 3 | `&&` | left |
| 4 | `==` `!=` | none |
| 5 | `<` `<=` `>` `>=` | none |
| 6 | `∈` `in` | none |
| 7 | `++` `>>` `>>=` | left |
| 8 | `!` (prefix) | — |
| 9 | function application | left |
--- ---
## Canonical Examples ## Canonical Examples
The following examples must all parse under the grammar above. ### Interface and zone declarations
### 1. Interface and Zone
```fwl ```fwl
interface wan : WAN { dynamic; }; interface wan : WAN { dynamic; };
interface lan : LAN { interface lan : LAN { cidr4 = { 10.17.1.0/24 }; };
cidr4 = { 10.17.1.0/24 };
cidr6 = { fe80::/10, fd12:3456::/48 };
};
interface wg0 : WireGuard {}; interface wg0 : WireGuard {};
zone lan_zone = { lan, wg0 }; zone lan_zone = { lan, wg0 };
``` ```
### 2. Import and Let ### Map literal
```fwl ```fwl
import rfc1918 : CIDRSet from "builtin:rfc1918";
let forwards : Map<(Protocol, Port), (IP, Port)> = { let forwards : Map<(Protocol, Port), (IP, Port)> = {
(tcp, :8080) -> (10.17.1.10, :80), (tcp, :8080) -> (10.17.1.10, :80),
(tcp, :2222) -> (10.17.1.11, :22) (tcp, :2222) -> (10.17.1.11, :22)
}; };
``` ```
### 3. Pattern and Flow ### Named patterns and flows
```fwl ```fwl
pattern WGInitiation : (UDPHeader, Bytes) = pattern WGInitiation : (UDPHeader, Bytes<{}>) =
(udp { length = 156 }, [0x01 _*]); (udp { length = 156 }, [0x01 _*]);
pattern WGResponse : (UDPHeader, Bytes) =
(udp { length = 100 }, [0x02 _*]);
flow WireGuardHandshake : FlowPattern = flow WireGuardHandshake : FlowPattern =
WGInitiation . WGResponse within 5s; WGInitiation . WGResponse within 5s;
``` ```
### 4. Rule with Effects ### Rule with effects
```fwl ```fwl
rule blockOutboundWG : Frame -> <FlowMatch, Log> Action = rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
@@ -497,9 +372,8 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
| Frame(iif in lan_zone -> wan, IPv4(ip, UDP(udp, payload))) | Frame(iif in lan_zone -> wan, IPv4(ip, UDP(udp, payload)))
if matches(WGInitiation, (udp, payload)) -> if matches(WGInitiation, (udp, payload)) ->
case perform FlowMatch.check(flowOf(ip, wg), WireGuardHandshake) of { case perform FlowMatch.check(flowOf(ip, wg), WireGuardHandshake) of {
| Matched -> | Matched -> do {
do { perform Log.emit(Warn, "WG blocked");
perform Log.emit(Warn, "WG blocked: " ++ show(ip.src));
Drop Drop
}; };
| _ -> Continue; | _ -> Continue;
@@ -508,190 +382,18 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
}; };
``` ```
### 5. Filter Policy ### Policy
```fwl ```fwl
policy input : Frame policy input : Frame
on { hook = Input, table = Filter, priority = Filter } on { hook = Input, table = Filter, priority = Filter } =
= { {
| _ if ct.state in { Established, Related } -> Allow; | _ if ct.state in { Established, Related } -> Allow;
| Frame(lo, _) -> Allow; | Frame(lo, _) -> Allow;
| Frame(_, IPv6(ip6, ICMPv6(_, _))) | Frame(_, Ether(_, IPv4(_, TCP(tcp, _))))
if ip6.src in fe80::/10 -> Allow;
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport == :22 -> Allow; if tcp.dport == :22 -> Allow;
| Frame(_, IPv4(_, UDP(udp, _))) | Frame(_, Ether(_, IPv4(_, UDP(udp, _))))
if udp.dport == :51944 -> Allow; if udp.dport == :51944 -> Allow;
| _ -> Drop; | _ -> Drop;
}; };
``` ```
### 6. NAT Policy
```fwl
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, _)) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap(forwards)
else Allow;
| _ -> Allow;
};
policy nat_postrouting : Frame
on { hook = Postrouting, table = NAT, priority = SrcNat }
= {
| Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade;
| _ -> Allow;
};
```
### 7. Forward Policy calling a Rule
```fwl
policy forward : Frame
on { hook = Forward, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame);
| _ if ct.status == DNAT -> Allow;
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| Frame(wan -> lan_zone, IPv4(ip, TCP(tcp, _)))
if (ip.dst, tcp.dport) in forwards -> Allow;
| _ -> Drop;
};
```
---
## Haskell AST Sketch
The following gives the direct mapping from grammar to Haskell types.
```haskell
-- src/FWL/AST.hs
data Program = Program [Config] [Decl]
data Config = Config { configTable :: Maybe String }
data Decl
= DInterface Name IfaceKind [IfaceProp]
| DZone Name [Name]
| DImport Name Type String
| DLet Name Type Expr
| DPattern Name Type PacketPat
| DFlow Name FlowExpr
| DRule Name Type Expr -- expr must be LamExpr
| DPolicy Name Type PolicyMeta ArmBlock
data PolicyMeta = PolicyMeta
{ pmHook :: Hook
, pmTable :: TableName
, pmPriority :: Priority }
data Hook = Input | Forward | Output | Prerouting | Postrouting
data TableName= Filter | NAT
data Priority = PFilter | PDstNat | PSrcNat | PMangle | PInt Int
data IfaceKind = WAN | LAN | WireGuard | IKUser Name
data IfaceProp = IPDynamic | IPCidr4 [CIDR] | IPCidr6 [CIDR]
-- Patterns
data Pat
= PWild
| PVar Name
| PNamed Name -- named pattern reference (first-class)
| PCtor Name [Pat]
| PRecord Name [FieldPat]
| PTuple [Pat]
| PFrame (Maybe PathPat) Pat
| PBytes [ByteElem]
data FieldPat
= FPEq Name Literal
| FPBind Name -- bind field to same-named var
| FPAs Name Name -- bind field to fresh var
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
data EndpointPat
= EPWild
| EPName Name
| EPMember Name Name -- iif `in` zoneName
data ByteElem = BEHex Word8 | BEWild | BEWildStar
-- Flow
data FlowExpr
= FAtom Name
| FSeq FlowExpr FlowExpr (Maybe Duration)
type Duration = (Int, TimeUnit)
data TimeUnit = Seconds | Millis | Minutes | Hours
-- Types
data Type
= TName Name [Type]
| TTuple [Type]
| TFun Type Type
| TEffect [Name] Type
-- Expressions
data Expr
= EVar Name
| EQual [Name]
| ELit Literal
| ELam Name Expr
| EApp Expr Expr
| ECase Expr ArmBlock
| EIf Expr Expr Expr
| EDo [DoStmt]
| ELet Name Expr Expr
| ETuple [Expr]
| ESet [Expr]
| EMap [(Expr, Expr)]
| EPerform [Name] [Expr] -- perform QualName(args)
| EInfix InfixOp Expr Expr
| EPrefix PrefixOp Expr
data InfixOp
= OpAnd | OpOr | OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
| OpIn | OpConcat | OpThen | OpBind
data PrefixOp = OpNot
data DoStmt
= DSBind Name Expr
| DSExpr Expr
type ArmBlock = [Arm]
data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard, body
-- Actions (constructors of the Action type; parsed as Expr constructors)
-- Allow | Drop | Continue | Masquerade
-- | DNAT Expr | DNATMap Expr | Log LogLevel Expr
data LogLevel = LInfo | LWarn | LError
-- Literals
data Literal
= LInt Int
| LString String
| LBool Bool
| LIPv4 (Word8,Word8,Word8,Word8)
| LIPv6 [Word16]
| LCIDR Literal Int
| LPort Int
| LDuration Int TimeUnit
| LHex Word8
type Name = String
type CIDR = (Literal, Int)
```

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
View File

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

95
examples/router.fwl Normal file
View File

@@ -0,0 +1,95 @@
-- 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 forwards : Map<(Protocol, Port), (IP, Port)> = {
(tcp, :8080) -> (10.17.1.10, :80),
(tcp, :2222) -> (10.17.1.11, :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;
};
-- Inbound to router
policy input : Frame
on { hook = Input, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| Frame(lo, _) -> Allow;
| Frame(_, IPv6(ip6, ICMPv6(_, _)))
if ip6.src in fe80::/10 -> Allow;
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport == :22 -> Allow;
| Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
-- Forwarded traffic
policy forward : Frame
on { hook = Forward, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame);
| _ if ct.status == DNAT -> Allow;
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(iif in lan_zone -> lan_zone, _) -> Allow;
| Frame(wan -> lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _)))
if (ip.protocol, th.dport) in forwards -> Allow;
| _ -> Drop;
};
-- Outbound from router
policy output : Frame
on { hook = Output, table = Filter, priority = Filter }
= {
| _ -> Allow;
};
-- NAT
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap((ip.protocol, th.dport), forwards)
else Allow;
| _ -> Allow;
};
policy nat_postrouting : Frame
on { hook = Postrouting, table = NAT, priority = SrcNat }
= {
| Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade;
| _ -> Allow;
};

View File

@@ -0,0 +1,69 @@
interface wan : WAN { dynamic; };
interface lan : LAN { cidr4 = { 10.0.0.0/24 }; };
zone lan_zone = { lan };
let rfc1918 : Set<IPv4> = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 };
-- Single IPv4 port forward: tcp:8080 -> 10.0.0.10:80
let forwards : Map<(Protocol, Port), (IP, Port)> = {
(tcp, :8080) -> (10.0.0.10, :80)
};
-- Open inbound ports on the router itself
let open_ports : Set<Port> = { :22 };
-- IPv6 forwarded destination: tcp . 2001:db8::1 . 22000
let forwards_v6 : Set<(Protocol, IP, Port)> = {
(tcp, 2001:db8::1, :22000)
};
policy input : Frame
on { hook = Input, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| Frame(lo, _) -> Allow;
| Frame(_, IPv6(ip6, ICMPv6(_, _)))
if ip6.src in fe80::/10 -> Allow;
| Frame(_, IPv4(_, TCP(tcp, _)))
if tcp.dport in open_ports -> Allow;
| Frame(_, IPv4(_, UDP(udp, _)))
if udp.dport == :51944 -> Allow;
| _ -> Drop;
};
policy forward : Frame
on { hook = Forward, table = Filter, priority = Filter }
= {
| _ if ct.state in { Established, Related } -> Allow;
| _ if ct.status == DNAT -> Allow;
| Frame(iif in lan_zone -> wan, _) -> Allow;
| Frame(wan -> iif in lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _)))
if (ip.protocol, th.dport) in forwards -> Allow;
| Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _)))
if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow;
| _ -> Drop;
};
policy output : Frame
on { hook = Output, table = Filter, priority = Filter }
= {
| _ -> Allow;
};
policy nat_prerouting : Frame
on { hook = Prerouting, table = NAT, priority = DstNat }
= {
| Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) ->
if perform FIB.daddrLocal(ip.dst)
then DNATMap((ip.protocol, th.dport), forwards)
else Allow;
| _ -> Allow;
};
policy nat_postrouting : Frame
on { hook = Postrouting, table = NAT, priority = SrcNat }
= {
| Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade;
| _ -> Allow;
};

View File

@@ -0,0 +1,955 @@
{
"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": "output",
"name": "output",
"policy": "accept",
"prio": 0,
"table": "fwl",
"type": "filter"
}
},
{
"chain": {
"family": "inet",
"hook": "prerouting",
"name": "nat_prerouting",
"policy": "accept",
"prio": -100,
"table": "fwl",
"type": "nat"
}
},
{
"chain": {
"family": "inet",
"hook": "postrouting",
"name": "nat_postrouting",
"policy": "accept",
"prio": 100,
"table": "fwl",
"type": "nat"
}
},
{
"set": {
"elem": [
{
"prefix": {
"addr": "10.0.0.0",
"len": 8
}
},
{
"prefix": {
"addr": "172.16.0.0",
"len": 12
}
},
{
"prefix": {
"addr": "192.168.0.0",
"len": 16
}
}
],
"family": "inet",
"name": "rfc1918",
"table": "fwl",
"type": "ipv4_addr"
}
},
{
"map": {
"elem": [
[
{
"concat": [
"tcp",
8080
]
},
{
"concat": [
"10.0.0.10",
80
]
}
]
],
"family": "inet",
"map": [
"ipv4_addr",
"inet_service"
],
"name": "forwards",
"table": "fwl",
"type": [
"inet_proto",
"inet_service"
]
}
},
{
"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",
"ipv4_addr",
"inet_service"
]
}
},
{
"rule": {
"chain": "input",
"expr": [
{
"match": {
"left": {
"ct": {
"key": "state"
}
},
"op": "in",
"right": [
"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": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv6"
}
},
{
"match": {
"left": {
"payload": {
"field": "nexthdr",
"protocol": "ip6"
}
},
"op": "==",
"right": "ipv6-icmp"
}
},
{
"match": {
"left": {
"payload": {
"field": "saddr",
"protocol": "ip6"
}
},
"op": "==",
"right": {
"prefix": {
"addr": "fe80:0:0:0:0:0:0:0",
"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": "in",
"right": [
"established",
"related"
]
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"ct": {
"key": "status"
}
},
"op": "==",
"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": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"match": {
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "iifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "in",
"right": {
"set": [
"lan"
]
}
}
},
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "udp"
}
},
{
"match": {
"left": {
"concat": [
{
"payload": {
"field": "protocol",
"protocol": "ip"
}
},
{
"payload": {
"field": "dport",
"protocol": "th"
}
}
]
},
"op": "==",
"right": "@forwards"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "forward",
"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": [
{
"payload": {
"field": "protocol",
"protocol": "ip6"
}
},
{
"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": [
{
"payload": {
"field": "protocol",
"protocol": "ip6"
}
},
{
"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": "output",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "tcp"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"meta": {
"key": "l4proto"
}
},
"op": "==",
"right": "udp"
}
},
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_prerouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_postrouting",
"expr": [
{
"match": {
"left": {
"meta": {
"key": "oifname"
}
},
"op": "==",
"right": "wan"
}
},
{
"match": {
"left": {
"meta": {
"key": "nfproto"
}
},
"op": "==",
"right": "ipv4"
}
},
{
"match": {
"left": {
"payload": {
"field": "saddr",
"protocol": "ip"
}
},
"op": "==",
"right": "@rfc1918"
}
},
{
"masquerade": null
}
],
"family": "inet",
"table": "fwl"
}
},
{
"rule": {
"chain": "nat_postrouting",
"expr": [
{
"accept": null
}
],
"family": "inet",
"table": "fwl"
}
}
]
}

View File

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

View File

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

View File

@@ -36,3 +36,23 @@ executable fwlc
hs-source-dirs: app hs-source-dirs: app
build-depends: build-depends:
base, fwl, text, aeson-pretty, bytestring 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

View File

@@ -1,6 +1,7 @@
module FWL.AST where 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 type Name = String
@@ -27,7 +28,7 @@ data Decl
| DLet Name Type Expr | DLet Name Type Expr
| DPattern Name Type Pat | DPattern Name Type Pat
| DFlow Name FlowExpr | DFlow Name FlowExpr
| DRule Name Type Expr -- body must be ELam | DRule Name Type Expr
| DPolicy Name Type PolicyMeta ArmBlock | DPolicy Name Type PolicyMeta ArmBlock
deriving (Show) deriving (Show)
@@ -41,9 +42,22 @@ data Hook = HInput | HForward | HOutput | HPrerouting | HPostrouting
deriving (Show, Eq) deriving (Show, Eq)
data TableName = TFilter | TNAT data TableName = TFilter | TNAT
deriving (Show, Eq) 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) 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 data IfaceKind = IWan | ILan | IWireGuard | IUser Name
deriving (Show) deriving (Show)
@@ -53,23 +67,28 @@ data IfaceProp
| IPCidr6 [CIDR] | IPCidr6 [CIDR]
deriving (Show) 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 ─────────────────────────────────────────────────────────────── -- ─── Patterns ───────────────────────────────────────────────────────────────
data Pat data Pat
= PWild = PWild
| PVar Name | PVar Name
| PNamed Name -- first-class named pattern ref | PNamed Name
| PCtor Name [Pat] -- IPv4(ip, ...), TCP(tcp, ...) | PCtor Name [Pat]
| PRecord Name [FieldPat] -- udp { length = 156 } | PRecord Name [FieldPat]
| PTuple [Pat] | PTuple [Pat]
| PFrame (Maybe PathPat) Pat -- Frame(path?, inner) | PFrame (Maybe PathPat) Pat
| PBytes [ByteElem] | PBytes [ByteElem]
| POr Pat Pat
deriving (Show) deriving (Show)
data FieldPat data FieldPat
= FPEq Name Literal -- field = literal = FPEq Name Literal
| FPBind Name -- bind field to same-named var | FPBind Name
| FPAs Name Name -- field as var | FPAs Name Name
deriving (Show) deriving (Show)
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat) data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
@@ -78,13 +97,13 @@ data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
data EndpointPat data EndpointPat
= EPWild = EPWild
| EPName Name | EPName Name
| EPMember Name Name -- iif `in` zone | EPMember Name Name
deriving (Show) deriving (Show)
data ByteElem data ByteElem
= BEHex Word8 = BEHex Word8
| BEWild -- _ (one byte) | BEWild
| BEWildStar -- _* (zero or more) | BEWildStar
deriving (Show) deriving (Show)
-- ─── Flow ─────────────────────────────────────────────────────────────────── -- ─── Flow ───────────────────────────────────────────────────────────────────
@@ -95,8 +114,11 @@ data FlowExpr
deriving (Show) deriving (Show)
type Duration = (Int, TimeUnit) 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 data TimeUnit = Seconds | Millis | Minutes | Hours
deriving (Show) deriving (Show, Eq)
-- ─── Types ────────────────────────────────────────────────────────────────── -- ─── Types ──────────────────────────────────────────────────────────────────
@@ -111,7 +133,7 @@ data Type
data Expr data Expr
= EVar Name = EVar Name
| EQual [Name] -- qualified name, e.g. Log.emit | EQual [Name]
| ELit Literal | ELit Literal
| ELam Name Expr | ELam Name Expr
| EApp Expr Expr | EApp Expr Expr
@@ -122,7 +144,7 @@ data Expr
| ETuple [Expr] | ETuple [Expr]
| ESet [Expr] | ESet [Expr]
| EMap [(Expr, Expr)] | EMap [(Expr, Expr)]
| EPerform [Name] [Expr] -- perform QualName(args) | EPerform [Name] [Expr]
| EInfix InfixOp Expr Expr | EInfix InfixOp Expr Expr
| ENot Expr | ENot Expr
deriving (Show) deriving (Show)
@@ -130,10 +152,10 @@ data Expr
data InfixOp data InfixOp
= OpAnd | OpOr = OpAnd | OpOr
| OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte | OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
| OpIn -- `in` / `∈` | OpIn
| OpConcat -- ++ | OpConcat
| OpThen -- >> | OpThen
| OpBind -- >>= | OpBind
deriving (Show, Eq) deriving (Show, Eq)
data DoStmt data DoStmt
@@ -142,19 +164,71 @@ data DoStmt
deriving (Show) deriving (Show)
type ArmBlock = [Arm] type ArmBlock = [Arm]
data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard?, body data Arm = Arm Pat (Maybe Expr) Expr
deriving (Show) deriving (Show)
-- ─── Literals ─────────────────────────────────────────────────────────────── -- ─── 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 data Literal
= LInt Int = LInt Int
| LString String | LString String
| LBool Bool | LBool Bool
| LIPv4 (Word8,Word8,Word8,Word8) | LIP IPVersion Integer -- unified IP address representation
| LIPv6 [Word16] | LCIDR Literal Int -- base address + prefix length
| LCIDR Literal Int
| LPort Int | LPort Int
| LDuration Int TimeUnit | LDuration Int TimeUnit
| LHex Word8 | LHex Word8
deriving (Show, Eq) 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

View File

@@ -9,7 +9,7 @@ module FWL.Check
, CheckError(..) , CheckError(..)
) where ) where
import Data.List (foldl', nub) import Data.List (nub)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
@@ -20,6 +20,7 @@ data CheckError
| PolicyNoContinue String -- policy name | PolicyNoContinue String -- policy name
| PatternCycle [String] -- cycle path | PatternCycle [String] -- cycle path
| DuplicateDecl String String -- kind, name | DuplicateDecl String String -- kind, name
| OrPatternMismatch [String] [String]
deriving (Show, Eq) deriving (Show, Eq)
type Env = Map.Map String DeclKind type Env = Map.Map String DeclKind
@@ -43,12 +44,12 @@ buildEnv = foldl' addDecl Map.empty
where where
addDecl m (DInterface n _ _) = Map.insert n KInterface m addDecl m (DInterface n _ _) = Map.insert n KInterface m
addDecl m (DZone n _) = Map.insert n KZone 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 (DLet n _ _) = Map.insert n KLet m
addDecl m (DPattern n _ _) = Map.insert n KPattern m addDecl m (DPattern n _ _) = Map.insert n KPattern m
addDecl m (DFlow n _) = Map.insert n KFlow m addDecl m (DFlow n _) = Map.insert n KFlow m
addDecl m (DRule n _ _) = Map.insert n KRule m addDecl m (DRule n _ _) = Map.insert n KRule m
addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m
addDecl m _ = m
findDups :: [Decl] -> [CheckError] findDups :: [Decl] -> [CheckError]
findDups decls = go [] Set.empty decls findDups decls = go [] Set.empty decls
@@ -100,11 +101,12 @@ checkName env kind n
isBuiltin :: String -> Bool isBuiltin :: String -> Bool
isBuiltin n = n `elem` isBuiltin n = n `elem`
[ "ct", "iif", "oif", "lo", "wan", "lan" [ "ct", "iif", "oif", "lo", "wan", "lan"
, "tcp", "udp", "ip", "ip6", "eth" , "tcp", "udp", "ip", "ip6", "eth", "wg"
, "Established", "Related", "DNAT" , "Established", "Related", "DNAT"
, "Allow", "Drop", "Continue", "Masquerade" , "Allow", "Drop", "Continue", "Masquerade", "DNATMap"
, "Matched", "Unmatched" , "Matched", "Unmatched"
, "true", "false" , "true", "false"
, "matches", "flowOf", "Warn"
] ]
checkPat :: Env -> Pat -> [CheckError] checkPat :: Env -> Pat -> [CheckError]
@@ -116,6 +118,25 @@ checkPat env (PRecord _ fs) = concatMap (checkFP env) fs
checkPat env (PTuple ps) = concatMap (checkPat env) ps checkPat env (PTuple ps) = concatMap (checkPat env) ps
checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner
checkPat _ (PBytes _) = [] 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 :: Env -> FieldPat -> [CheckError]
checkFP _ _ = [] -- field names checked by type-checker later checkFP _ _ = [] -- field names checked by type-checker later
@@ -135,15 +156,36 @@ checkFlow env (FSeq a b _) = checkFlow env a ++ checkFlow env b
checkArm :: Env -> Arm -> [CheckError] checkArm :: Env -> Arm -> [CheckError]
checkArm env (Arm p mg e) = checkArm env (Arm p mg e) =
let env' = addPat env p in
checkPat env p ++ checkPat env p ++
maybe [] (checkExpr env) mg ++ maybe [] (checkExpr env') mg ++
checkExpr env e 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 -> Expr -> [CheckError]
checkExpr env (EVar n) = checkName env "name" n checkExpr env (EVar n) = checkName env "name" n
checkExpr _ (EQual _) = [] -- qualified names: deferred checkExpr _ (EQual _) = [] -- qualified names: deferred
checkExpr _ (ELit _) = [] 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 (EApp f x) = checkExpr env f ++ checkExpr env x
checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab
checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f] checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f]
@@ -190,6 +232,7 @@ checkPatternCycles decls =
refsInPat (PCtor _ ps) = concatMap refsInPat ps refsInPat (PCtor _ ps) = concatMap refsInPat ps
refsInPat (PTuple ps) = concatMap refsInPat ps refsInPat (PTuple ps) = concatMap refsInPat ps
refsInPat (PFrame _ p) = refsInPat p refsInPat (PFrame _ p) = refsInPat p
refsInPat (POr p1 p2) = refsInPat p1 ++ refsInPat p2
refsInPat _ = [] refsInPat _ = []
findCycles :: Map.Map String [String] -> [[String]] findCycles :: Map.Map String [String] -> [[String]]

View File

@@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Compile a checked FWL program to nftables JSON using Aeson. {- | Compile a checked FWL program to nftables JSON using Aeson.
All policies (Filter and NAT) go into one table named by Config. All policies (Filter and NAT) go into one table named by Config.
Layer stripping: Frame patterns that omit Ether compile identically Layer stripping: Frame patterns that omit Ether compile identically
to those that include it — the compiler inserts protocol matches to those that include it.
from whatever constructor the user wrote.
-} -}
module FWL.Compile module FWL.Compile
( compileProgram ( compileProgram
@@ -12,37 +12,43 @@ module FWL.Compile
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Aeson as A
import Data.Aeson ((.=), Value(..), object, toJSON) 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.ByteString.Lazy as BL
import qualified Data.Aeson.Encode.Pretty as Pretty import Data.Aeson.Encode.Pretty (encodePretty)
import FWL.AST import FWL.AST
-- ─── Entry points ──────────────────────────────────────────────────────────── -- ─── Entry points ────────────────────────────────────────────────────────────
-- | Compile an FWL program and render to pretty-printed JSON bytes.
compileToJson :: Program -> BL.ByteString compileToJson :: Program -> BL.ByteString
compileToJson = Pretty.encodePretty . programToValue compileToJson = encodePretty . programToValue
-- exposed for tests
compileProgram :: Program -> Value
compileProgram = programToValue
-- | Compile an FWL program to an Aeson Value (the nftables JSON schema).
programToValue :: Program -> Value programToValue :: Program -> Value
programToValue prog@(Program cfg decls) = programToValue (Program cfg decls) =
object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ] object [ "nftables" .= toJSON
(metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
where where
env = buildEnv decls env = buildEnv decls
tbl = configTable cfg 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 ] tableObj = object [ "table" .= tableValue tbl ]
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ] policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies
ruleObjs = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies ruleObjs = concatMap
(\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab)
policies
letDecls = [ (n, t, e) | DLet n t e <- decls ] 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
-- ─── Table / Chain declarations ────────────────────────────────────────────── -- ─── Table / Chain declarations ──────────────────────────────────────────────
@@ -60,7 +66,7 @@ chainDeclValue tbl n pm = object
, "name" .= n , "name" .= n
, "type" .= chainTypeStr (pmTable pm) , "type" .= chainTypeStr (pmTable pm)
, "hook" .= hookStr (pmHook pm) , "hook" .= hookStr (pmHook pm)
, "prio" .= priorityStr (pmPriority pm) , "prio" .= priorityInt (pmPriority pm)
, "policy" .= defaultPolicyStr (pmHook pm) , "policy" .= defaultPolicyStr (pmHook pm)
] ]
] ]
@@ -76,14 +82,10 @@ hookStr HOutput = "output"
hookStr HPrerouting = "prerouting" hookStr HPrerouting = "prerouting"
hookStr HPostrouting = "postrouting" hookStr HPostrouting = "postrouting"
priorityStr :: Priority -> String -- Priority is emitted as an integer in nftables JSON.
priorityStr PFilter = "filter" priorityInt :: Priority -> Int
priorityStr PDstNat = "dstnat" priorityInt = priorityValue
priorityStr PSrcNat = "srcnat"
priorityStr PMangle = "mangle"
priorityStr (PInt n) = show n
-- Input and Forward hooks default to drop; everything else to accept.
defaultPolicyStr :: Hook -> String defaultPolicyStr :: Hook -> String
defaultPolicyStr HInput = "drop" defaultPolicyStr HInput = "drop"
defaultPolicyStr HForward = "drop" defaultPolicyStr HForward = "drop"
@@ -91,25 +93,22 @@ defaultPolicyStr _ = "accept"
-- ─── Arm → Rule objects ────────────────────────────────────────────────────── -- ─── 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 :: CompileEnv -> String -> Name -> Arm -> [Value]
armToRuleValues env tbl chain (Arm p mg body) = armToRuleValues env tbl chain (Arm p mg body) =
case compileAction env body of case compileAction env body of
Nothing -> [] -- Continue: emit nothing Nothing -> []
Just verdict -> Just verdict ->
let patExprs = compilePat env p let patExprsAlts = compilePat env p
guardExprs = maybe [] (compileGuard env) mg guardExprs = maybe [] (compileGuard env) mg
allExprs = patExprs ++ guardExprs ++ [verdict]
in [ object in [ object
[ "rule" .= object [ "rule" .= object
[ "family" .= ("inet" :: String) [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "chain" .= chain , "chain" .= chain
, "expr" .= toJSON allExprs , "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict])
]
] ]
] ]
| patExprs <- patExprsAlts ]
-- ─── Pattern → [Value] ─────────────────────────────────────────────────────── -- ─── Pattern → [Value] ───────────────────────────────────────────────────────
@@ -127,83 +126,83 @@ buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty
declNameOf (DLet n _ _) = n declNameOf (DLet n _ _) = n
declNameOf (DImport n _ _) = n declNameOf (DImport n _ _) = n
compilePat :: CompileEnv -> Pat -> [Value] compilePat :: CompileEnv -> Pat -> [[Value]]
compilePat _ PWild = [] compilePat _ PWild = [[]]
compilePat _ (PVar _) = [] compilePat _ (PVar _) = [[]]
compilePat env (PNamed n) = expandNamedPat env n compilePat env (PNamed n) = expandNamedPat env n
compilePat env (PFrame mp inner) = compilePat env (PFrame mp inner) = do
maybe [] (compilePathPat env) mp ++ compilePat env inner pathConds <- maybe [[]] (compilePathPat env) mp
innerConds <- compilePat env inner
return (pathConds ++ innerConds)
compilePat env (PCtor n ps) = compileCtorPat env n ps compilePat env (PCtor n ps) = compileCtorPat env n ps
compilePat _ (PRecord n fs) = compileRecordPat n fs compilePat _ (PRecord n fs) = compileRecordPat n fs
compilePat env (PTuple ps) = concatMap (compilePat env) ps compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps))
compilePat _ (PBytes _) = [] -- handled by flow/ct mark (future) 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 :: CompileEnv -> Name -> [Value]
expandNamedPat env n = expandNamedPat env n =
case Map.lookup n env of case Map.lookup n env of
Just (DPattern _ _ p) -> compilePat env p Just (DPattern _ _ p) -> compilePat env p
_ -> [] _ -> []
-- Layer stripping: Ether is transparent; IPv4/IPv6/TCP/UDP/ICMPv6 each emit compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]]
-- the appropriate protocol-selector match then recurse into their children.
-- Omitting Ether produces identical output.
compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
compileCtorPat env ctor ps = case ctor of compileCtorPat env ctor ps = case ctor of
"Ether" -> children -- transparent layer "Ether" -> children
"IPv4" -> matchMeta "nfproto" "ipv4" : children "IPv4" -> map (matchMeta "nfproto" "ipv4" :) children
"IPv6" -> matchMeta "nfproto" "ipv6" : children "IPv6" -> map (matchMeta "nfproto" "ipv6" :) children
"TCP" -> matchPayload "th" "protocol" "tcp" : children "TCP" -> map (matchMeta "l4proto" "tcp" :) children
"UDP" -> matchPayload "th" "protocol" "udp" : children "UDP" -> map (matchMeta "l4proto" "udp" :) children
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children "ICMPv6" -> map (matchPayload "ip6" "nexthdr" "ipv6-icmp" :) children
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children "ICMP" -> map (matchPayload "ip" "protocol" "icmp" :) children
_ -> children _ -> children
where 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 :: String -> [FieldPat] -> [Value] compileRecordPat proto fs = [mapMaybe go fs]
compileRecordPat proto = mapMaybe go
where where
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit)) go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
go _ = Nothing go _ = Nothing
-- Path patterns (iif/oif). compilePathPat :: CompileEnv -> PathPat -> [[Value]]
compilePathPat :: CompileEnv -> PathPat -> [Value] compilePathPat env (PathPat ms md) =
compilePathPat _ (PathPat ms md) = [ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint "iifname") ms ++ maybe [] (compileEndpoint env "oifname") md ]
maybe [] (compileEndpoint "oifname") md
compileEndpoint :: String -> EndpointPat -> [Value] compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value]
compileEndpoint _ EPWild = [] compileEndpoint _ _ EPWild = []
compileEndpoint dir (EPName n) = [matchMeta dir n] compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]] compileEndpoint env dir (EPMember _ z) =
-- zone membership: for MVP we emit the zone name as a set element. case Map.lookup z env of
-- A later pass would expand zones to their member interface names. Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
_ -> [matchInSet (metaVal dir) [A.String (toText z)]]
-- ─── Guard → [Value] ───────────────────────────────────────────────────────── -- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: CompileEnv -> Expr -> [Value] compileGuard :: CompileEnv -> Expr -> [Value]
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
compileGuard _ (EInfix OpIn l r) = [compileInExpr l r] compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)] compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal r)] compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
compileGuard _ _ = [] compileGuard _ _ = []
compileInExpr :: Expr -> Expr -> Value compileInExpr :: CompileEnv -> Expr -> Expr -> Value
-- ct.state in { Established, Related } -- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element
compileInExpr (EQual ["ct","state"]) (ESet vs) = ctMatch "state" vs -- EQual case to eliminate the overlapping pattern match warning.
compileInExpr (EQual ["ct","status"]) (ESet vs) = ctMatch "status" vs compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
-- generic set membership matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr l (ESet vs) = matchExpr "in" (exprVal l) (setVal (map exprToStr vs)) compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
compileInExpr l r = matchExpr "==" (exprVal l) (exprVal r) matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr env l (ESet vs) =
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
compileInExpr env l (EVar z)
| Just (DZone _ ns) <- Map.lookup z env =
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r)
ctMatch :: String -> [Expr] -> Value -- ─── Action → Maybe Value ─────────────────────────────────────────────────────
ctMatch key vs = matchExpr "in"
(object ["ct" .= object ["key" .= key]])
(setVal (map exprToStr vs))
-- ─── Action → Maybe Value (Nothing = Continue = no rule) ─────────────────────
compileAction :: CompileEnv -> Expr -> Maybe Value compileAction :: CompileEnv -> Expr -> Maybe Value
compileAction _ (EVar "Allow") = Just (object ["accept" .= Null]) compileAction _ (EVar "Allow") = Just (object ["accept" .= Null])
@@ -212,105 +211,184 @@ compileAction _ (EVar "Continue") = Nothing
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null]) compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null])
compileAction _ (EApp (EVar "DNAT") arg) = compileAction _ (EApp (EVar "DNAT") arg) =
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]] Just $ object ["dnat" .= object ["addr" .= exprToStr arg]]
compileAction _ (EApp (EVar "DNATMap") arg) = compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
Just $ object ["dnat" .= object ["addr" .= object Just $ object ["dnat" .= object ["addr" .= object
["map" .= object ["key" .= object ["concat" .= Array mempty] [ "map" .= object [ "key" .= exprVal env key
,"data" .= exprToStr arg]]]] , "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]
-- Rule invocation → jump
compileAction env (EApp (EVar rn) _) = compileAction env (EApp (EVar rn) _) =
case Map.lookup rn env of case Map.lookup rn env of
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]] Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
_ -> Just (object ["accept" .= Null]) _ -> Just (object ["accept" .= Null])
compileAction _ _ = Just (object ["accept" .= Null]) compileAction _ _ = Just (object ["accept" .= Null])
-- ─── Let → Map object ──────────────────────────────────────────────────────── letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
letToMapValue :: String -> Name -> Expr -> Maybe Value
letToMapValue tbl n (EMap entries) = Just $ object
[ "map" .= object [ "map" .= object
[ "family" .= ("inet" :: String) [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "name" .= n , "name" .= n
, "type" .= ("inetproto . inetservice" :: String) , "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= ("ipv4_addr . inetservice" :: String) , "map" .= renderNftType (fwlTypeToNft tv)
, "elem" .= toJSON (map renderMapElem entries) , "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)
, "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 :: (Expr, Expr) -> Value
renderMapElem (k, v) = toJSON renderMapElem (k, v) = toJSON
[ object ["concat" .= toJSON [exprToStr k]] [ renderMapOrSetKey k
, exprToStr v , renderMapOrSetKey v
] ]
renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey
-- ─── Aeson building blocks ─────────────────────────────────────────────────── -- ─── Aeson building blocks ───────────────────────────────────────────────────
-- { "match": { "op": op, "left": left, "right": right } }
matchExpr :: String -> Value -> Value -> Value matchExpr :: String -> Value -> Value -> Value
matchExpr op l r = object matchExpr op l r = object
[ "match" .= object [ "match" .= object
[ "op" .= op [ "op" .= (op :: String)
, "left" .= l , "left" .= l
, "right" .= r , "right" .= r
] ]
] ]
matchMeta :: String -> String -> Value 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 :: String -> String -> String -> Value
matchPayload proto field val = 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 :: Value -> [Value] -> Value
matchInSet lhs vals = matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
matchExpr "in" lhs (setVal vals)
metaVal :: String -> Value metaVal :: String -> Value
metaVal key = object ["meta" .= object ["key" .= key]] metaVal key = object ["meta" .= object ["key" .= (key :: String)]]
payloadVal :: String -> String -> Value payloadVal :: String -> String -> Value
payloadVal proto field = 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] setVal vs = object ["set" .= toJSON vs]
-- ─── Expression → Value helpers ────────────────────────────────────────────── -- ─── Expression helpers ───────────────────────────────────────────────────────
exprVal :: Expr -> Value isSetOrMapRef :: CompileEnv -> Name -> Bool
exprVal (EQual [p, f]) = payloadVal p f isSetOrMapRef env n = case Map.lookup n env of
exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= k]] Just (DLet _ _ _) -> True
exprVal (EVar n) = metaVal n Just (DImport _ _ _) -> True
exprVal (ELit l) = A.String (strText (renderLit l)) _ -> False
exprVal (ESet vs) = setVal (map exprToStr vs)
exprVal e = A.String (strText (exprToStr e)) mapField :: String -> String
mapField "src" = "saddr"
mapField "dst" = "daddr"
mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
exprVal :: CompileEnv -> Expr -> Value
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
exprVal _ (EQual ["meta", k])= metaVal k
exprVal _ (EQual ["th", k]) = payloadVal "th" k
exprVal _ (EQual [p, f]) = payloadVal p (mapField f)
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns))
exprVal env (EVar n)
| Just (DInterface _ _ _) <- Map.lookup n env = A.String (toText n)
| isSetOrMapRef env n = A.String ("@" <> toText n)
| n == "iif" = metaVal "iifname"
| n == "oif" = metaVal "oifname"
| n == "DNAT" = A.String "dnat"
| n == "Established" = A.String "established"
| n == "Related" = A.String "related"
| otherwise = metaVal n
exprVal _ (ELit (LCIDR ip p)) = object
[ "prefix" .= object
[ "addr" .= A.String (toText (renderLit ip))
, "len" .= p
]
]
exprVal _ (ELit l) = A.String (toText (renderLit l))
exprVal env (ESet vs) = setVal (map (exprVal env) vs)
exprVal env (ETuple es) = object ["concat" .= toJSON (map (exprVal env) es)]
exprVal _ e = A.String (toText (exprToStr e))
exprToStr :: Expr -> String exprToStr :: 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 (ELit l) = renderLit l
exprToStr (EQual ns) = intercalate "." ns exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es) exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
exprToStr _ = "_" exprToStr _ = "_"
strText :: String -> A.Text -- Fix 2: Use Data.Text.pack via OverloadedStrings + fromString instead of
strText = \s -> read (show s) -- simple String→Text without extra dep -- the fragile read(show s) hack. With OverloadedStrings enabled, string
-- literals already produce the correct Text/Key types; for runtime String
toText :: String -> T.Text
toText = T.pack
renderLit :: Literal -> String renderLit :: Literal -> String
renderLit (LInt n) = show n renderLit (LInt n) = show n
renderLit (LString s) = s renderLit (LString s) = s
renderLit (LBool True) = "true" renderLit (LBool True) = "true"
renderLit (LBool False) = "false" renderLit (LBool False) = "false"
renderLit (LIPv4 (a,b,c,d)) = renderLit (LIP IPv4 n) = renderIPv4 n
show a++"."++show b++"."++show c++"."++show d renderLit (LIP IPv6 n) = renderIPv6 n
renderLit (LIPv6 _) = "::1"
renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p
renderLit (LPort p) = show p renderLit (LPort p) = show p
renderLit (LDuration n Seconds) = show n renderLit (LDuration n Seconds) = show n ++ "s"
renderLit (LDuration n _) = show n 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 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)

View File

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

View File

@@ -3,15 +3,19 @@ module FWL.Parser
, parseFile , parseFile
) where ) where
import Control.Monad (void) import Control.Monad (void, when)
import Data.Bits ((.&.), (.|.), shiftL)
import Data.List (foldl')
import Data.Word (Word8) import Data.Word (Word8)
import Numeric (readHex) import Numeric (readHex)
import Text.Parsec import Text.Parsec
import Text.Parsec.String (Parser) import Text.Parsec.String (Parser)
import Data.Functor.Identity (Identity)
import qualified Text.Parsec.Expr as Ex import qualified Text.Parsec.Expr as Ex
import FWL.AST import FWL.AST
import FWL.Lexer import FWL.Lexer
import Data.Char (isUpper)
-- ─── Entry points ──────────────────────────────────────────────────────────── -- ─── Entry points ────────────────────────────────────────────────────────────
@@ -34,7 +38,7 @@ program = do
configBlock :: Parser Config configBlock :: Parser Config
configBlock = do configBlock = do
reserved "config" reserved "config"
props <- braces (semiSep configProp) props <- braces (endBy configProp semi)
optional semi optional semi
return $ foldr applyProp defaultConfig props return $ foldr applyProp defaultConfig props
where where
@@ -66,8 +70,8 @@ interfaceDecl = do
n <- identifier n <- identifier
reservedOp ":" reservedOp ":"
k <- ifaceKind k <- ifaceKind
ps <- braces (semiSep ifaceProp) ps <- braces (endBy ifaceProp semi)
semi _ <- semi
return (DInterface n k ps) return (DInterface n k ps)
ifaceKind :: Parser IfaceKind ifaceKind :: Parser IfaceKind
@@ -90,7 +94,7 @@ zoneDecl = do
n <- identifier n <- identifier
reservedOp "=" reservedOp "="
ns <- braces (commaSep1 identifier) ns <- braces (commaSep1 identifier)
semi _ <- semi
return (DZone n ns) return (DZone n ns)
importDecl :: Parser Decl importDecl :: Parser Decl
@@ -101,7 +105,7 @@ importDecl = do
t <- typeP t <- typeP
reserved "from" reserved "from"
s <- stringLit s <- stringLit
semi _ <- semi
return (DImport n t s) return (DImport n t s)
letDecl :: Parser Decl letDecl :: Parser Decl
@@ -112,7 +116,7 @@ letDecl = do
t <- typeP t <- typeP
reservedOp "=" reservedOp "="
e <- expr e <- expr
semi _ <- semi
return (DLet n t e) return (DLet n t e)
patternDecl :: Parser Decl patternDecl :: Parser Decl
@@ -123,7 +127,7 @@ patternDecl = do
t <- typeP t <- typeP
reservedOp "=" reservedOp "="
p <- pat p <- pat
semi _ <- semi
return (DPattern n t p) return (DPattern n t p)
flowDecl :: Parser Decl flowDecl :: Parser Decl
@@ -134,7 +138,7 @@ flowDecl = do
reserved "FlowPattern" reserved "FlowPattern"
reservedOp "=" reservedOp "="
f <- flowExpr f <- flowExpr
semi _ <- semi
return (DFlow n f) return (DFlow n f)
ruleDecl :: Parser Decl ruleDecl :: Parser Decl
@@ -145,7 +149,7 @@ ruleDecl = do
t <- typeP t <- typeP
reservedOp "=" reservedOp "="
e <- expr e <- expr
semi _ <- semi
return (DRule n t e) return (DRule n t e)
policyDecl :: Parser Decl policyDecl :: Parser Decl
@@ -158,7 +162,7 @@ policyDecl = do
pm <- braces policyMeta pm <- braces policyMeta
reservedOp "=" reservedOp "="
ab <- armBlock ab <- armBlock
semi _ <- semi
return (DPolicy n t pm ab) return (DPolicy n t pm ab)
policyMeta :: Parser PolicyMeta policyMeta :: Parser PolicyMeta
@@ -166,7 +170,7 @@ policyMeta = do
props <- commaSep1 metaProp props <- commaSep1 metaProp
let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props 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 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 pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) pFilter props
return (PolicyMeta h tb pr) return (PolicyMeta h tb pr)
metaProp :: Parser (Either Hook (Either TableName Priority)) metaProp :: Parser (Either Hook (Either TableName Priority))
@@ -187,11 +191,21 @@ tableNameP = (reserved "Filter" >> return TFilter)
<|> (reserved "NAT" >> return TNAT) <|> (reserved "NAT" >> return TNAT)
priorityP :: Parser Priority priorityP :: Parser Priority
priorityP = (reserved "Filter" >> return PFilter) priorityP
<|> (reserved "DstNat" >> return PDstNat) = (reserved "Filter" >> return pFilter)
<|> (reserved "SrcNat" >> return PSrcNat) <|> (reserved "DstNat" >> return pDstNat)
<|> (reserved "Mangle" >> return PMangle) <|> (reserved "SrcNat" >> return pSrcNat)
<|> (PInt . fromIntegral <$> natural) <|> (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 ────────────────────────────────────────────────────────────── -- ─── Arm blocks ──────────────────────────────────────────────────────────────
@@ -200,19 +214,24 @@ armBlock = braces (many arm)
arm :: Parser Arm arm :: Parser Arm
arm = do arm = do
symbol "|" _ <- symbol "|"
p <- pat p <- pat
g <- optionMaybe (reserved "if" >> expr) g <- optionMaybe (reserved "if" >> expr)
reservedOp "->" reservedOp "->"
e <- expr e <- expr
semi _ <- semi
return (Arm p g e) return (Arm p g e)
-- ─── Patterns ──────────────────────────────────────────────────────────────── -- ─── Patterns ────────────────────────────────────────────────────────────────
pat :: Parser Pat pat :: Parser Pat
pat = wildcardPat pat = Ex.buildExpressionParser patTable patAtom <?> "pattern"
<|> framePat where
patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ]
patAtom :: Parser Pat
patAtom = wildcardPat
<|> try framePat
<|> try tuplePat <|> try tuplePat
<|> bytesPat <|> bytesPat
<|> try recordPat <|> try recordPat
@@ -236,7 +255,7 @@ frameArgs = try withPath <|> withoutPath
where where
withPath = do withPath = do
pp <- pathPat pp <- pathPat
comma _ <- comma
inner <- pat inner <- pat
return (Just pp, inner) return (Just pp, inner)
withoutPath = do withoutPath = do
@@ -271,7 +290,7 @@ tuplePat = do
commaSep2 :: Parser a -> Parser [a] commaSep2 :: Parser a -> Parser [a]
commaSep2 p = do commaSep2 p = do
x <- p x <- p
comma _ <- comma
xs <- commaSep1 p xs <- commaSep1 p
return (x:xs) return (x:xs)
@@ -290,8 +309,9 @@ hexByte = do
h1 <- hexDigit h1 <- hexDigit
h2 <- hexDigit h2 <- hexDigit
whiteSpace whiteSpace
let [(v,"")] = readHex [h1,h2] case (readHex [h1,h2] :: [(Integer, String)]) of
return (fromIntegral v) [(v,"")] -> return (fromIntegral v)
_ -> fail "invalid hex byte"
-- Record pattern: ident { fields } -- Record pattern: ident { fields }
recordPat :: Parser Pat recordPat :: Parser Pat
@@ -303,17 +323,25 @@ recordPat = do
fieldPat :: Parser FieldPat fieldPat :: Parser FieldPat
fieldPat = do fieldPat = do
n <- identifier n <- identifier
try (reservedOp "=" >> FPEq n <$> literal) try (reservedOp "=" >> FPEq n <$> fieldLiteral)
<|> try (reserved "as" >> FPAs n <$> identifier) <|> try (reserved "as" >> FPAs n <$> identifier)
<|> return (FPBind n) <|> 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 :: Parser Pat
namedOrCtorPat = do namedOrCtorPat = do
n <- identifier n <- identifier
args <- optionMaybe (try (parens (commaSep pat))) args <- optionMaybe (try (parens (commaSep pat)))
case args of 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) Just ps -> return (PCtor n ps)
-- ─── Flow expressions ──────────────────────────────────────────────────────── -- ─── Flow expressions ────────────────────────────────────────────────────────
@@ -323,13 +351,17 @@ flowExpr = do
first <- FAtom <$> identifier first <- FAtom <$> identifier
rest <- many (reservedOp "." >> identifier) rest <- many (reservedOp "." >> identifier)
mw <- optionMaybe (reserved "within" >> durationLit) 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 where
buildSeq [x] mw = case mw of buildSeq [x] = x
Nothing -> x buildSeq (x:xs) = FSeq x (buildSeq xs) Nothing
Just w -> FSeq x x (Just w) -- degenerate buildSeq [] = error "impossible"
buildSeq (x:xs) mw = FSeq x (buildSeq xs mw) mw
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 :: Parser Duration
durationLit = do durationLit = do
@@ -518,7 +550,7 @@ mapEntry = do
literal :: Parser Literal literal :: Parser Literal
literal literal
= try cidrOrIpLit = try ipOrCidrLit
<|> try hexLit <|> try hexLit
<|> try (LBool True <$ reserved "true") <|> try (LBool True <$ reserved "true")
<|> try (LBool False <$ reserved "false") <|> try (LBool False <$ reserved "false")
@@ -528,26 +560,110 @@ literal
hexLit :: Parser Literal hexLit :: Parser Literal
hexLit = LHex <$> hexByte hexLit = LHex <$> hexByte
cidrOrIpLit :: Parser Literal -- ─── IP / CIDR parsing ───────────────────────────────────────────────────────
cidrOrIpLit = do
a <- fromIntegral <$> natural -- | Parse an IPv4 or IPv6 address, optionally followed by /prefix.
void (char '.') -- Tries IPv6 first (it can start with hex digits too), then IPv4.
b <- fromIntegral <$> natural ipOrCidrLit :: Parser Literal
void (char '.') ipOrCidrLit = do
c <- fromIntegral <$> natural ip <- try ipv6Lit <|> ipv4Lit_
void (char '.')
d <- fromIntegral <$> natural
whiteSpace
mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural) mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural)
whiteSpace whiteSpace
let ip = LIPv4 (a,b,c,d)
return $ case mPrefix of return $ case mPrefix of
Nothing -> ip Nothing -> ip
Just p -> LCIDR ip p 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 :: Parser CIDR
cidrLit = do cidrLit = do
l <- cidrOrIpLit l <- ipOrCidrLit
case l of case l of
LCIDR ip p -> return (ip, p) LCIDR ip p -> return (ip, p)
_ -> fail "expected CIDR notation" _ -> fail "expected CIDR notation (address/prefix)"

View File

@@ -49,8 +49,6 @@ prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr
prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }" prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }"
prettyCidr :: CIDR -> String 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 prettyCidr (ip, p) = prettyLit ip ++ "/" ++ show p
prettyHook :: Hook -> String prettyHook :: Hook -> String
@@ -65,11 +63,7 @@ prettyTable TFilter = "Filter"
prettyTable TNAT = "NAT" prettyTable TNAT = "NAT"
prettyPriority :: Priority -> String prettyPriority :: Priority -> String
prettyPriority PFilter = "Filter" prettyPriority p = show (priorityValue p)
prettyPriority PDstNat = "DstNat"
prettyPriority PSrcNat = "SrcNat"
prettyPriority PMangle = "Mangle"
prettyPriority (PInt n)= show n
prettyType :: Type -> String prettyType :: Type -> String
prettyType (TName n []) = n prettyType (TName n []) = n
@@ -88,6 +82,7 @@ prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
prettyPat (PFrame mp inner)= prettyPat (PFrame mp inner)=
"Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")" "Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")"
prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]" prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]"
prettyPat (POr p1 p2) = prettyPat p1 ++ " | " ++ prettyPat p2
prettyFP :: FieldPat -> String prettyFP :: FieldPat -> String
prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l
@@ -182,9 +177,8 @@ prettyLit (LInt n) = show n
prettyLit (LString s) = "\"" ++ s ++ "\"" prettyLit (LString s) = "\"" ++ s ++ "\""
prettyLit (LBool True) = "true" prettyLit (LBool True) = "true"
prettyLit (LBool False) = "false" prettyLit (LBool False) = "false"
prettyLit (LIPv4 (a,b,c,d)) = prettyLit (LIP IPv4 n) = renderIPv4 n
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d prettyLit (LIP IPv6 n) = renderIPv6 n
prettyLit (LIPv6 _) = "<ipv6>"
prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p
prettyLit (LPort p) = ":" ++ show p prettyLit (LPort p) = ":" ++ show p
prettyLit (LDuration n u) = show n ++ prettyUnit u prettyLit (LDuration n u) = show n ++ prettyUnit u

224
test/CheckTests.hs Normal file
View File

@@ -0,0 +1,224 @@
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 \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | 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 \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Allow; }; \
\policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Continue; };"
, testCase "last arm is Drop — ok" $
assertNoErrors
"policy good : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
, testCase "last arm is Allow — ok" $
assertNoErrors
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, 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 \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
]
-- ─── 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> 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;"
]

384
test/CompileTests.hs Normal file
View File

@@ -0,0 +1,384 @@
{-# 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
]
-- ─── 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 \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
return ()
, testCase "top-level nftables array present" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
_ <- nftArr v
return ()
, testCase "metainfo is first element" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> 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 \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected at least one table object"
(not (null (withKey "table" arr)))
, testCase "default table name is fwl" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
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 \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","hook"] c @?= Just (A.String "input")
[] -> assertFailure "No chain"
, testCase "filter chain type is filter" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "filter")
[] -> assertFailure "No chain"
, testCase "NAT chain type is nat" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "nat")
[] -> assertFailure "No chain"
, testCase "input chain default policy is drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "drop")
[] -> assertFailure "No chain"
, testCase "output chain default policy is accept" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "accept")
[] -> assertFailure "No chain"
, testCase "chain name matches policy name" $ do
v <- compileToValue
"policy my_input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> 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 "two arms produce two rules" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, testCase "arm without guard produces one rule" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "rule" arr) @?= 1
, testCase "rule expr array is present" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | 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 \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected accept verdict"
(not (null (withKey "accept" (allExprs arr))))
, testCase "Drop compiles to drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
assertBool "Expected drop verdict"
(not (null (withKey "drop" (allExprs arr))))
, testCase "Masquerade compiles to masquerade" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Masquerade; };"
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 \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
\ };"
withoutEther =
"policy p1 : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | 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 "two terminal arms produce two rules" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl"))
(withKey "rule" arr)
, testCase "chain objects reference correct table" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl"))
(withKey "chain" arr)
]

44
test/FWL/Util.hs Normal file
View 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

516
test/ParserTests.hs Normal file
View File

@@ -0,0 +1,516 @@
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
, 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 "minimal policy" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
d <- singleDecl p
case d of
DPolicy "output" _ (PolicyMeta HOutput TFilter (Priority 0)) [_] -> return ()
_ -> assertFailure (show d)
, testCase "NAT prerouting" $ do
p <- parseOk
"policy nat_pre : Frame \
\ on { hook = Prerouting, table = NAT, priority = DstNat } \
\ = { | _ -> Allow; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-100))) _ -> return ()
_ -> assertFailure (show d)
, testCase "arm with guard" $ do
p <- parseOk
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
\ | _ 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 \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
\ | 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 \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
\ | 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 \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
\ | 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)
]
-- ─── 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 "unknown hook" $
parseFail
"policy p : Frame \
\ on { hook = Bogus, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, testCase "empty arm block with no arms is ok" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
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
View 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
]