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

crazy mega refactor

Browse Source
This commit is contained in:
Yura
2026-05-04 03:16:40 -07:00
parent 55c1d347e6
commit 6d96e2d159
11 changed files with 686 additions and 616 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
test/CheckTests.hs
View File

@@ -86,8 +86,7 @@ undefinedNameTests = testGroup "undefined names"
, testCase "policy guard references undeclared zone" $
-- 'unknown_zone' not declared; check should flag it
assertHasError (isUndefined "unknown_zone")
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
"policy fwd : Frame hook Forward \
\ = { | Frame(iif in unknown_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -96,8 +95,7 @@ undefinedNameTests = testGroup "undefined names"
assertNoErrors
"interface lan : LAN {}; \
\zone trusted = { lan }; \
\policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\policy fwd : Frame hook Forward \
\ = { | Frame(iif in trusted -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -124,11 +122,9 @@ duplicateTests = testGroup "duplicates"
, testCase "duplicate policy" $
assertHasError (isDuplicate "input")
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
"policy input : Frame hook Input \
\ = { | _ -> Allow; }; \
\policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\policy input : Frame hook Input \
\ = { | _ -> Drop; };"
, testCase "distinct names — no error" $
@@ -144,23 +140,18 @@ policyTerminationTests :: TestTree
policyTerminationTests = testGroup "policy termination"
[ testCase "last arm is Continue — error" $
assertHasError (isNoContinue "bad_policy")
"policy bad_policy : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Continue; };"
"policy bad_policy : Frame hook Input = { | _ -> Continue; };"
, testCase "last arm is Drop — ok" $
assertNoErrors
"policy good : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
"policy good : Frame hook Input \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
, testCase "last arm is Allow — ok" $
assertNoErrors
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
"policy output : Frame hook Output = { | _ -> Allow; };"
, testCase "Continue in non-last arm is fine" $
assertNoErrors
@@ -172,9 +163,7 @@ policyTerminationTests = testGroup "policy termination"
, testCase "empty policy body — error" $
assertHasError (isNoContinue "empty")
"policy empty : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
"policy empty : Frame hook Output = {};"
]
-- ─── Pattern cycle tests ─────────────────────────────────────────────────────
@@ -207,14 +196,11 @@ cleanProgramTests = testGroup "clean programs"
\interface lan : LAN { cidr4 = { 10.17.1.0/24 }; }; \
\interface wg0 : WireGuard {}; \
\zone lan_zone = { lan, wg0 }; \
\policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\policy input : Frame hook Input \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
\policy output : Frame hook Output = { | _ -> Allow; };"
, testCase "pattern and flow declarations" $
assertNoErrors

317
test/CompileTests.hs
View File

