Compare commits
12 Commits
master
...
9390647f7a
| Author | SHA1 | Date | |
|---|---|---|---|
9390647f7a
|
|||
|
25f95996fb
|
|||
|
d79206440a
|
|||
|
d136bd62f7
|
|||
|
8a508ad7cc
|
|||
|
d01be7bc23
|
|||
|
2705f18e0f
|
|||
|
a0632d5263
|
|||
|
2a44095791
|
|||
|
30427521ca
|
|||
|
23ce29aece
|
|||
|
778cf13c40
|
166
AGENTS.md
Normal file
166
AGENTS.md
Normal 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
|
||||
17
app/Main.hs
17
app/Main.hs
@@ -3,19 +3,20 @@ module Main where
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL
|
||||
|
||||
import FWL.Parser (parseFile)
|
||||
import FWL.Pretty (prettyProgram)
|
||||
import FWL.Check (checkProgram)
|
||||
import FWL.Compile (compileToJson, compileProgram)
|
||||
import FWL.Compile (compileToJson)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
["check", fp] -> runCheck fp
|
||||
["check", fp] -> runCheck fp
|
||||
["compile", fp] -> runCompile fp
|
||||
["pretty", fp] -> runPretty fp
|
||||
["pretty", fp] -> runPretty fp
|
||||
_ -> do
|
||||
putStrLn "Usage: fwlc <command> <file.fwl>"
|
||||
putStrLn " check <file> -- parse and static-check"
|
||||
@@ -32,9 +33,7 @@ runCheck fp = do
|
||||
let errs = checkProgram prog
|
||||
if null errs
|
||||
then putStrLn "OK" >> exitSuccess
|
||||
else do
|
||||
mapM_ (hPutStrLn stderr . show) errs
|
||||
exitFailure
|
||||
else mapM_ (hPutStrLn stderr . show) errs >> exitFailure
|
||||
|
||||
runCompile :: FilePath -> IO ()
|
||||
runCompile fp = do
|
||||
@@ -44,10 +43,8 @@ runCompile fp = do
|
||||
Right prog -> do
|
||||
let errs = checkProgram prog
|
||||
if null errs
|
||||
then putStrLn (compileToJson prog)
|
||||
else do
|
||||
mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs
|
||||
exitFailure
|
||||
then BL.putStrLn (compileToJson prog)
|
||||
else mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs >> exitFailure
|
||||
|
||||
runPretty :: FilePath -> IO ()
|
||||
runPretty fp = do
|
||||
|
||||
@@ -1,494 +1,369 @@
|
||||
# FWL Grammar Specification (MVP)
|
||||
# FWL Grammar Specification
|
||||
|
||||
## Overview
|
||||
|
||||
FWL is a typed, functional DSL that compiles to nftables JSON. Programs are
|
||||
sequences of top-level declarations. The grammar uses explicit braces and
|
||||
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.
|
||||
> **Version:** MVP
|
||||
> **Last updated:** May 2026
|
||||
> This document is the authoritative grammar reference for the Firewall Language (FWL).
|
||||
> It supersedes the syntax examples in `proposal.md` and reflects the current parser implementation.
|
||||
|
||||
---
|
||||
|
||||
## Notation
|
||||
## Design Principles
|
||||
|
||||
```
|
||||
::= production
|
||||
| alternative
|
||||
{ x } zero or more repetitions of x
|
||||
[ x ] optional x
|
||||
```
|
||||
|
||||
String terminals are written in `"double quotes"`. Regex-like character classes
|
||||
use `[a-z]`, etc.
|
||||
- **Explicit delimiters everywhere** — all blocks use `{` `}` with trailing `;` on each item. No layout/indentation sensitivity.
|
||||
- **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.
|
||||
- **Types are explicit** — top-level declarations carry full type annotations in the MVP.
|
||||
- **Patterns vs. guards are strictly separated** — structural decomposition happens in patterns; boolean predicates over bound names happen in guards.
|
||||
- **IP addresses are integers** — IPv4 is a 32-bit value; IPv6 is a 128-bit value. Named priority constants (`Filter`, `SrcNat`, etc.) lower to their canonical integer values at parse time.
|
||||
|
||||
---
|
||||
|
||||
## Top-Level Structure
|
||||
## Top-Level Program
|
||||
|
||||
```ebnf
|
||||
program ::= { config } { decl }
|
||||
program ::= { decl }
|
||||
|
||||
config ::= "config" "{" { configProp ";" } "}"
|
||||
|
||||
configProp ::= "table" "=" stringLit
|
||||
decl ::= interfaceDecl
|
||||
| zoneDecl
|
||||
| importDecl
|
||||
| letDecl
|
||||
| patternDecl
|
||||
| flowDecl
|
||||
| ruleDecl
|
||||
| policyDecl
|
||||
```
|
||||
|
||||
Every non-`config` declaration is terminated by `";"`.
|
||||
|
||||
---
|
||||
|
||||
## Declarations
|
||||
|
||||
```ebnf
|
||||
decl ::= interfaceDecl
|
||||
| zoneDecl
|
||||
| importDecl
|
||||
| letDecl
|
||||
| patternDecl
|
||||
| flowDecl
|
||||
| ruleDecl
|
||||
| policyDecl
|
||||
interfaceDecl ::= "interface" ident ":" ifaceKind "{" { ifaceProp ";" } "}" ";"
|
||||
|
||||
ifaceKind ::= "WAN" | "LAN" | "WireGuard" | ident
|
||||
|
||||
ifaceProp ::= "dynamic"
|
||||
| "cidr4" "=" cidrSet
|
||||
| "cidr6" "=" cidrSet
|
||||
|
||||
cidrSet ::= "{" cidrLit { "," cidrLit } "}"
|
||||
|
||||
zoneDecl ::= "zone" ident "=" "{" ident { "," ident } "}" ";"
|
||||
|
||||
importDecl ::= "import" ident ":" type "from" stringLit ";"
|
||||
|
||||
letDecl ::= "let" ident ":" type "=" expr ";"
|
||||
|
||||
patternDecl ::= "pattern" ident ":" type "=" pat ";"
|
||||
|
||||
flowDecl ::= "flow" ident ":" "FlowPattern" "=" flowExpr ";"
|
||||
flowExpr ::= ident
|
||||
| ident "." ident "within" duration
|
||||
|
||||
ruleDecl ::= "rule" ident ":" type "=" lambdaExpr ";"
|
||||
|
||||
policyDecl ::= "policy" ident ":" type
|
||||
"on" "{"
|
||||
"hook" "=" hook ","
|
||||
"table" "=" tableName ","
|
||||
"priority" "=" priority
|
||||
"}"
|
||||
"=" armBlock ";"
|
||||
```
|
||||
|
||||
### Interface
|
||||
### Policy Metadata
|
||||
|
||||
```ebnf
|
||||
interfaceDecl ::= "interface" ident ":" ifaceKind "{" { ifaceProp ";" } "}" ";"
|
||||
hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting"
|
||||
|
||||
ifaceKind ::= "WAN" | "LAN" | "WireGuard" | ident
|
||||
tableName ::= "Filter" | "NAT" | ident
|
||||
|
||||
ifaceProp ::= "dynamic"
|
||||
| "cidr4" "=" cidrSet
|
||||
| "cidr6" "=" cidrSet
|
||||
|
||||
cidrSet ::= "{" cidrLit { "," cidrLit } "}"
|
||||
-- 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
|
||||
```
|
||||
|
||||
### Zone
|
||||
|
||||
```ebnf
|
||||
zoneDecl ::= "zone" ident "=" "{" ident { "," ident } "}" ";"
|
||||
```
|
||||
|
||||
### Import
|
||||
|
||||
```ebnf
|
||||
importDecl ::= "import" ident ":" type "from" stringLit ";"
|
||||
```
|
||||
|
||||
### Let
|
||||
|
||||
```ebnf
|
||||
letDecl ::= "let" ident ":" type "=" expr ";"
|
||||
```
|
||||
|
||||
### Pattern
|
||||
|
||||
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 ";"
|
||||
|
||||
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 ";"
|
||||
|
||||
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
|
||||
"on" "{" hookSpec "}"
|
||||
"=" armBlock ";"
|
||||
|
||||
hookSpec ::= hookProp "," hookProp "," hookProp
|
||||
| hookProp "," hookProp "," hookProp "," -- trailing comma OK
|
||||
|
||||
hookProp ::= "hook" "=" hook
|
||||
| "table" "=" tableName
|
||||
| "priority" "=" priority
|
||||
|
||||
hook ::= "Input" | "Forward" | "Output" | "Prerouting" | "Postrouting"
|
||||
tableName ::= "Filter" | "NAT"
|
||||
priority ::= "Filter" | "DstNat" | "SrcNat" | "Mangle" | intLit
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## 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
|
||||
|
||||
```ebnf
|
||||
type ::= funType
|
||||
type ::= simpleType
|
||||
| simpleType "->" type -- function type
|
||||
| "<" effectList ">" type -- effectful function type
|
||||
|
||||
funType ::= effectType
|
||||
| effectType "->" funType
|
||||
simpleType ::= ident -- type name (Frame, Action, IP, etc.)
|
||||
| ident "<" typeList ">" -- generic: Map<K,V>, Bytes<{}>
|
||||
| "(" type { "," type } ")" -- tuple type
|
||||
|
||||
effectType ::= "<" [ ident { "," ident } ] ">" simpleType
|
||||
| simpleType
|
||||
|
||||
simpleType ::= ident [ "<" typeList ">" ] -- parameterised type
|
||||
| "(" type { "," type } ")" -- tuple type
|
||||
| "(" type ")" -- grouped
|
||||
|
||||
typeList ::= type { "," type }
|
||||
typeList ::= type { "," type }
|
||||
effectList ::= ident { "," ident }
|
||||
```
|
||||
|
||||
Effect rows use angle brackets: `<FlowMatch, Log> Action`.
|
||||
|
||||
For MVP, effect annotations are required on `rule` declarations that contain
|
||||
`perform` expressions and are optional on `policy` declarations.
|
||||
> **Note:** `Frame`, `FlowPattern`, and all action/effect type names (`Action`, `CIDRSet`, etc.)
|
||||
> are plain identifiers in the type parser — they are **not** reserved keywords.
|
||||
|
||||
---
|
||||
|
||||
## Actions
|
||||
|
||||
`Action` is a built-in type. Its constructors are:
|
||||
## Expressions
|
||||
|
||||
```ebnf
|
||||
action ::= "Allow"
|
||||
| "Drop"
|
||||
| "Continue"
|
||||
| "Masquerade"
|
||||
| "DNAT" "(" expr ")"
|
||||
| "DNATMap" "(" expr ")"
|
||||
| "Log" "(" logLevel "," expr ")"
|
||||
lambdaExpr ::= "\" ident "->" expr
|
||||
| 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 |
|
||||
|------------|---------------------------------------------------|
|
||||
| `FlowMatch`| `FlowMatch.check(flowId, pattern) : MatchResult` |
|
||||
| `Log` | `Log.emit(level, msg) : ()` |
|
||||
| `FIB` | `FIB.daddrLocal(ip) : Bool` |
|
||||
wildcardPat ::= "_"
|
||||
framePat ::= "Frame" "(" frameArgs ")"
|
||||
frameArgs ::= pathPat "," pat -- with explicit path
|
||||
| pat -- path inferred
|
||||
|
||||
`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
|
||||
|
||||
```ebnf
|
||||
literal ::= intLit
|
||||
| stringLit
|
||||
| boolLit
|
||||
| ipv4Lit
|
||||
| ipv6Lit
|
||||
| cidrLit
|
||||
| portLit
|
||||
| durationLit
|
||||
| hexByte
|
||||
literal ::= ipOrCidrLit
|
||||
| hexByte -- 0xff
|
||||
| "true" | "false"
|
||||
| stringLit -- "..."
|
||||
| nat -- decimal integer
|
||||
|
||||
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
|
||||
portLit ::= ":" nat -- :22, :8080, :51944
|
||||
|
||||
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"
|
||||
```
|
||||
|
||||
### Internal IP Representation
|
||||
|
||||
IP addresses are stored as plain `Integer` values, not tuples or byte arrays:
|
||||
|
||||
| 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`.
|
||||
|
||||
---
|
||||
|
||||
## Reserved Keywords
|
||||
|
||||
Only these words are reserved (i.e. `identifier` will reject them):
|
||||
|
||||
```
|
||||
config table interface zone import from
|
||||
let in pattern flow rule policy on
|
||||
case of if then else do perform
|
||||
within as dynamic cidr4 cidr6
|
||||
hook priority
|
||||
WAN LAN WireGuard
|
||||
Input Forward Output Prerouting Postrouting
|
||||
Filter NAT Mangle DstNat SrcNat
|
||||
Raw ConnTrack
|
||||
true false
|
||||
```
|
||||
|
||||
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
|
||||
```
|
||||
|
||||
---
|
||||
|
||||
## Lexical Rules
|
||||
## Priority Constants
|
||||
|
||||
```ebnf
|
||||
ident ::= letter { letter | digit | "_" }
|
||||
-- must not be a reserved word
|
||||
Named priorities resolve to integers at parse time:
|
||||
|
||||
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"
|
||||
| "FlowPattern" | "Frame"
|
||||
| Name | Integer value |
|
||||
|-------------|---------------|
|
||||
| `Raw` | -300 |
|
||||
| `ConnTrack` | -200 |
|
||||
| `Mangle` | -150 |
|
||||
| `DstNat` | -100 |
|
||||
| `Filter` | 0 |
|
||||
| `SrcNat` | 100 |
|
||||
|
||||
comment ::= "--" { any char except newline }
|
||||
| "{-" { any char } "-}"
|
||||
|
||||
whitespace ::= space | tab | newline | comment
|
||||
```
|
||||
|
||||
Identifiers beginning with an uppercase letter are treated as constructor
|
||||
names by convention; those beginning with lowercase are variables. The lexer
|
||||
does not enforce this — it is a naming convention only, checked during
|
||||
type-checking.
|
||||
Arbitrary integers (including negative, e.g. `-150`) are also accepted.
|
||||
|
||||
---
|
||||
|
||||
## Resolved Inconsistencies from Proposal
|
||||
## Operator Precedence
|
||||
|
||||
The following decisions were made to normalize the proposal's syntax:
|
||||
From lowest to highest binding:
|
||||
|
||||
| Topic | Proposal state | MVP decision |
|
||||
|-------|---------------|--------------|
|
||||
| Interface body | Multiline, no delimiters | Braced block with `;` separators |
|
||||
| Policy body | `where` with indented arms | `=` followed by arm-block |
|
||||
| Rule body | `\frame -> case frame of \| ...` | `\ident -> expr`; `case` is a normal expression |
|
||||
| Policy vs rule | Distinct surface syntax | Policies use a bare arm-block; rules use `case` explicitly |
|
||||
| `Frame<{}>` | Unclear `<{}>` parameter | Parsed but ignored for MVP; written as `Frame` in practice |
|
||||
| Named patterns in sub-positions | Unclear | First-class everywhere; resolved at type-check time |
|
||||
| `∈` operator | Unicode only | Both `∈` and `in` accepted everywhere |
|
||||
| `Continue` | Unclear semantics | Legal `Action` constructor; compiles to nothing; type error if last arm of a policy block |
|
||||
| Single nftables table | Not specified | Default table name `fwl`; configurable via `config { table = "name"; }` |
|
||||
| `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`) |
|
||||
| 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
|
||||
|
||||
The following examples must all parse under the grammar above.
|
||||
|
||||
### 1. Interface and Zone
|
||||
### Interface and zone declarations
|
||||
|
||||
```fwl
|
||||
interface wan : WAN { dynamic; };
|
||||
interface lan : LAN {
|
||||
cidr4 = { 10.17.1.0/24 };
|
||||
cidr6 = { fe80::/10, fd12:3456::/48 };
|
||||
};
|
||||
interface wg0 : WireGuard {};
|
||||
interface wan : WAN { dynamic; };
|
||||
interface lan : LAN { cidr4 = { 10.17.1.0/24 }; };
|
||||
interface wg0 : WireGuard {};
|
||||
|
||||
zone lan_zone = { lan, wg0 };
|
||||
```
|
||||
|
||||
### 2. Import and Let
|
||||
### Map literal
|
||||
|
||||
```fwl
|
||||
import rfc1918 : CIDRSet from "builtin:rfc1918";
|
||||
|
||||
let forwards : Map<(Protocol, Port), (IP, Port)> = {
|
||||
(tcp, :8080) -> (10.17.1.10, :80),
|
||||
(tcp, :2222) -> (10.17.1.11, :22)
|
||||
};
|
||||
```
|
||||
|
||||
### 3. Pattern and Flow
|
||||
### Named patterns and flows
|
||||
|
||||
```fwl
|
||||
pattern WGInitiation : (UDPHeader, Bytes) =
|
||||
pattern WGInitiation : (UDPHeader, Bytes<{}>) =
|
||||
(udp { length = 156 }, [0x01 _*]);
|
||||
|
||||
pattern WGResponse : (UDPHeader, Bytes) =
|
||||
(udp { length = 100 }, [0x02 _*]);
|
||||
|
||||
flow WireGuardHandshake : FlowPattern =
|
||||
WGInitiation . WGResponse within 5s;
|
||||
```
|
||||
|
||||
### 4. Rule with Effects
|
||||
### Rule with effects
|
||||
|
||||
```fwl
|
||||
rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
|
||||
@@ -497,201 +372,28 @@ rule blockOutboundWG : Frame -> <FlowMatch, Log> Action =
|
||||
| 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: " ++ show(ip.src));
|
||||
Drop
|
||||
};
|
||||
| Matched -> do {
|
||||
perform Log.emit(Warn, "WG blocked");
|
||||
Drop
|
||||
};
|
||||
| _ -> Continue;
|
||||
};
|
||||
| _ -> Continue;
|
||||
};
|
||||
```
|
||||
|
||||
### 5. Filter Policy
|
||||
### Policy
|
||||
|
||||
```fwl
|
||||
policy input : Frame
|
||||
on { hook = Input, table = Filter, priority = Filter }
|
||||
= {
|
||||
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;
|
||||
| Frame(lo, _) -> Allow;
|
||||
| Frame(_, Ether(_, IPv4(_, TCP(tcp, _))))
|
||||
if tcp.dport == :22 -> Allow;
|
||||
| Frame(_, Ether(_, IPv4(_, UDP(udp, _))))
|
||||
if udp.dport == :51944 -> Allow;
|
||||
| _ -> 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
1
doc/ref/ruleset-1.json
Normal file
File diff suppressed because one or more lines are too long
163
doc/ref/ruleset-1.nft
Normal file
163
doc/ref/ruleset-1.nft
Normal file
@@ -0,0 +1,163 @@
|
||||
#!/usr/sbin/nft -f
|
||||
# Compiled from examples/router.fwl
|
||||
# Single inet table: fwl
|
||||
|
||||
flush ruleset
|
||||
|
||||
table inet fwl {
|
||||
|
||||
# ── Data: let rfc1918 ────────────────────────────────────────────────────
|
||||
set rfc1918 {
|
||||
type ipv4_addr
|
||||
flags interval
|
||||
elements = {
|
||||
10.0.0.0/8,
|
||||
172.16.0.0/12,
|
||||
192.168.0.0/16
|
||||
}
|
||||
}
|
||||
|
||||
# ── Data: let forwards ──────────────────────────────────────────────────
|
||||
map forwards {
|
||||
type inet_proto . inet_service : ipv4_addr . inet_service
|
||||
elements = {
|
||||
tcp . 8080 : 10.17.1.10 . 80,
|
||||
tcp . 2222 : 10.17.1.11 . 22
|
||||
}
|
||||
}
|
||||
|
||||
# ── WireGuard ct mark state machine ─────────────────────────────────────
|
||||
# Compiles: flow WireGuardHandshake = WGInitiation . WGResponse within 5s
|
||||
# State: ct mark 0 = Idle, 1 = SawInitiation, 2 = Confirmed
|
||||
#
|
||||
# WGInitiation: UDP, udp length == 156 (8 hdr + 148 payload), payload[0] == 0x01
|
||||
# WGResponse: UDP, udp length == 100 (8 hdr + 92 payload), payload[0] == 0x02
|
||||
# @th,64,8 = first byte of UDP payload (offset 64 bits past transport header start)
|
||||
|
||||
chain wg_flow {
|
||||
# Packet 1: Idle → SawInitiation
|
||||
ct state new ct mark 0 \
|
||||
meta l4proto udp udp length 156 \
|
||||
@th,64,8 0x01 \
|
||||
ct mark set 1 \
|
||||
return
|
||||
|
||||
# Packet 2: SawInitiation → Confirmed
|
||||
ct mark 1 \
|
||||
meta l4proto udp udp length 100 \
|
||||
@th,64,8 0x02 \
|
||||
ct mark set 2 \
|
||||
return
|
||||
}
|
||||
|
||||
# ── rule blockOutboundWG ─────────────────────────────────────────────────
|
||||
# Compiles: rule blockOutboundWG : Frame -> <FlowMatch, Log> Action
|
||||
# Called via jump from forward. Drops confirmed WG handshakes, returns otherwise.
|
||||
|
||||
chain blockOutboundWG {
|
||||
# Feed matching UDP into the WG state machine
|
||||
meta nfproto ipv4 meta l4proto udp \
|
||||
udp length 156 \
|
||||
@th,64,8 0x01 \
|
||||
jump wg_flow
|
||||
|
||||
# If handshake is now Confirmed (ct mark 2): log + drop
|
||||
ct mark 2 \
|
||||
log prefix "WG blocked: " level warn \
|
||||
drop
|
||||
|
||||
# Continue: return to forward chain (no verdict)
|
||||
return
|
||||
}
|
||||
|
||||
# ── policy input ─────────────────────────────────────────────────────────
|
||||
# hook = Input, table = Filter, priority = filter (0), default = drop
|
||||
|
||||
chain input {
|
||||
type filter hook input priority filter; policy drop;
|
||||
|
||||
# | _ if ct.state in { Established, Related } -> Allow
|
||||
ct state { established, related } accept
|
||||
|
||||
# | Frame(lo, _) -> Allow
|
||||
iifname "lo" accept
|
||||
|
||||
# | Frame(_, IPv6(ip6, ICMPv6(_, _))) if ip6.src in fe80::/10 -> Allow
|
||||
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
|
||||
|
||||
# | Frame(_, IPv4(_, TCP(tcp, _))) if tcp.dport == :22 -> Allow
|
||||
meta nfproto ipv4 meta l4proto tcp tcp dport 22 accept
|
||||
|
||||
# | Frame(_, IPv4(_, UDP(udp, _))) if udp.dport == :51944 -> Allow
|
||||
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
|
||||
|
||||
# | _ -> Drop (chain policy)
|
||||
}
|
||||
|
||||
# ── policy forward ───────────────────────────────────────────────────────
|
||||
# hook = Forward, table = Filter, priority = filter (0), default = drop
|
||||
|
||||
chain forward {
|
||||
type filter hook forward priority filter; policy drop;
|
||||
|
||||
# | _ if ct.state in { Established, Related } -> Allow
|
||||
ct state { established, related } accept
|
||||
|
||||
# | frame if iif in lan_zone && oif == wan -> blockOutboundWG(frame)
|
||||
meta iifname { "lan", "wg0" } meta oifname "wan" jump blockOutboundWG
|
||||
|
||||
# | _ if ct.status == DNAT -> Allow
|
||||
ct status dnat accept
|
||||
|
||||
# | Frame(iif in lan_zone -> wan, _) -> Allow
|
||||
meta iifname { "lan", "wg0" } meta oifname "wan" accept
|
||||
|
||||
# | Frame(iif in lan_zone -> lan_zone, _) -> Allow
|
||||
meta iifname { "lan", "wg0" } meta oifname { "lan", "wg0" } accept
|
||||
|
||||
# | Frame(wan -> lan_zone, IPv4(ip, TCP|UDP)) if (proto, dport) in forwards -> Allow
|
||||
# Membership test only — the actual DNAT is done in nat_prerouting.
|
||||
meta iifname "wan" meta oifname { "lan", "wg0" } \
|
||||
meta nfproto ipv4 \
|
||||
meta l4proto { tcp, udp } \
|
||||
meta l4proto . th dport @forwards \
|
||||
accept
|
||||
|
||||
# | _ -> Drop (chain policy)
|
||||
}
|
||||
|
||||
# ── policy output ────────────────────────────────────────────────────────
|
||||
# hook = Output, table = Filter, priority = filter (0), default = accept
|
||||
|
||||
chain output {
|
||||
type filter hook output priority filter; policy accept;
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
|
||||
# ── policy nat_prerouting ────────────────────────────────────────────────
|
||||
# hook = Prerouting, table = NAT, priority = dstnat (-100), default = accept
|
||||
|
||||
chain nat_prerouting {
|
||||
type nat hook prerouting priority dstnat; policy accept;
|
||||
|
||||
# | Frame(_, IPv4(ip, TCP|UDP)) ->
|
||||
# if FIB.daddrLocal(ip.dst) then DNATMap((proto, dport), forwards) else Allow
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
fib daddr type local \
|
||||
dnat ip to meta l4proto . th dport map @forwards
|
||||
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
|
||||
# ── policy nat_postrouting ───────────────────────────────────────────────
|
||||
# hook = Postrouting, table = NAT, priority = srcnat (100), default = accept
|
||||
|
||||
chain nat_postrouting {
|
||||
type nat hook postrouting priority srcnat; policy accept;
|
||||
|
||||
# | Frame(_ -> wan, IPv4(ip, _)) if ip.src in rfc1918 -> Masquerade
|
||||
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
|
||||
|
||||
# | _ -> Allow (chain policy)
|
||||
}
|
||||
}
|
||||
95
examples/router.fwl
Normal file
95
examples/router.fwl
Normal 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;
|
||||
};
|
||||
69
examples/simple-router.fwl
Normal file
69
examples/simple-router.fwl
Normal 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;
|
||||
};
|
||||
955
examples/simple-router.fwl.json
Normal file
955
examples/simple-router.fwl.json
Normal 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"
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
98
examples/simple-router.nft
Normal file
98
examples/simple-router.nft
Normal file
@@ -0,0 +1,98 @@
|
||||
table inet fwl {
|
||||
|
||||
# ── let rfc1918 ──────────────────────────────────────────────────────────
|
||||
set rfc1918 {
|
||||
type ipv4_addr
|
||||
flags interval
|
||||
elements = {
|
||||
10.0.0.0/8,
|
||||
172.16.0.0/12,
|
||||
192.168.0.0/16
|
||||
}
|
||||
}
|
||||
|
||||
# ── let open_ports : Set<Port> ───────────────────────────────────────────
|
||||
set open_ports {
|
||||
type inet_service
|
||||
elements = { 22 }
|
||||
}
|
||||
|
||||
# ── let forwards_v6 : Set<(Protocol, IP, Port)> ──────────────────────────
|
||||
set forwards_v6 {
|
||||
type inet_proto . ipv6_addr . inet_service
|
||||
elements = {
|
||||
tcp . 2001:db8::1 . 22000
|
||||
}
|
||||
}
|
||||
|
||||
# ── let forwards : Map<(Protocol, Port), (IP, Port)> ────────────────────
|
||||
map forwards {
|
||||
type inet_proto . inet_service : ipv4_addr . inet_service
|
||||
elements = {
|
||||
tcp . 8080 : 10.0.0.10 . 80
|
||||
}
|
||||
}
|
||||
|
||||
# ── zone lan_zone = { lan } ──────────────────────────────────────────────
|
||||
# Zones compile to anonymous sets wherever referenced in iifname/oifname.
|
||||
# With a single member the set degenerates to a plain string match,
|
||||
# but we keep the set form so the compiler output is uniform regardless
|
||||
# of zone size.
|
||||
set lan_zone {
|
||||
type ifname
|
||||
elements = { "lan" }
|
||||
}
|
||||
|
||||
# ── policy input ─────────────────────────────────────────────────────────
|
||||
chain input {
|
||||
type filter hook input priority filter; policy drop;
|
||||
|
||||
ct state { established, related } accept
|
||||
iifname "lo" accept
|
||||
meta nfproto ipv6 ip6 nexthdr ipv6-icmp ip6 saddr fe80::/10 accept
|
||||
meta nfproto ipv4 meta l4proto tcp tcp dport @open_ports accept
|
||||
meta nfproto ipv4 meta l4proto udp udp dport 51944 accept
|
||||
}
|
||||
|
||||
# ── policy forward ───────────────────────────────────────────────────────
|
||||
chain forward {
|
||||
type filter hook forward priority filter; policy drop;
|
||||
|
||||
ct state { established, related } accept
|
||||
ct status dnat accept
|
||||
|
||||
# | Frame(iif in lan_zone -> wan, _) -> Allow
|
||||
meta iifname @lan_zone meta oifname "wan" accept
|
||||
|
||||
# | Frame(wan -> iif in lan_zone, IPv4 TCP|UDP) if (proto,dport) in forwards
|
||||
meta iifname "wan" meta oifname @lan_zone \
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
meta l4proto . th dport @forwards accept
|
||||
|
||||
# | Frame(wan -> iif in lan_zone, IPv6 TCP|UDP) if (proto,dst,dport) in forwards_v6
|
||||
meta iifname "wan" meta oifname @lan_zone \
|
||||
meta nfproto ipv6 meta l4proto { tcp, udp } \
|
||||
meta l4proto . ip6 daddr . th dport @forwards_v6 accept
|
||||
}
|
||||
|
||||
# ── policy output ────────────────────────────────────────────────────────
|
||||
chain output {
|
||||
type filter hook output priority filter; policy accept;
|
||||
}
|
||||
|
||||
# ── policy nat_prerouting ────────────────────────────────────────────────
|
||||
chain nat_prerouting {
|
||||
type nat hook prerouting priority dstnat; policy accept;
|
||||
|
||||
meta nfproto ipv4 meta l4proto { tcp, udp } \
|
||||
fib daddr type local \
|
||||
dnat ip to meta l4proto . th dport map @forwards
|
||||
}
|
||||
|
||||
# ── policy nat_postrouting ───────────────────────────────────────────────
|
||||
chain nat_postrouting {
|
||||
type nat hook postrouting priority srcnat; policy accept;
|
||||
|
||||
meta oifname "wan" meta nfproto ipv4 ip saddr @rfc1918 masquerade
|
||||
}
|
||||
}
|
||||
693
examples/simple-router.nft.json
Normal file
693
examples/simple-router.nft.json
Normal file
@@ -0,0 +1,693 @@
|
||||
{
|
||||
"nftables": [
|
||||
{
|
||||
"metainfo": {
|
||||
"version": "1.1.6",
|
||||
"release_name": "Commodore Bullmoose #7",
|
||||
"json_schema_version": 1
|
||||
}
|
||||
},
|
||||
{
|
||||
"table": {
|
||||
"family": "inet",
|
||||
"name": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "input",
|
||||
"type": "filter",
|
||||
"hook": "input",
|
||||
"prio": 0,
|
||||
"policy": "drop"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "forward",
|
||||
"type": "filter",
|
||||
"hook": "forward",
|
||||
"prio": 0,
|
||||
"policy": "drop"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "output",
|
||||
"type": "filter",
|
||||
"hook": "output",
|
||||
"prio": 0,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "nat_prerouting",
|
||||
"type": "nat",
|
||||
"hook": "prerouting",
|
||||
"prio": -100,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"name": "nat_postrouting",
|
||||
"type": "nat",
|
||||
"hook": "postrouting",
|
||||
"prio": 100,
|
||||
"policy": "accept"
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "rfc1918",
|
||||
"table": "fwl",
|
||||
"type": "ipv4_addr",
|
||||
"flags": [
|
||||
"interval"
|
||||
],
|
||||
"elem": [
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "10.0.0.0",
|
||||
"len": 8
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "172.16.0.0",
|
||||
"len": 12
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "192.168.0.0",
|
||||
"len": 16
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "open_ports",
|
||||
"table": "fwl",
|
||||
"type": "inet_service",
|
||||
"elem": [
|
||||
22
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "forwards_v6",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"ipv6_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"elem": [
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
"2001:db8::1",
|
||||
22000
|
||||
]
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"map": {
|
||||
"family": "inet",
|
||||
"name": "forwards",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"inet_service"
|
||||
],
|
||||
"map": [
|
||||
"ipv4_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"elem": [
|
||||
[
|
||||
{
|
||||
"concat": [
|
||||
"tcp",
|
||||
8080
|
||||
]
|
||||
},
|
||||
{
|
||||
"concat": [
|
||||
"10.0.0.10",
|
||||
80
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"family": "inet",
|
||||
"name": "lan_zone",
|
||||
"table": "fwl",
|
||||
"type": "ifname",
|
||||
"elem": [
|
||||
"lan"
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "lo"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "nexthdr"
|
||||
}
|
||||
},
|
||||
"right": "ipv6-icmp"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "saddr"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"prefix": {
|
||||
"addr": "fe80::",
|
||||
"len": 10
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "tcp",
|
||||
"field": "dport"
|
||||
}
|
||||
},
|
||||
"right": "@open_ports"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "udp",
|
||||
"field": "dport"
|
||||
}
|
||||
},
|
||||
"right": 51944
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "in",
|
||||
"left": {
|
||||
"ct": {
|
||||
"key": "status"
|
||||
}
|
||||
},
|
||||
"right": "dnat"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"right": "@forwards"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "forward",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "iifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "@lan_zone"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "ip6",
|
||||
"field": "daddr"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"right": "@forwards_v6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "nat_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"fib": {
|
||||
"result": "type",
|
||||
"flags": [
|
||||
"daddr"
|
||||
]
|
||||
}
|
||||
},
|
||||
"right": "local"
|
||||
}
|
||||
},
|
||||
{
|
||||
"dnat": {
|
||||
"family": "ip",
|
||||
"addr": {
|
||||
"map": {
|
||||
"key": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
"payload": {
|
||||
"protocol": "th",
|
||||
"field": "dport"
|
||||
}
|
||||
}
|
||||
]
|
||||
},
|
||||
"data": "@forwards"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"family": "inet",
|
||||
"table": "fwl",
|
||||
"chain": "nat_postrouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "oifname"
|
||||
}
|
||||
},
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"op": "==",
|
||||
"left": {
|
||||
"payload": {
|
||||
"protocol": "ip",
|
||||
"field": "saddr"
|
||||
}
|
||||
},
|
||||
"right": "@rfc1918"
|
||||
}
|
||||
},
|
||||
{
|
||||
"masquerade": null
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
20
fwl.cabal
20
fwl.cabal
@@ -36,3 +36,23 @@ executable fwlc
|
||||
hs-source-dirs: app
|
||||
build-depends:
|
||||
base, fwl, text, aeson-pretty, bytestring
|
||||
|
||||
test-suite fwl-tests
|
||||
import: shared
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test
|
||||
other-modules:
|
||||
FWL.Util
|
||||
, ParserTests
|
||||
, CheckTests
|
||||
, CompileTests
|
||||
build-depends:
|
||||
base, fwl
|
||||
, tasty >= 1.4
|
||||
, tasty-hunit >= 0.10
|
||||
, aeson >= 2.0
|
||||
, aeson-pretty >= 0.8
|
||||
, bytestring >= 0.11
|
||||
, parsec >= 3.1
|
||||
, vector >= 0.12
|
||||
|
||||
122
src/FWL/AST.hs
122
src/FWL/AST.hs
@@ -1,6 +1,7 @@
|
||||
module FWL.AST where
|
||||
|
||||
import Data.Word (Word8, Word16)
|
||||
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
|
||||
import Data.Word (Word8) -- Word8 still used for ByteElem/hex literals
|
||||
|
||||
type Name = String
|
||||
|
||||
@@ -27,7 +28,7 @@ data Decl
|
||||
| DLet Name Type Expr
|
||||
| DPattern Name Type Pat
|
||||
| DFlow Name FlowExpr
|
||||
| DRule Name Type Expr -- body must be ELam
|
||||
| DRule Name Type Expr
|
||||
| DPolicy Name Type PolicyMeta ArmBlock
|
||||
deriving (Show)
|
||||
|
||||
@@ -41,9 +42,22 @@ data Hook = HInput | HForward | HOutput | HPrerouting | HPostrouting
|
||||
deriving (Show, Eq)
|
||||
data TableName = TFilter | TNAT
|
||||
deriving (Show, Eq)
|
||||
data Priority = PFilter | PDstNat | PSrcNat | PMangle | PInt Int
|
||||
-- Priority is always an integer in the nftables JSON.
|
||||
-- Named constants are resolved to their numeric values at parse time.
|
||||
newtype Priority = Priority { priorityValue :: Int }
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Standard nftables priority constants
|
||||
pRaw, pConnTrackDefrag, pConnTrack, pMangle, pDstNat, pFilter, pSecurity, pSrcNat :: Priority
|
||||
pRaw = Priority (-300)
|
||||
pConnTrackDefrag = Priority (-400)
|
||||
pConnTrack = Priority (-200)
|
||||
pMangle = Priority (-150)
|
||||
pDstNat = Priority (-100)
|
||||
pFilter = Priority 0
|
||||
pSecurity = Priority 50
|
||||
pSrcNat = Priority 100
|
||||
|
||||
data IfaceKind = IWan | ILan | IWireGuard | IUser Name
|
||||
deriving (Show)
|
||||
|
||||
@@ -53,23 +67,28 @@ data IfaceProp
|
||||
| IPCidr6 [CIDR]
|
||||
deriving (Show)
|
||||
|
||||
-- | A CIDR block: base address literal paired with prefix length.
|
||||
-- e.g. (LIPv4 (10,0,0,0), 8) represents 10.0.0.0/8
|
||||
type CIDR = (Literal, Int)
|
||||
|
||||
-- ─── Patterns ───────────────────────────────────────────────────────────────
|
||||
|
||||
data Pat
|
||||
= PWild
|
||||
| PVar Name
|
||||
| PNamed Name -- first-class named pattern ref
|
||||
| PCtor Name [Pat] -- IPv4(ip, ...), TCP(tcp, ...)
|
||||
| PRecord Name [FieldPat] -- udp { length = 156 }
|
||||
| PNamed Name
|
||||
| PCtor Name [Pat]
|
||||
| PRecord Name [FieldPat]
|
||||
| PTuple [Pat]
|
||||
| PFrame (Maybe PathPat) Pat -- Frame(path?, inner)
|
||||
| PFrame (Maybe PathPat) Pat
|
||||
| PBytes [ByteElem]
|
||||
| POr Pat Pat
|
||||
deriving (Show)
|
||||
|
||||
data FieldPat
|
||||
= FPEq Name Literal -- field = literal
|
||||
| FPBind Name -- bind field to same-named var
|
||||
| FPAs Name Name -- field as var
|
||||
= FPEq Name Literal
|
||||
| FPBind Name
|
||||
| FPAs Name Name
|
||||
deriving (Show)
|
||||
|
||||
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
|
||||
@@ -78,13 +97,13 @@ data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
|
||||
data EndpointPat
|
||||
= EPWild
|
||||
| EPName Name
|
||||
| EPMember Name Name -- iif `in` zone
|
||||
| EPMember Name Name
|
||||
deriving (Show)
|
||||
|
||||
data ByteElem
|
||||
= BEHex Word8
|
||||
| BEWild -- _ (one byte)
|
||||
| BEWildStar -- _* (zero or more)
|
||||
| BEWild
|
||||
| BEWildStar
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Flow ───────────────────────────────────────────────────────────────────
|
||||
@@ -95,8 +114,11 @@ data FlowExpr
|
||||
deriving (Show)
|
||||
|
||||
type Duration = (Int, TimeUnit)
|
||||
|
||||
-- Fix 1: TimeUnit must derive Eq because Literal (which embeds it via
|
||||
-- LDuration) derives Eq, requiring all constituent types to also have Eq.
|
||||
data TimeUnit = Seconds | Millis | Minutes | Hours
|
||||
deriving (Show)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ─── Types ──────────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -111,7 +133,7 @@ data Type
|
||||
|
||||
data Expr
|
||||
= EVar Name
|
||||
| EQual [Name] -- qualified name, e.g. Log.emit
|
||||
| EQual [Name]
|
||||
| ELit Literal
|
||||
| ELam Name Expr
|
||||
| EApp Expr Expr
|
||||
@@ -122,7 +144,7 @@ data Expr
|
||||
| ETuple [Expr]
|
||||
| ESet [Expr]
|
||||
| EMap [(Expr, Expr)]
|
||||
| EPerform [Name] [Expr] -- perform QualName(args)
|
||||
| EPerform [Name] [Expr]
|
||||
| EInfix InfixOp Expr Expr
|
||||
| ENot Expr
|
||||
deriving (Show)
|
||||
@@ -130,10 +152,10 @@ data Expr
|
||||
data InfixOp
|
||||
= OpAnd | OpOr
|
||||
| OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
|
||||
| OpIn -- `in` / `∈`
|
||||
| OpConcat -- ++
|
||||
| OpThen -- >>
|
||||
| OpBind -- >>=
|
||||
| OpIn
|
||||
| OpConcat
|
||||
| OpThen
|
||||
| OpBind
|
||||
deriving (Show, Eq)
|
||||
|
||||
data DoStmt
|
||||
@@ -142,19 +164,71 @@ data DoStmt
|
||||
deriving (Show)
|
||||
|
||||
type ArmBlock = [Arm]
|
||||
data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard?, body
|
||||
data Arm = Arm Pat (Maybe Expr) Expr
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Literals ───────────────────────────────────────────────────────────────
|
||||
|
||||
-- IP addresses are stored as plain Integers for easy arithmetic,
|
||||
-- CIDR validation (mask host bits), and future subnet math.
|
||||
-- IPv4: 32-bit value in the low 32 bits.
|
||||
-- IPv6: 128-bit value.
|
||||
-- CIDR host-bit validation: (addr .&. hostMask prefix bits) == 0
|
||||
data IPVersion = IPv4 | IPv6
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Literal
|
||||
= LInt Int
|
||||
| LString String
|
||||
| LBool Bool
|
||||
| LIPv4 (Word8,Word8,Word8,Word8)
|
||||
| LIPv6 [Word16]
|
||||
| LCIDR Literal Int
|
||||
| LIP IPVersion Integer -- unified IP address representation
|
||||
| LCIDR Literal Int -- base address + prefix length
|
||||
| LPort Int
|
||||
| LDuration Int TimeUnit
|
||||
| LHex Word8
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ─── IP address helpers ──────────────────────────────────────────────────────
|
||||
|
||||
-- | Build an IPv4 literal from four octets.
|
||||
ipv4Lit :: Int -> Int -> Int -> Int -> Literal
|
||||
ipv4Lit a b c d =
|
||||
LIP IPv4 (fromIntegral a `shiftL` 24
|
||||
.|. fromIntegral b `shiftL` 16
|
||||
.|. fromIntegral c `shiftL` 8
|
||||
.|. fromIntegral d)
|
||||
|
||||
-- | Check that a CIDR has no host bits set.
|
||||
cidrHostBitsZero :: Integer -> Int -> Int -> Bool
|
||||
cidrHostBitsZero addr prefix bits =
|
||||
let hostBits = bits - prefix
|
||||
hostMask = (1 `shiftL` hostBits) - 1
|
||||
in (addr .&. hostMask) == 0
|
||||
|
||||
-- | Render an IPv4 integer as a dotted-decimal string.
|
||||
renderIPv4 :: Integer -> String
|
||||
renderIPv4 n =
|
||||
show ((n `shiftR` 24) .&. 0xff) ++ "." ++
|
||||
show ((n `shiftR` 16) .&. 0xff) ++ "." ++
|
||||
show ((n `shiftR` 8) .&. 0xff) ++ "." ++
|
||||
show (n .&. 0xff)
|
||||
|
||||
-- | Render an IPv6 integer as a condensed colon-hex string.
|
||||
renderIPv6 :: Integer -> String
|
||||
renderIPv6 n =
|
||||
let groups = [ fromIntegral ((n `shiftR` (i * 16)) .&. 0xffff) :: Int
|
||||
| i <- [7,6..0] ]
|
||||
hexGroups = map (`showHex` "") groups
|
||||
in concatIntersperse ":" hexGroups
|
||||
where
|
||||
showHex x s = let h = showHexInt x in h ++ s
|
||||
showHexInt x
|
||||
| x == 0 = "0"
|
||||
| otherwise = reverse (go x)
|
||||
where go 0 = []
|
||||
go v = let (q,r) = v `divMod` 16
|
||||
c = "0123456789abcdef" !! r
|
||||
in c : go q
|
||||
concatIntersperse _ [] = ""
|
||||
concatIntersperse _ [x] = x
|
||||
concatIntersperse s (x:xs) = x ++ s ++ concatIntersperse s xs
|
||||
|
||||
@@ -9,7 +9,7 @@ module FWL.Check
|
||||
, CheckError(..)
|
||||
) where
|
||||
|
||||
import Data.List (foldl', nub)
|
||||
import Data.List (nub)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@@ -20,6 +20,7 @@ data CheckError
|
||||
| PolicyNoContinue String -- policy name
|
||||
| PatternCycle [String] -- cycle path
|
||||
| DuplicateDecl String String -- kind, name
|
||||
| OrPatternMismatch [String] [String]
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Env = Map.Map String DeclKind
|
||||
@@ -43,12 +44,12 @@ buildEnv = foldl' addDecl Map.empty
|
||||
where
|
||||
addDecl m (DInterface n _ _) = Map.insert n KInterface m
|
||||
addDecl m (DZone n _) = Map.insert n KZone m
|
||||
addDecl m (DImport n _ _) = Map.insert n KLet m
|
||||
addDecl m (DLet n _ _) = Map.insert n KLet m
|
||||
addDecl m (DPattern n _ _) = Map.insert n KPattern m
|
||||
addDecl m (DFlow n _) = Map.insert n KFlow m
|
||||
addDecl m (DRule n _ _) = Map.insert n KRule m
|
||||
addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m
|
||||
addDecl m _ = m
|
||||
|
||||
findDups :: [Decl] -> [CheckError]
|
||||
findDups decls = go [] Set.empty decls
|
||||
@@ -100,11 +101,12 @@ checkName env kind n
|
||||
isBuiltin :: String -> Bool
|
||||
isBuiltin n = n `elem`
|
||||
[ "ct", "iif", "oif", "lo", "wan", "lan"
|
||||
, "tcp", "udp", "ip", "ip6", "eth"
|
||||
, "tcp", "udp", "ip", "ip6", "eth", "wg"
|
||||
, "Established", "Related", "DNAT"
|
||||
, "Allow", "Drop", "Continue", "Masquerade"
|
||||
, "Allow", "Drop", "Continue", "Masquerade", "DNATMap"
|
||||
, "Matched", "Unmatched"
|
||||
, "true", "false"
|
||||
, "matches", "flowOf", "Warn"
|
||||
]
|
||||
|
||||
checkPat :: Env -> Pat -> [CheckError]
|
||||
@@ -116,6 +118,25 @@ checkPat env (PRecord _ fs) = concatMap (checkFP env) fs
|
||||
checkPat env (PTuple ps) = concatMap (checkPat env) ps
|
||||
checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner
|
||||
checkPat _ (PBytes _) = []
|
||||
checkPat env (POr p1 p2) =
|
||||
let v1 = boundVars p1
|
||||
v2 = boundVars p2
|
||||
errs = if Set.fromList v1 == Set.fromList v2 then [] else [OrPatternMismatch v1 v2]
|
||||
in errs ++ checkPat env p1 ++ checkPat env p2
|
||||
|
||||
boundVars :: Pat -> [String]
|
||||
boundVars (PVar n) = [n]
|
||||
boundVars (PCtor _ ps) = concatMap boundVars ps
|
||||
boundVars (PRecord _ fs) = concatMap boundFP fs
|
||||
boundVars (PTuple ps) = concatMap boundVars ps
|
||||
boundVars (PFrame _ p) = boundVars p
|
||||
boundVars (POr p1 p2) = boundVars p1
|
||||
boundVars _ = []
|
||||
|
||||
boundFP :: FieldPat -> [String]
|
||||
boundFP (FPBind n) = [n]
|
||||
boundFP (FPAs _ v) = [v]
|
||||
boundFP _ = []
|
||||
|
||||
checkFP :: Env -> FieldPat -> [CheckError]
|
||||
checkFP _ _ = [] -- field names checked by type-checker later
|
||||
@@ -135,15 +156,36 @@ checkFlow env (FSeq a b _) = checkFlow env a ++ checkFlow env b
|
||||
|
||||
checkArm :: Env -> Arm -> [CheckError]
|
||||
checkArm env (Arm p mg e) =
|
||||
let env' = addPat env p in
|
||||
checkPat env p ++
|
||||
maybe [] (checkExpr env) mg ++
|
||||
checkExpr env e
|
||||
maybe [] (checkExpr env') mg ++
|
||||
checkExpr env' e
|
||||
|
||||
addPat :: Env -> Pat -> Env
|
||||
addPat env (PVar n) = Map.insert n KLet env
|
||||
addPat env (PCtor _ ps) = foldl' addPat env ps
|
||||
addPat env (PTuple ps) = foldl' addPat env ps
|
||||
addPat env (PRecord _ fs) = foldl' addFP env fs
|
||||
addPat env (PFrame mp inner) =
|
||||
let env' = case mp of
|
||||
Just (PathPat ms md) ->
|
||||
let env1 = case ms of Just (EPName n) -> Map.insert n KLet env; _ -> env
|
||||
in case md of Just (EPName n) -> Map.insert n KLet env1; _ -> env1
|
||||
Nothing -> env
|
||||
in addPat env' inner
|
||||
addPat env (POr p1 _) = addPat env p1
|
||||
addPat env _ = env
|
||||
|
||||
addFP :: Env -> FieldPat -> Env
|
||||
addFP env (FPBind n) = Map.insert n KLet env
|
||||
addFP env (FPAs _ v) = Map.insert v KLet env
|
||||
addFP env _ = env
|
||||
|
||||
checkExpr :: Env -> Expr -> [CheckError]
|
||||
checkExpr env (EVar n) = checkName env "name" n
|
||||
checkExpr _ (EQual _) = [] -- qualified names: deferred
|
||||
checkExpr _ (ELit _) = []
|
||||
checkExpr env (ELam _ e) = checkExpr env e
|
||||
checkExpr env (ELam n e) = checkExpr (Map.insert n KLet env) e
|
||||
checkExpr env (EApp f x) = checkExpr env f ++ checkExpr env x
|
||||
checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab
|
||||
checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f]
|
||||
@@ -190,6 +232,7 @@ checkPatternCycles decls =
|
||||
refsInPat (PCtor _ ps) = concatMap refsInPat ps
|
||||
refsInPat (PTuple ps) = concatMap refsInPat ps
|
||||
refsInPat (PFrame _ p) = refsInPat p
|
||||
refsInPat (POr p1 p2) = refsInPat p1 ++ refsInPat p2
|
||||
refsInPat _ = []
|
||||
|
||||
findCycles :: Map.Map String [String] -> [[String]]
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{- | Compile a checked FWL program to nftables JSON using Aeson.
|
||||
All policies (Filter and NAT) go into one table named by Config.
|
||||
Layer stripping: Frame patterns that omit Ether compile identically
|
||||
to those that include it — the compiler inserts protocol matches
|
||||
from whatever constructor the user wrote.
|
||||
to those that include it.
|
||||
-}
|
||||
module FWL.Compile
|
||||
( compileProgram
|
||||
@@ -12,37 +12,43 @@ module FWL.Compile
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson ((.=), Value(..), object, toJSON)
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Aeson.Encode.Pretty as Pretty
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
|
||||
import FWL.AST
|
||||
|
||||
-- ─── Entry points ────────────────────────────────────────────────────────────
|
||||
|
||||
-- | Compile an FWL program and render to pretty-printed JSON bytes.
|
||||
compileToJson :: Program -> BL.ByteString
|
||||
compileToJson = Pretty.encodePretty . programToValue
|
||||
compileToJson = encodePretty . programToValue
|
||||
|
||||
-- exposed for tests
|
||||
compileProgram :: Program -> Value
|
||||
compileProgram = programToValue
|
||||
|
||||
-- | Compile an FWL program to an Aeson Value (the nftables JSON schema).
|
||||
programToValue :: Program -> Value
|
||||
programToValue prog@(Program cfg decls) =
|
||||
object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
|
||||
programToValue (Program cfg decls) =
|
||||
object [ "nftables" .= toJSON
|
||||
(metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
|
||||
where
|
||||
env = buildEnv decls
|
||||
tbl = configTable cfg
|
||||
|
||||
metainfo = object [ "metainfo" .= object [ "json_schema_version" .= (1 :: Int) ] ]
|
||||
tableObj = object [ "table" .= tableValue tbl ]
|
||||
metainfo = object [ "metainfo" .= object
|
||||
[ "json_schema_version" .= (1 :: Int) ] ]
|
||||
tableObj = object [ "table" .= tableValue tbl ]
|
||||
|
||||
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
|
||||
chainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
|
||||
ruleObjs = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies
|
||||
chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies
|
||||
ruleObjs = concatMap
|
||||
(\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab)
|
||||
policies
|
||||
|
||||
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 ──────────────────────────────────────────────
|
||||
|
||||
@@ -60,7 +66,7 @@ chainDeclValue tbl n pm = object
|
||||
, "name" .= n
|
||||
, "type" .= chainTypeStr (pmTable pm)
|
||||
, "hook" .= hookStr (pmHook pm)
|
||||
, "prio" .= priorityStr (pmPriority pm)
|
||||
, "prio" .= priorityInt (pmPriority pm)
|
||||
, "policy" .= defaultPolicyStr (pmHook pm)
|
||||
]
|
||||
]
|
||||
@@ -76,14 +82,10 @@ hookStr HOutput = "output"
|
||||
hookStr HPrerouting = "prerouting"
|
||||
hookStr HPostrouting = "postrouting"
|
||||
|
||||
priorityStr :: Priority -> String
|
||||
priorityStr PFilter = "filter"
|
||||
priorityStr PDstNat = "dstnat"
|
||||
priorityStr PSrcNat = "srcnat"
|
||||
priorityStr PMangle = "mangle"
|
||||
priorityStr (PInt n) = show n
|
||||
-- Priority is emitted as an integer in nftables JSON.
|
||||
priorityInt :: Priority -> Int
|
||||
priorityInt = priorityValue
|
||||
|
||||
-- Input and Forward hooks default to drop; everything else to accept.
|
||||
defaultPolicyStr :: Hook -> String
|
||||
defaultPolicyStr HInput = "drop"
|
||||
defaultPolicyStr HForward = "drop"
|
||||
@@ -91,25 +93,22 @@ defaultPolicyStr _ = "accept"
|
||||
|
||||
-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
|
||||
|
||||
-- Each policy arm becomes zero or more nftables rule objects.
|
||||
-- An arm whose action is Continue compiles to zero rules.
|
||||
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value]
|
||||
armToRuleValues env tbl chain (Arm p mg body) =
|
||||
case compileAction env body of
|
||||
Nothing -> [] -- Continue: emit nothing
|
||||
Nothing -> []
|
||||
Just verdict ->
|
||||
let patExprs = compilePat env p
|
||||
guardExprs = maybe [] (compileGuard env) mg
|
||||
allExprs = patExprs ++ guardExprs ++ [verdict]
|
||||
let patExprsAlts = compilePat env p
|
||||
guardExprs = maybe [] (compileGuard env) mg
|
||||
in [ object
|
||||
[ "rule" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "chain" .= chain
|
||||
, "expr" .= toJSON allExprs
|
||||
, "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict])
|
||||
]
|
||||
]
|
||||
]
|
||||
| patExprs <- patExprsAlts ]
|
||||
|
||||
-- ─── Pattern → [Value] ───────────────────────────────────────────────────────
|
||||
|
||||
@@ -127,83 +126,83 @@ buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty
|
||||
declNameOf (DLet n _ _) = n
|
||||
declNameOf (DImport n _ _) = n
|
||||
|
||||
compilePat :: CompileEnv -> Pat -> [Value]
|
||||
compilePat _ PWild = []
|
||||
compilePat _ (PVar _) = []
|
||||
compilePat :: CompileEnv -> Pat -> [[Value]]
|
||||
compilePat _ PWild = [[]]
|
||||
compilePat _ (PVar _) = [[]]
|
||||
compilePat env (PNamed n) = expandNamedPat env n
|
||||
compilePat env (PFrame mp inner) =
|
||||
maybe [] (compilePathPat env) mp ++ compilePat env inner
|
||||
compilePat env (PFrame mp inner) = do
|
||||
pathConds <- maybe [[]] (compilePathPat env) mp
|
||||
innerConds <- compilePat env inner
|
||||
return (pathConds ++ innerConds)
|
||||
compilePat env (PCtor n ps) = compileCtorPat env n ps
|
||||
compilePat _ (PRecord n fs) = compileRecordPat n fs
|
||||
compilePat env (PTuple ps) = concatMap (compilePat env) ps
|
||||
compilePat _ (PBytes _) = [] -- handled by flow/ct mark (future)
|
||||
compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps))
|
||||
compilePat _ (PBytes _) = [[]]
|
||||
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
|
||||
|
||||
-- Named patterns are inlined at compile time.
|
||||
expandNamedPat :: CompileEnv -> Name -> [Value]
|
||||
expandNamedPat :: CompileEnv -> Name -> [[Value]]
|
||||
expandNamedPat env n =
|
||||
case Map.lookup n env of
|
||||
Just (DPattern _ _ p) -> compilePat env p
|
||||
_ -> []
|
||||
|
||||
-- Layer stripping: Ether is transparent; IPv4/IPv6/TCP/UDP/ICMPv6 each emit
|
||||
-- the appropriate protocol-selector match then recurse into their children.
|
||||
-- Omitting Ether produces identical output.
|
||||
compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
|
||||
compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]]
|
||||
compileCtorPat env ctor ps = case ctor of
|
||||
"Ether" -> children -- transparent layer
|
||||
"IPv4" -> matchMeta "nfproto" "ipv4" : children
|
||||
"IPv6" -> matchMeta "nfproto" "ipv6" : children
|
||||
"TCP" -> matchPayload "th" "protocol" "tcp" : children
|
||||
"UDP" -> matchPayload "th" "protocol" "udp" : children
|
||||
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
|
||||
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children
|
||||
"Ether" -> children
|
||||
"IPv4" -> map (matchMeta "nfproto" "ipv4" :) children
|
||||
"IPv6" -> map (matchMeta "nfproto" "ipv6" :) children
|
||||
"TCP" -> map (matchMeta "l4proto" "tcp" :) children
|
||||
"UDP" -> map (matchMeta "l4proto" "udp" :) children
|
||||
"ICMPv6" -> map (matchPayload "ip6" "nexthdr" "ipv6-icmp" :) children
|
||||
"ICMP" -> map (matchPayload "ip" "protocol" "icmp" :) children
|
||||
_ -> children
|
||||
where
|
||||
children = concatMap (compilePat env) ps
|
||||
children = map concat (sequence (map (compilePat env) ps))
|
||||
|
||||
-- Record patterns emit field equality matches, e.g. tcp { dport = :22 }.
|
||||
compileRecordPat :: String -> [FieldPat] -> [Value]
|
||||
compileRecordPat proto = mapMaybe go
|
||||
compileRecordPat :: String -> [FieldPat] -> [[Value]]
|
||||
compileRecordPat proto fs = [mapMaybe go fs]
|
||||
where
|
||||
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
|
||||
go _ = Nothing
|
||||
|
||||
-- Path patterns (iif/oif).
|
||||
compilePathPat :: CompileEnv -> PathPat -> [Value]
|
||||
compilePathPat _ (PathPat ms md) =
|
||||
maybe [] (compileEndpoint "iifname") ms ++
|
||||
maybe [] (compileEndpoint "oifname") md
|
||||
compilePathPat :: CompileEnv -> PathPat -> [[Value]]
|
||||
compilePathPat env (PathPat ms md) =
|
||||
[ maybe [] (compileEndpoint env "iifname") ms ++
|
||||
maybe [] (compileEndpoint env "oifname") md ]
|
||||
|
||||
compileEndpoint :: String -> EndpointPat -> [Value]
|
||||
compileEndpoint _ EPWild = []
|
||||
compileEndpoint dir (EPName n) = [matchMeta dir n]
|
||||
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]]
|
||||
-- zone membership: for MVP we emit the zone name as a set element.
|
||||
-- A later pass would expand zones to their member interface names.
|
||||
compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value]
|
||||
compileEndpoint _ _ EPWild = []
|
||||
compileEndpoint _ dir (EPName n) = [matchMeta dir n]
|
||||
compileEndpoint env dir (EPMember _ z) =
|
||||
case Map.lookup z env of
|
||||
Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
|
||||
_ -> [matchInSet (metaVal dir) [A.String (toText z)]]
|
||||
|
||||
-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
|
||||
|
||||
compileGuard :: CompileEnv -> Expr -> [Value]
|
||||
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
|
||||
compileGuard _ (EInfix OpIn l r) = [compileInExpr l r]
|
||||
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)]
|
||||
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal r)]
|
||||
compileGuard _ _ = []
|
||||
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
|
||||
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
|
||||
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
|
||||
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
|
||||
compileGuard _ _ = []
|
||||
|
||||
compileInExpr :: Expr -> Expr -> Value
|
||||
-- ct.state in { Established, Related }
|
||||
compileInExpr (EQual ["ct","state"]) (ESet vs) = ctMatch "state" vs
|
||||
compileInExpr (EQual ["ct","status"]) (ESet vs) = ctMatch "status" vs
|
||||
-- generic set membership
|
||||
compileInExpr l (ESet vs) = matchExpr "in" (exprVal l) (setVal (map exprToStr vs))
|
||||
compileInExpr l r = matchExpr "==" (exprVal l) (exprVal r)
|
||||
compileInExpr :: CompileEnv -> Expr -> Expr -> Value
|
||||
-- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element
|
||||
-- EQual case to eliminate the overlapping pattern match warning.
|
||||
compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
|
||||
matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
|
||||
compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
|
||||
matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]]) (toJSON (map (exprVal env) vs))
|
||||
compileInExpr env l (ESet vs) =
|
||||
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
|
||||
compileInExpr env l (EVar z)
|
||||
| Just (DZone _ ns) <- Map.lookup z env =
|
||||
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
|
||||
compileInExpr env l r =
|
||||
matchExpr "==" (exprVal env l) (exprVal env r)
|
||||
|
||||
ctMatch :: String -> [Expr] -> Value
|
||||
ctMatch key vs = matchExpr "in"
|
||||
(object ["ct" .= object ["key" .= key]])
|
||||
(setVal (map exprToStr vs))
|
||||
|
||||
-- ─── Action → Maybe Value (Nothing = Continue = no rule) ─────────────────────
|
||||
-- ─── Action → Maybe Value ─────────────────────────────────────────────────────
|
||||
|
||||
compileAction :: CompileEnv -> Expr -> Maybe Value
|
||||
compileAction _ (EVar "Allow") = Just (object ["accept" .= Null])
|
||||
@@ -212,105 +211,184 @@ compileAction _ (EVar "Continue") = Nothing
|
||||
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null])
|
||||
compileAction _ (EApp (EVar "DNAT") arg) =
|
||||
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]]
|
||||
compileAction _ (EApp (EVar "DNATMap") arg) =
|
||||
compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
|
||||
Just $ object ["dnat" .= object ["addr" .= object
|
||||
["map" .= object ["key" .= object ["concat" .= Array mempty]
|
||||
,"data" .= exprToStr arg]]]]
|
||||
-- Rule invocation → jump
|
||||
[ "map" .= object [ "key" .= exprVal env key
|
||||
, "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]
|
||||
compileAction env (EApp (EVar rn) _) =
|
||||
case Map.lookup rn env of
|
||||
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
|
||||
_ -> Just (object ["accept" .= Null])
|
||||
compileAction _ _ = Just (object ["accept" .= Null])
|
||||
|
||||
-- ─── Let → Map object ────────────────────────────────────────────────────────
|
||||
|
||||
letToMapValue :: String -> Name -> Expr -> Maybe Value
|
||||
letToMapValue tbl n (EMap entries) = Just $ object
|
||||
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
|
||||
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
|
||||
[ "map" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= ("inetproto . inetservice" :: String)
|
||||
, "map" .= ("ipv4_addr . inetservice" :: String)
|
||||
, "elem" .= toJSON (map renderMapElem entries)
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= renderNftType (fwlTypeToNft tk)
|
||||
, "map" .= renderNftType (fwlTypeToNft tv)
|
||||
, "elem" .= toJSON (map renderMapElem entries)
|
||||
]
|
||||
]
|
||||
letToMapValue _ _ _ = Nothing
|
||||
letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object
|
||||
[ "set" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= renderNftType (fwlTypeToNft t)
|
||||
, "elem" .= toJSON (map renderSetElem entries)
|
||||
]
|
||||
]
|
||||
letToSetOrMapValue _ _ _ _ = Nothing
|
||||
|
||||
fwlTypeToNft :: Type -> [String]
|
||||
fwlTypeToNft (TName "Protocol" []) = ["inet_proto"]
|
||||
fwlTypeToNft (TName "Port" []) = ["inet_service"]
|
||||
fwlTypeToNft (TName "IP" []) = ["ipv4_addr"]
|
||||
fwlTypeToNft (TName "IPv4" []) = ["ipv4_addr"]
|
||||
fwlTypeToNft (TName "IPv6" []) = ["ipv6_addr"]
|
||||
fwlTypeToNft (TTuple ts) = concatMap fwlTypeToNft ts
|
||||
fwlTypeToNft _ = ["any"]
|
||||
|
||||
renderNftType :: [String] -> Value
|
||||
renderNftType [t] = A.String (toText t)
|
||||
renderNftType ts = toJSON ts
|
||||
|
||||
exprToVal :: Expr -> Value
|
||||
exprToVal (ELit (LPort p)) = toJSON p
|
||||
exprToVal (ELit (LInt n)) = toJSON n
|
||||
exprToVal (ELit (LCIDR ip p))= object
|
||||
[ "prefix" .= object
|
||||
[ "addr" .= A.String (toText (renderLit ip))
|
||||
, "len" .= p
|
||||
]
|
||||
]
|
||||
exprToVal (ELit l) = A.String (toText (renderLit l))
|
||||
exprToVal (EVar n) = A.String (toText n)
|
||||
exprToVal (EQual ns) = A.String (toText (intercalate "." ns))
|
||||
exprToVal _ = A.String "_"
|
||||
|
||||
exprToConcatList :: Expr -> [Value]
|
||||
exprToConcatList (ETuple es) = concatMap exprToConcatList es
|
||||
exprToConcatList e = [exprToVal e]
|
||||
|
||||
renderMapOrSetKey :: Expr -> Value
|
||||
renderMapOrSetKey (ETuple es) = object ["concat" .= toJSON (exprToConcatList (ETuple es))]
|
||||
renderMapOrSetKey e = exprToVal e
|
||||
|
||||
renderMapElem :: (Expr, Expr) -> Value
|
||||
renderMapElem (k, v) = toJSON
|
||||
[ object ["concat" .= toJSON [exprToStr k]]
|
||||
, exprToStr v
|
||||
[ renderMapOrSetKey k
|
||||
, renderMapOrSetKey v
|
||||
]
|
||||
|
||||
renderSetElem :: Expr -> Value
|
||||
renderSetElem = renderMapOrSetKey
|
||||
|
||||
-- ─── Aeson building blocks ───────────────────────────────────────────────────
|
||||
|
||||
-- { "match": { "op": op, "left": left, "right": right } }
|
||||
matchExpr :: String -> Value -> Value -> Value
|
||||
matchExpr op l r = object
|
||||
[ "match" .= object
|
||||
[ "op" .= op
|
||||
[ "op" .= (op :: String)
|
||||
, "left" .= l
|
||||
, "right" .= r
|
||||
]
|
||||
]
|
||||
|
||||
matchMeta :: String -> String -> Value
|
||||
matchMeta key val = matchExpr "==" (metaVal key) (A.String (strText val))
|
||||
matchMeta key val = matchExpr "==" (metaVal key) (A.String (toText val))
|
||||
|
||||
matchPayload :: String -> String -> String -> Value
|
||||
matchPayload proto field val =
|
||||
matchExpr "==" (payloadVal proto field) (A.String (strText val))
|
||||
matchExpr "==" (payloadVal proto field) (A.String (toText val))
|
||||
|
||||
matchInSet :: Value -> [String] -> Value
|
||||
matchInSet lhs vals =
|
||||
matchExpr "in" lhs (setVal vals)
|
||||
matchInSet :: Value -> [Value] -> Value
|
||||
matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
|
||||
|
||||
metaVal :: String -> Value
|
||||
metaVal key = object ["meta" .= object ["key" .= key]]
|
||||
metaVal key = object ["meta" .= object ["key" .= (key :: String)]]
|
||||
|
||||
payloadVal :: String -> String -> Value
|
||||
payloadVal proto field =
|
||||
object ["payload" .= object ["protocol" .= proto, "field" .= field]]
|
||||
object ["payload" .= object
|
||||
[ "protocol" .= (proto :: String)
|
||||
, "field" .= (field :: String)
|
||||
]]
|
||||
|
||||
setVal :: [String] -> Value
|
||||
setVal :: [Value] -> Value
|
||||
setVal vs = object ["set" .= toJSON vs]
|
||||
|
||||
-- ─── Expression → Value helpers ──────────────────────────────────────────────
|
||||
-- ─── Expression helpers ───────────────────────────────────────────────────────
|
||||
|
||||
exprVal :: Expr -> Value
|
||||
exprVal (EQual [p, f]) = payloadVal p f
|
||||
exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= k]]
|
||||
exprVal (EVar n) = metaVal n
|
||||
exprVal (ELit l) = A.String (strText (renderLit l))
|
||||
exprVal (ESet vs) = setVal (map exprToStr vs)
|
||||
exprVal e = A.String (strText (exprToStr e))
|
||||
isSetOrMapRef :: CompileEnv -> Name -> Bool
|
||||
isSetOrMapRef env n = case Map.lookup n env of
|
||||
Just (DLet _ _ _) -> True
|
||||
Just (DImport _ _ _) -> True
|
||||
_ -> False
|
||||
|
||||
mapField :: String -> String
|
||||
mapField "src" = "saddr"
|
||||
mapField "dst" = "daddr"
|
||||
mapField f = f
|
||||
|
||||
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
|
||||
exprVal :: 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 (EVar n) = n
|
||||
exprToStr (EVar n) = case n of
|
||||
"Established" -> "established"
|
||||
"Related" -> "related"
|
||||
"DNAT" -> "dnat"
|
||||
_ -> n
|
||||
exprToStr (ELit l) = renderLit l
|
||||
exprToStr (EQual ns) = intercalate "." ns
|
||||
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
|
||||
exprToStr _ = "_"
|
||||
|
||||
strText :: String -> A.Text
|
||||
strText = \s -> read (show s) -- simple String→Text without extra dep
|
||||
-- Fix 2: Use Data.Text.pack via OverloadedStrings + fromString instead of
|
||||
-- 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 (LInt n) = show n
|
||||
renderLit (LString s) = s
|
||||
renderLit (LBool True) = "true"
|
||||
renderLit (LBool False) = "false"
|
||||
renderLit (LIPv4 (a,b,c,d)) =
|
||||
show a++"."++show b++"."++show c++"."++show d
|
||||
renderLit (LIPv6 _) = "::1"
|
||||
renderLit (LInt n) = show n
|
||||
renderLit (LString s) = s
|
||||
renderLit (LBool True) = "true"
|
||||
renderLit (LBool False) = "false"
|
||||
renderLit (LIP IPv4 n) = renderIPv4 n
|
||||
renderLit (LIP IPv6 n) = renderIPv6 n
|
||||
renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p
|
||||
renderLit (LPort p) = show p
|
||||
renderLit (LDuration n Seconds) = show n
|
||||
renderLit (LDuration n _) = show n
|
||||
renderLit (LDuration n Seconds) = show n ++ "s"
|
||||
renderLit (LDuration n Millis) = show n ++ "ms"
|
||||
renderLit (LDuration n Minutes) = show n ++ "m"
|
||||
renderLit (LDuration n Hours) = show n ++ "h"
|
||||
renderLit (LHex b) = show b
|
||||
|
||||
-- Data.Aeson.Key helper (aeson >= 2.0 uses Key, not Text, for object keys)
|
||||
(.=) :: A.ToJSON v => String -> v -> A.Pair
|
||||
k .= v = (K.fromString k, toJSON v)
|
||||
|
||||
@@ -15,6 +15,11 @@ fwlDef = emptyDef
|
||||
, Tok.identStart = letter <|> char '_'
|
||||
, Tok.identLetter = alphaNum <|> char '_'
|
||||
, Tok.reservedNames =
|
||||
-- Only genuine syntactic keywords belong here.
|
||||
-- Semantic values used as constructors, actions, type names, or
|
||||
-- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must
|
||||
-- NOT be reserved so that `identifier` can consume them in those
|
||||
-- positions.
|
||||
[ "config", "table"
|
||||
, "interface", "zone", "import", "from"
|
||||
, "let", "in", "pattern", "flow", "rule", "policy", "on"
|
||||
@@ -23,11 +28,7 @@ fwlDef = emptyDef
|
||||
, "hook", "priority"
|
||||
, "WAN", "LAN", "WireGuard"
|
||||
, "Input", "Forward", "Output", "Prerouting", "Postrouting"
|
||||
, "Filter", "NAT", "Mangle", "DstNat", "SrcNat"
|
||||
, "Allow", "Drop", "Continue", "Masquerade", "DNAT", "DNATMap"
|
||||
, "Log", "Info", "Warn", "Error"
|
||||
, "Matched", "Unmatched"
|
||||
, "Frame", "FlowPattern"
|
||||
, "Filter", "NAT", "Mangle", "DstNat", "SrcNat", "Raw", "ConnTrack"
|
||||
, "true", "false"
|
||||
]
|
||||
, Tok.reservedOpNames =
|
||||
|
||||
@@ -3,15 +3,19 @@ module FWL.Parser
|
||||
, parseFile
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad (void, when)
|
||||
import Data.Bits ((.&.), (.|.), shiftL)
|
||||
import Data.List (foldl')
|
||||
import Data.Word (Word8)
|
||||
import Numeric (readHex)
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
|
||||
import FWL.AST
|
||||
import FWL.Lexer
|
||||
import Data.Char (isUpper)
|
||||
|
||||
-- ─── Entry points ────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -34,7 +38,7 @@ program = do
|
||||
configBlock :: Parser Config
|
||||
configBlock = do
|
||||
reserved "config"
|
||||
props <- braces (semiSep configProp)
|
||||
props <- braces (endBy configProp semi)
|
||||
optional semi
|
||||
return $ foldr applyProp defaultConfig props
|
||||
where
|
||||
@@ -66,8 +70,8 @@ interfaceDecl = do
|
||||
n <- identifier
|
||||
reservedOp ":"
|
||||
k <- ifaceKind
|
||||
ps <- braces (semiSep ifaceProp)
|
||||
semi
|
||||
ps <- braces (endBy ifaceProp semi)
|
||||
_ <- semi
|
||||
return (DInterface n k ps)
|
||||
|
||||
ifaceKind :: Parser IfaceKind
|
||||
@@ -90,7 +94,7 @@ zoneDecl = do
|
||||
n <- identifier
|
||||
reservedOp "="
|
||||
ns <- braces (commaSep1 identifier)
|
||||
semi
|
||||
_ <- semi
|
||||
return (DZone n ns)
|
||||
|
||||
importDecl :: Parser Decl
|
||||
@@ -101,7 +105,7 @@ importDecl = do
|
||||
t <- typeP
|
||||
reserved "from"
|
||||
s <- stringLit
|
||||
semi
|
||||
_ <- semi
|
||||
return (DImport n t s)
|
||||
|
||||
letDecl :: Parser Decl
|
||||
@@ -112,7 +116,7 @@ letDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
e <- expr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DLet n t e)
|
||||
|
||||
patternDecl :: Parser Decl
|
||||
@@ -123,7 +127,7 @@ patternDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
p <- pat
|
||||
semi
|
||||
_ <- semi
|
||||
return (DPattern n t p)
|
||||
|
||||
flowDecl :: Parser Decl
|
||||
@@ -134,7 +138,7 @@ flowDecl = do
|
||||
reserved "FlowPattern"
|
||||
reservedOp "="
|
||||
f <- flowExpr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DFlow n f)
|
||||
|
||||
ruleDecl :: Parser Decl
|
||||
@@ -145,7 +149,7 @@ ruleDecl = do
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
e <- expr
|
||||
semi
|
||||
_ <- semi
|
||||
return (DRule n t e)
|
||||
|
||||
policyDecl :: Parser Decl
|
||||
@@ -158,7 +162,7 @@ policyDecl = do
|
||||
pm <- braces policyMeta
|
||||
reservedOp "="
|
||||
ab <- armBlock
|
||||
semi
|
||||
_ <- semi
|
||||
return (DPolicy n t pm ab)
|
||||
|
||||
policyMeta :: Parser PolicyMeta
|
||||
@@ -166,7 +170,7 @@ policyMeta = do
|
||||
props <- commaSep1 metaProp
|
||||
let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props
|
||||
tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props
|
||||
pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) PFilter props
|
||||
pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) pFilter props
|
||||
return (PolicyMeta h tb pr)
|
||||
|
||||
metaProp :: Parser (Either Hook (Either TableName Priority))
|
||||
@@ -187,11 +191,21 @@ tableNameP = (reserved "Filter" >> return TFilter)
|
||||
<|> (reserved "NAT" >> return TNAT)
|
||||
|
||||
priorityP :: Parser Priority
|
||||
priorityP = (reserved "Filter" >> return PFilter)
|
||||
<|> (reserved "DstNat" >> return PDstNat)
|
||||
<|> (reserved "SrcNat" >> return PSrcNat)
|
||||
<|> (reserved "Mangle" >> return PMangle)
|
||||
<|> (PInt . fromIntegral <$> natural)
|
||||
priorityP
|
||||
= (reserved "Filter" >> return pFilter)
|
||||
<|> (reserved "DstNat" >> return pDstNat)
|
||||
<|> (reserved "SrcNat" >> return pSrcNat)
|
||||
<|> (reserved "Mangle" >> return pMangle)
|
||||
<|> (reserved "Raw" >> return pRaw)
|
||||
<|> (reserved "ConnTrack" >> return pConnTrack)
|
||||
<|> (Priority . fromIntegral <$> integerP)
|
||||
where
|
||||
-- Accept optional leading minus for negative priorities
|
||||
integerP = do
|
||||
neg <- option 1 (char '-' >> return (-1))
|
||||
n <- natural
|
||||
whiteSpace
|
||||
return (neg * fromIntegral n)
|
||||
|
||||
-- ─── Arm blocks ──────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -200,19 +214,24 @@ armBlock = braces (many arm)
|
||||
|
||||
arm :: Parser Arm
|
||||
arm = do
|
||||
symbol "|"
|
||||
_ <- symbol "|"
|
||||
p <- pat
|
||||
g <- optionMaybe (reserved "if" >> expr)
|
||||
reservedOp "->"
|
||||
e <- expr
|
||||
semi
|
||||
_ <- semi
|
||||
return (Arm p g e)
|
||||
|
||||
-- ─── Patterns ────────────────────────────────────────────────────────────────
|
||||
|
||||
pat :: Parser Pat
|
||||
pat = wildcardPat
|
||||
<|> framePat
|
||||
pat = Ex.buildExpressionParser patTable patAtom <?> "pattern"
|
||||
where
|
||||
patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ]
|
||||
|
||||
patAtom :: Parser Pat
|
||||
patAtom = wildcardPat
|
||||
<|> try framePat
|
||||
<|> try tuplePat
|
||||
<|> bytesPat
|
||||
<|> try recordPat
|
||||
@@ -236,7 +255,7 @@ frameArgs = try withPath <|> withoutPath
|
||||
where
|
||||
withPath = do
|
||||
pp <- pathPat
|
||||
comma
|
||||
_ <- comma
|
||||
inner <- pat
|
||||
return (Just pp, inner)
|
||||
withoutPath = do
|
||||
@@ -271,7 +290,7 @@ tuplePat = do
|
||||
commaSep2 :: Parser a -> Parser [a]
|
||||
commaSep2 p = do
|
||||
x <- p
|
||||
comma
|
||||
_ <- comma
|
||||
xs <- commaSep1 p
|
||||
return (x:xs)
|
||||
|
||||
@@ -290,8 +309,9 @@ hexByte = do
|
||||
h1 <- hexDigit
|
||||
h2 <- hexDigit
|
||||
whiteSpace
|
||||
let [(v,"")] = readHex [h1,h2]
|
||||
return (fromIntegral v)
|
||||
case (readHex [h1,h2] :: [(Integer, String)]) of
|
||||
[(v,"")] -> return (fromIntegral v)
|
||||
_ -> fail "invalid hex byte"
|
||||
|
||||
-- Record pattern: ident { fields }
|
||||
recordPat :: Parser Pat
|
||||
@@ -303,17 +323,25 @@ recordPat = do
|
||||
fieldPat :: Parser FieldPat
|
||||
fieldPat = do
|
||||
n <- identifier
|
||||
try (reservedOp "=" >> FPEq n <$> literal)
|
||||
try (reservedOp "=" >> FPEq n <$> fieldLiteral)
|
||||
<|> try (reserved "as" >> FPAs n <$> identifier)
|
||||
<|> return (FPBind n)
|
||||
|
||||
-- Named pattern reference OR constructor: starts with uppercase-ish ident
|
||||
-- Port literals (:22) are valid in record field position as well as plain literals.
|
||||
fieldLiteral :: Parser Literal
|
||||
fieldLiteral = try portLit <|> literal
|
||||
where
|
||||
portLit = do
|
||||
void (char ':')
|
||||
n <- fromIntegral <$> natural
|
||||
return (LPort n)
|
||||
|
||||
namedOrCtorPat :: Parser Pat
|
||||
namedOrCtorPat = do
|
||||
n <- identifier
|
||||
args <- optionMaybe (try (parens (commaSep pat)))
|
||||
case args of
|
||||
Nothing -> return (PNamed n) -- bare name = named pattern ref
|
||||
Nothing -> return $ if null n then PWild else if isUpper (head n) then PNamed n else PVar n
|
||||
Just ps -> return (PCtor n ps)
|
||||
|
||||
-- ─── Flow expressions ────────────────────────────────────────────────────────
|
||||
@@ -323,13 +351,17 @@ flowExpr = do
|
||||
first <- FAtom <$> identifier
|
||||
rest <- many (reservedOp "." >> identifier)
|
||||
mw <- optionMaybe (reserved "within" >> durationLit)
|
||||
return $ buildSeq (first : map FAtom rest) mw
|
||||
let chain = buildSeq (first : map FAtom rest)
|
||||
return $ case mw of
|
||||
Nothing -> chain
|
||||
Just w -> attach w chain
|
||||
where
|
||||
buildSeq [x] mw = case mw of
|
||||
Nothing -> x
|
||||
Just w -> FSeq x x (Just w) -- degenerate
|
||||
buildSeq (x:xs) mw = FSeq x (buildSeq xs mw) mw
|
||||
buildSeq [] _ = error "impossible"
|
||||
buildSeq [x] = x
|
||||
buildSeq (x:xs) = FSeq x (buildSeq xs) Nothing
|
||||
buildSeq [] = error "impossible"
|
||||
|
||||
attach w (FSeq a b _) = FSeq a b (Just w)
|
||||
attach w x = FSeq x x (Just w)
|
||||
|
||||
durationLit :: Parser Duration
|
||||
durationLit = do
|
||||
@@ -518,7 +550,7 @@ mapEntry = do
|
||||
|
||||
literal :: Parser Literal
|
||||
literal
|
||||
= try cidrOrIpLit
|
||||
= try ipOrCidrLit
|
||||
<|> try hexLit
|
||||
<|> try (LBool True <$ reserved "true")
|
||||
<|> try (LBool False <$ reserved "false")
|
||||
@@ -528,26 +560,110 @@ literal
|
||||
hexLit :: Parser Literal
|
||||
hexLit = LHex <$> hexByte
|
||||
|
||||
cidrOrIpLit :: Parser Literal
|
||||
cidrOrIpLit = do
|
||||
a <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
b <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
c <- fromIntegral <$> natural
|
||||
void (char '.')
|
||||
d <- fromIntegral <$> natural
|
||||
whiteSpace
|
||||
-- ─── IP / CIDR parsing ───────────────────────────────────────────────────────
|
||||
|
||||
-- | Parse an IPv4 or IPv6 address, optionally followed by /prefix.
|
||||
-- Tries IPv6 first (it can start with hex digits too), then IPv4.
|
||||
ipOrCidrLit :: Parser Literal
|
||||
ipOrCidrLit = do
|
||||
ip <- try ipv6Lit <|> ipv4Lit_
|
||||
mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural)
|
||||
whiteSpace
|
||||
let ip = LIPv4 (a,b,c,d)
|
||||
return $ case mPrefix of
|
||||
Nothing -> ip
|
||||
Just p -> LCIDR ip p
|
||||
|
||||
-- | IPv4: four decimal octets separated by dots → LIP IPv4 (32-bit Integer)
|
||||
ipv4Lit_ :: Parser Literal
|
||||
ipv4Lit_ = do
|
||||
a <- octet
|
||||
void (char '.')
|
||||
b <- octet
|
||||
void (char '.')
|
||||
c <- octet
|
||||
void (char '.')
|
||||
d <- octet
|
||||
return $ LIP IPv4
|
||||
( fromIntegral a `shiftL` 24
|
||||
.|. fromIntegral b `shiftL` 16
|
||||
.|. fromIntegral c `shiftL` 8
|
||||
.|. fromIntegral d)
|
||||
where
|
||||
octet = do
|
||||
n <- fromIntegral <$> natural
|
||||
if n > 255 then fail "octet out of range" else return n
|
||||
|
||||
-- | IPv6: full notation, :: abbreviation, and optional embedded IPv4.
|
||||
-- Stores as LIP IPv6 (128-bit Integer).
|
||||
ipv6Lit :: Parser Literal
|
||||
ipv6Lit = do
|
||||
(left, hasDbl, right) <- ipv6Groups
|
||||
let missing = 8 - length left - length right
|
||||
when (missing < 0) $ fail "too many groups in IPv6 address"
|
||||
when (not hasDbl && missing /= 0) $ fail "invalid IPv6 address (must have 8 groups or use ::)"
|
||||
let groups = left ++ replicate missing 0 ++ right
|
||||
when (length groups /= 8) $ fail "invalid IPv6 address"
|
||||
let val = foldl' (\acc g -> (acc `shiftL` 16) .|. fromIntegral g) (0::Integer) groups
|
||||
return (LIP IPv6 val)
|
||||
|
||||
-- Returns (left-of-::, has_dbl_colon, right-of-::).
|
||||
-- If no :: present, left has all 8 groups and right is empty.
|
||||
ipv6Groups :: Parser ([Int], Bool, [Int])
|
||||
ipv6Groups = do
|
||||
-- must start with a hex digit or ':' (for ::)
|
||||
ahead <- lookAhead (hexDigit <|> char ':')
|
||||
case ahead of
|
||||
':' -> do
|
||||
void (string "::")
|
||||
right <- ipv6RightGroups
|
||||
return ([], True, right)
|
||||
_ -> do
|
||||
left <- ipv6LeftGroups
|
||||
mDbl <- optionMaybe (try (string "::"))
|
||||
case mDbl of
|
||||
Nothing -> return (left, False, [])
|
||||
Just _ -> do
|
||||
right <- ipv6RightGroups
|
||||
return (left, True, right)
|
||||
|
||||
-- Parse a run of hex16:hex16:... stopping before :: or end
|
||||
ipv6LeftGroups :: Parser [Int]
|
||||
ipv6LeftGroups = do
|
||||
first <- hex16
|
||||
rest <- many (try (char ':' >> notFollowedBy (char ':') >> hex16))
|
||||
return (first : rest)
|
||||
|
||||
-- Parse groups to the right of ::, including optional embedded IPv4
|
||||
ipv6RightGroups :: Parser [Int]
|
||||
ipv6RightGroups = option [] $
|
||||
try ipv4EmbeddedGroups <|> ipv6LeftGroups
|
||||
|
||||
-- IPv4-mapped groups: e.g. ffff:192.168.1.1 -> [0xffff, 0xc0a8, 0x0101]
|
||||
ipv4EmbeddedGroups :: Parser [Int]
|
||||
ipv4EmbeddedGroups = do
|
||||
prefix <- many (try (hex16 <* char ':' <* lookAhead digit))
|
||||
a <- octet_; void (char '.')
|
||||
b <- octet_; void (char '.')
|
||||
c <- octet_; void (char '.')
|
||||
d <- octet_
|
||||
let hi = (a `shiftL` 8) .|. b
|
||||
lo = (c `shiftL` 8) .|. d
|
||||
return (prefix ++ [hi, lo])
|
||||
where
|
||||
octet_ = do
|
||||
n <- fromIntegral <$> natural
|
||||
if n > 255 then fail "IPv4 octet out of range" else return n
|
||||
|
||||
hex16 :: Parser Int
|
||||
hex16 = do
|
||||
digits <- many1 hexDigit
|
||||
case (reads ("0x" ++ digits)) :: [(Int,String)] of
|
||||
[(v,"")] -> if v > 0xffff then fail "hex16 out of range" else return v
|
||||
_ -> fail "invalid hex group"
|
||||
|
||||
cidrLit :: Parser CIDR
|
||||
cidrLit = do
|
||||
l <- cidrOrIpLit
|
||||
l <- ipOrCidrLit
|
||||
case l of
|
||||
LCIDR ip p -> return (ip, p)
|
||||
_ -> fail "expected CIDR notation"
|
||||
_ -> fail "expected CIDR notation (address/prefix)"
|
||||
|
||||
@@ -49,8 +49,6 @@ prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr
|
||||
prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }"
|
||||
|
||||
prettyCidr :: CIDR -> String
|
||||
prettyCidr (LIPv4 (a,b,c,d), p) =
|
||||
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ "/" ++ show p
|
||||
prettyCidr (ip, p) = prettyLit ip ++ "/" ++ show p
|
||||
|
||||
prettyHook :: Hook -> String
|
||||
@@ -65,11 +63,7 @@ prettyTable TFilter = "Filter"
|
||||
prettyTable TNAT = "NAT"
|
||||
|
||||
prettyPriority :: Priority -> String
|
||||
prettyPriority PFilter = "Filter"
|
||||
prettyPriority PDstNat = "DstNat"
|
||||
prettyPriority PSrcNat = "SrcNat"
|
||||
prettyPriority PMangle = "Mangle"
|
||||
prettyPriority (PInt n)= show n
|
||||
prettyPriority p = show (priorityValue p)
|
||||
|
||||
prettyType :: Type -> String
|
||||
prettyType (TName n []) = n
|
||||
@@ -88,6 +82,7 @@ prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
|
||||
prettyPat (PFrame mp inner)=
|
||||
"Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")"
|
||||
prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]"
|
||||
prettyPat (POr p1 p2) = prettyPat p1 ++ " | " ++ prettyPat p2
|
||||
|
||||
prettyFP :: FieldPat -> String
|
||||
prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l
|
||||
@@ -182,9 +177,8 @@ prettyLit (LInt n) = show n
|
||||
prettyLit (LString s) = "\"" ++ s ++ "\""
|
||||
prettyLit (LBool True) = "true"
|
||||
prettyLit (LBool False) = "false"
|
||||
prettyLit (LIPv4 (a,b,c,d)) =
|
||||
show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d
|
||||
prettyLit (LIPv6 _) = "<ipv6>"
|
||||
prettyLit (LIP IPv4 n) = renderIPv4 n
|
||||
prettyLit (LIP IPv6 n) = renderIPv6 n
|
||||
prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p
|
||||
prettyLit (LPort p) = ":" ++ show p
|
||||
prettyLit (LDuration n u) = show n ++ prettyUnit u
|
||||
|
||||
224
test/CheckTests.hs
Normal file
224
test/CheckTests.hs
Normal 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
384
test/CompileTests.hs
Normal 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
44
test/FWL/Util.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
-- | Shared test utilities.
|
||||
module FWL.Util where
|
||||
|
||||
import Test.Tasty.HUnit
|
||||
import Text.Parsec.String (Parser)
|
||||
import Text.Parsec (parse)
|
||||
|
||||
import FWL.Parser (parseProgram)
|
||||
import FWL.AST
|
||||
|
||||
-- | Assert a parser succeeds and return the result.
|
||||
shouldParse :: (Show a) => Parser a -> String -> IO a
|
||||
shouldParse p input =
|
||||
case parse p "<test>" input of
|
||||
Left err -> assertFailure ("Unexpected parse error:\n" ++ show err)
|
||||
>> undefined
|
||||
Right v -> return v
|
||||
|
||||
-- | Assert a parser fails.
|
||||
shouldFailParse :: (Show a) => Parser a -> String -> IO ()
|
||||
shouldFailParse p input =
|
||||
case parse p "<test>" input of
|
||||
Left _ -> return ()
|
||||
Right v -> assertFailure ("Expected parse failure but got: " ++ show v)
|
||||
|
||||
-- | Parse a full program, asserting success.
|
||||
parseOk :: String -> IO Program
|
||||
parseOk src =
|
||||
case parseProgram "<test>" src of
|
||||
Left err -> assertFailure ("Parse error:\n" ++ show err) >> undefined
|
||||
Right p -> return p
|
||||
|
||||
-- | Parse a full program, asserting failure.
|
||||
parseFail :: String -> IO ()
|
||||
parseFail src =
|
||||
case parseProgram "<test>" src of
|
||||
Left _ -> return ()
|
||||
Right p -> assertFailure ("Expected parse failure, got:\n" ++ show p)
|
||||
|
||||
-- | Extract the single declaration from a one-decl program.
|
||||
singleDecl :: Program -> IO Decl
|
||||
singleDecl (Program _ [d]) = return d
|
||||
singleDecl (Program _ ds) =
|
||||
assertFailure ("Expected 1 decl, got " ++ show (length ds)) >> undefined
|
||||
516
test/ParserTests.hs
Normal file
516
test/ParserTests.hs
Normal 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
15
test/Spec.hs
Normal file
@@ -0,0 +1,15 @@
|
||||
module Main where
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import qualified ParserTests
|
||||
import qualified CheckTests
|
||||
import qualified CompileTests
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain $ testGroup "FWL"
|
||||
[ ParserTests.tests
|
||||
, CheckTests.tests
|
||||
, CompileTests.tests
|
||||
]
|
||||
Reference in New Issue
Block a user