@@ -22,6 +22,9 @@ tests = testGroup "Compile"
, layerStrippingTests
, continueTests
, configTests
, filterInjectionTests
, portforwardCompileTests
, masqueradeCompileTests
]
-- ─── Helpers ─────────────────────────────────────────────────────────────────
@@ -60,23 +63,16 @@ withKey k = filter (\v -> case at [k] v of Just _ -> True; _ -> False)
jsonStructureTests :: TestTree
jsonStructureTests = testGroup "JSON structure"
[ testCase "output is valid JSON" $ do
_ <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
_ <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
return ()
, testCase "top-level nftables array present" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
_ <- nftArr v
return ()
, testCase "metainfo is first element" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case arr of
(first:_) -> case at ["metainfo"] first of
@@ -85,17 +81,13 @@ jsonStructureTests = testGroup "JSON structure"
[] -> assertFailure "Empty nftables array"
, testCase "table object present" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected at least one table object"
(not (null (withKey "table" arr)))
, testCase "default table name is fwl" $ do
v <- compileToValue "policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "fwl")
@@ -104,9 +96,7 @@ jsonStructureTests = testGroup "JSON structure"
, testCase "custom table name respected" $ do
v <- compileToValue
"config { table = \"custom\"; } \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "table" arr of
(t:_) -> at ["table","name"] t @?= Just (A.String "custom")
@@ -118,60 +108,42 @@ jsonStructureTests = testGroup "JSON structure"
chainTests :: TestTree
chainTests = testGroup "chain declarations"
[ testCase "filter input chain has correct hook" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","hook"] c @?= Just (A.String "input")
[] -> assertFailure "No chain"
, testCase "filter chain type is filter" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy fwd : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "filter")
[] -> assertFailure "No chain"
, testCase "NAT chain type is nat" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","type"] c @?= Just (A.String "nat")
[] -> assertFailure "No chain"
, testCase "input chain default policy is drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "drop")
[] -> assertFailure "No chain"
, testCase "output chain default policy is accept" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","policy"] c @?= Just (A.String "accept")
[] -> assertFailure "No chain"
, testCase "chain name matches policy name" $ do
v <- compileToValue
"policy my_input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy my_input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
case withKey "chain" arr of
(c:_) -> at ["chain","name"] c @?= Just (A.String "my_input")
@@ -179,12 +151,8 @@ chainTests = testGroup "chain declarations"
, testCase "two policies produce two chains" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; }; \
\policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
"policy input : Frame hook Input = { | _ -> Drop; }; \
\policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "chain" arr) @?= 2
]
@@ -199,29 +167,14 @@ ruleExprs arr =
ruleExprTests :: TestTree
ruleExprTests = testGroup "rule expressions"
[ testCase "two arms produce two rules" $ do
[ testCase "arm without guard produces rule" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
"policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, testCase "arm without guard produces one rule" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
arr <- nftArr v
length (withKey "rule" arr) @?= 1
assertBool "Should have at least one rule" (not (null (withKey "rule" arr)))
, testCase "rule expr array is present" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
case withKey "rule" arr of
(r:_) -> case at ["rule","expr"] r of
@@ -231,10 +184,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "IPv4 ctor emits nfproto match" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
"policy input : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
@@ -245,10 +197,9 @@ ruleExprTests = testGroup "rule expressions"
, testCase "record field pat emits payload match" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ | _ -> Drop; \
"policy input : Frame hook Input = \
\ { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
let matches = withKey "match" (ruleExprs arr)
@@ -269,28 +220,19 @@ allExprs arr =
verdictTests :: TestTree
verdictTests = testGroup "verdicts"
[ testCase "Allow compiles to accept" $ do
v <- compileToValue
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
assertBool "Expected accept verdict"
(not (null (withKey "accept" (allExprs arr))))
, testCase "Drop compiles to drop" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
assertBool "Expected drop verdict"
(not (null (withKey "drop" (allExprs arr))))
, testCase "Masquerade compiles to masquerade" $ do
v <- compileToValue
"policy nat_post : Frame \
\ on { hook = Postrouting, table = NAT, priority = SrcNat } \
\ = { | _ -> Masquerade; };"
v <- compileToValue "policy nat_post : Frame hook Postrouting = { | _ -> Masquerade; };"
arr <- nftArr v
assertBool "Expected masquerade verdict"
(not (null (withKey "masquerade" (allExprs arr))))
@@ -298,9 +240,7 @@ verdictTests = testGroup "verdicts"
, testCase "rule call compiles to jump" $ do
v <- compileToValue
"rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \
\policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | frame -> blockAll(frame); };"
\policy fwd : Frame hook Forward = { | frame -> blockAll(frame); };"
arr <- nftArr v
assertBool "Expected jump verdict for rule call"
(not (null (withKey "jump" (allExprs arr))))
@@ -312,16 +252,14 @@ layerStrippingTests :: TestTree
layerStrippingTests = testGroup "layer stripping"
[ testCase "Frame with and without Ether both emit nfproto match" $ do
let withEther =
"policy p1 : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
"policy p1 : Frame hook Input = \
\ { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
\ | _ -> Drop; \
\ };"
withoutEther =
"policy p1 : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
"policy p1 : Frame hook Input = \
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
\ | _ -> Drop; \
\ };"
v1 <- compileToValue withEther
v2 <- compileToValue withoutEther
@@ -338,22 +276,11 @@ layerStrippingTests = testGroup "layer stripping"
continueTests :: TestTree
continueTests = testGroup "Continue"
[ testCase "two terminal arms produce two rules" $ do
[ testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy fwd : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
length (withKey "rule" arr) @?= 2
, testCase "non-Continue arms still produce rules" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
"policy input : Frame hook Input = \
\ { | _ if ct.state in { Established } -> Allow; \
\ | _ -> Drop; \
\ };"
arr <- nftArr v
assertBool "Should have rules for non-Continue arms"
@@ -365,20 +292,166 @@ continueTests = testGroup "Continue"
configTests :: TestTree
configTests = testGroup "config"
[ testCase "all rule objects reference correct table" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl"))
(withKey "rule" arr)
, testCase "chain objects reference correct table" $ do
v <- compileToValue
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Drop; };"
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl"))
(withKey "chain" arr)
]
-- ─── Filter-hook injection tests ─────────────────────────────────────────────
filterInjectionTests :: TestTree
filterInjectionTests = testGroup "filter hook injections"
[ testCase "Input chain first rule is stateful ct state" $ do
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
inputRules = filter (\r -> at ["rule","chain"] r == Just (A.String "input")) rules
case inputRules of
(r:_) -> case at ["rule","expr","0","match","left","ct","key"] r of
Just (A.String "state") -> return ()
_ -> case at ["rule","expr"] r of
Just (A.Array es) ->
let exprs = V.toList es
hasState = any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) exprs
in assertBool "First rule should have ct state match" hasState
_ -> assertFailure "No expr in first rule"
[] -> assertFailure "No rules for input chain"
, testCase "Input chain has loopback rule (iifname lo)" $ do
v <- compileToValue "policy input : Frame hook Input = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
inputRules = filter (\r -> at ["rule","chain"] r == Just (A.String "input")) rules
hasLo = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","right"] e == Just (A.String "lo")) (V.toList es)
_ -> False) inputRules
assertBool "Input chain should have iifname lo rule" hasLo
, testCase "Forward chain first rule is stateful ct state" $ do
v <- compileToValue "policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
fwdRules = filter (\r -> at ["rule","chain"] r == Just (A.String "forward")) rules
case fwdRules of
(r:_) -> case at ["rule","expr"] r of
Just (A.Array es) ->
let hasState = any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) (V.toList es)
in assertBool "First forward rule should have ct state match" hasState
_ -> assertFailure "No expr"
[] -> assertFailure "No rules for forward chain"
, testCase "Output chain has stateful rule but no loopback" $ do
v <- compileToValue "policy output : Frame hook Output = { | _ -> Allow; };"
arr <- nftArr v
let rules = withKey "rule" arr
outRules = filter (\r -> at ["rule","chain"] r == Just (A.String "output")) rules
hasState = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e -> at ["match","left","ct","key"] e == Just (A.String "state")) (V.toList es)
_ -> False) outRules
hasLo = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e -> at ["match","right"] e == Just (A.String "lo")) (V.toList es)
_ -> False) outRules
assertBool "Output chain should have ct state rule" hasState
assertBool "Output chain should NOT have loopback rule" (not hasLo)
]
-- ─── PortForward compile tests ───────────────────────────────────────────────
portforwardCompileTests :: TestTree
portforwardCompileTests = testGroup "portforward compilation"
[ testCase "portforward produces a map object with the decl name" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let maps = withKey "map" arr
named = filter (\m -> at ["map","name"] m == Just (A.String "wan_forwards")) maps
assertBool "Should have a map named wan_forwards" (not (null named))
, testCase "portforward produces prerouting chain" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let chains = withKey "chain" arr
preChain = filter (\c ->
at ["chain","name"] c == Just (A.String "wan_forwards_prerouting")) chains
assertBool "Should have wan_forwards_prerouting chain" (not (null preChain))
case preChain of
(c:_) -> do
at ["chain","type"] c @?= Just (A.String "nat")
at ["chain","hook"] c @?= Just (A.String "prerouting")
[] -> return ()
, testCase "portforward injects ct status dnat accept into Forward chain" $ do
v <- compileToValue
"portforward wan_forwards on wan via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\}; \
\policy forward : Frame hook Forward = { | _ -> Drop; };"
arr <- nftArr v
let rules = withKey "rule" arr
fwdRules = filter (\r -> at ["rule","chain"] r == Just (A.String "forward")) rules
hasDnat = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","left","ct","key"] e == Just (A.String "status")) (V.toList es)
_ -> False) fwdRules
assertBool "Forward chain should have ct status dnat rule when portforward present" hasDnat
]
-- ─── Masquerade compile tests ────────────────────────────────────────────────
masqueradeCompileTests :: TestTree
masqueradeCompileTests = testGroup "masquerade compilation"
[ testCase "masquerade produces postrouting chain" $ do
v <- compileToValue
"let rfc1918 : Set<IPv4> = { 10.0.0.0/8 }; \
\masquerade wan_snat on wan src rfc1918;"
arr <- nftArr v
let chains = withKey "chain" arr
postChain = filter (\c ->
at ["chain","name"] c == Just (A.String "wan_snat_postrouting")) chains
assertBool "Should have wan_snat_postrouting chain" (not (null postChain))
case postChain of
(c:_) -> do
at ["chain","type"] c @?= Just (A.String "nat")
at ["chain","hook"] c @?= Just (A.String "postrouting")
[] -> return ()
, testCase "masquerade rule has oifname match and masquerade verdict" $ do
v <- compileToValue
"let rfc1918 : Set<IPv4> = { 10.0.0.0/8 }; \
\masquerade wan_snat on wan src rfc1918;"
arr <- nftArr v
let rules = withKey "rule" arr
snatRules = filter (\r ->
at ["rule","chain"] r == Just (A.String "wan_snat_postrouting")) rules
hasOifname = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["match","left","meta","key"] e == Just (A.String "oifname")) (V.toList es)
_ -> False) snatRules
hasMasq = any (\r ->
case at ["rule","expr"] r of
Just (A.Array es) -> any (\e ->
at ["masquerade"] e /= Nothing) (V.toList es)
_ -> False) snatRules
assertBool "Masquerade rule should match oifname" hasOifname
assertBool "Masquerade rule should have masquerade verdict" hasMasq
]

92
test/ParserTests.hs
View File

@@ -17,6 +17,8 @@ tests = testGroup "Parser"
, typeTests
, exprTests
, policyTests
, portforwardTests
, masqueradeTests
, ruleTests
, configTests
, errorTests
@@ -351,31 +353,38 @@ exprTests = testGroup "expressions"
policyTests :: TestTree
policyTests = testGroup "policy"
[ testCase "minimal policy" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
[ testCase "compact hook Input syntax" $ do
p <- parseOk "policy input : Frame hook Input = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy "output" _ (PolicyMeta HOutput TFilter (Priority 0)) [_] -> return ()
DPolicy "input" _ (PolicyMeta HInput TFilter (Priority 0)) [_] -> return ()
_ -> assertFailure (show d)
, testCase "NAT prerouting" $ do
, testCase "hook Prerouting priority Mangle" $ do
p <- parseOk
"policy nat_pre : Frame \
\ on { hook = Prerouting, table = NAT, priority = DstNat } \
\ = { | _ -> Allow; };"
"policy pre : Frame hook Prerouting priority Mangle = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-100))) _ -> return ()
DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-150))) _ -> return ()
_ -> assertFailure (show d)
, testCase "hook Forward infers filter table and priority 0" $ do
p <- parseOk "policy forward : Frame hook Forward = { | _ -> Drop; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HForward TFilter (Priority 0)) _ -> return ()
_ -> assertFailure (show d)
, testCase "hook Postrouting infers nat table and priority 100" $ do
p <- parseOk "policy post : Frame hook Postrouting = { | _ -> Allow; };"
d <- singleDecl p
case d of
DPolicy _ _ (PolicyMeta HPostrouting TNAT (Priority 100)) _ -> return ()
_ -> assertFailure (show d)
, testCase "arm with guard" $ do
p <- parseOk
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
"policy input : Frame hook Input = { \
\ | _ if ct.state in { Established, Related } -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -386,9 +395,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern with path" $ do
p <- parseOk
"policy forward : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
"policy forward : Frame hook Forward = { \
\ | Frame(iif in lan_zone -> wan, _) -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -399,9 +406,7 @@ policyTests = testGroup "policy"
, testCase "Frame pattern without Ether (layer stripping)" $ do
p <- parseOk
"policy input : Frame \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { \
"policy input : Frame hook Input = { \
\ | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \
\ | _ -> Drop; \
\ };"
@@ -412,9 +417,7 @@ policyTests = testGroup "policy"
, testCase "policy arm calls rule" $ do
p <- parseOk
"policy forward : Frame \
\ on { hook = Forward, table = Filter, priority = Filter } \
\ = { \
"policy forward : Frame hook Forward = { \
\ | frame -> blockOutboundWG(frame); \
\ };"
d <- singleDecl p
@@ -435,6 +438,36 @@ policyTests = testGroup "policy"
_ -> assertFailure (show d)
]
-- ─── PortForward ─────────────────────────────────────────────────────────────
portforwardTests :: TestTree
portforwardTests = testGroup "portforward"
[ testCase "basic portforward decl" $ do
p <- parseOk
"portforward wan_forwards \
\ on wan \
\ via Map<(Protocol, Port), (IPv4, Port)> = { \
\ (tcp, :8080) -> (10.0.0.10, :80) \
\ };"
d <- singleDecl p
case d of
DPortForward "wan_forwards" "wan" (TName "Map" [TTuple _, TTuple _]) [(_, _)] -> return ()
DPortForward "wan_forwards" "wan" _ [_] -> return ()
_ -> assertFailure (show d)
]
-- ─── Masquerade ──────────────────────────────────────────────────────────────
masqueradeTests :: TestTree
masqueradeTests = testGroup "masquerade"
[ testCase "basic masquerade decl" $ do
p <- parseOk "masquerade wan_snat on wan src rfc1918;"
d <- singleDecl p
case d of
DMasquerade "wan_snat" "wan" "rfc1918" -> return ()
_ -> assertFailure (show d)
]
-- ─── Rule ────────────────────────────────────────────────────────────────────
ruleTests :: TestTree
@@ -495,17 +528,18 @@ errorTests = testGroup "parse errors"
[ testCase "missing semicolon" $
parseFail "interface wan : WAN {}"
, testCase "unknown hook" $
, testCase "old on-brace policy syntax is a parse error" $
parseFail
"policy p : Frame \
\ on { hook = Bogus, table = Filter, priority = Filter } \
\ on { hook = Input, table = Filter, priority = Filter } \
\ = { | _ -> Allow; };"
, testCase "unknown hook" $
parseFail
"policy p : Frame hook Bogus = { | _ -> Allow; };"
, testCase "empty arm block with no arms is ok" $ do
p <- parseOk
"policy output : Frame \
\ on { hook = Output, table = Filter, priority = Filter } \
\ = {};"
p <- parseOk "policy output : Frame hook Output = {};"
d <- singleDecl p
case d of
DPolicy _ _ _ [] -> return ()