crazy mega refactor
This commit is contained in:
@@ -5,65 +5,33 @@ 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)> = {
|
||||
let forwards_v6 : Set<(Protocol, IPv6, 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;
|
||||
portforward wan_forwards
|
||||
on wan
|
||||
via Map<(Protocol, Port), (IPv4, Port)> = {
|
||||
(tcp, :8080) -> (10.0.0.10, :80)
|
||||
};
|
||||
|
||||
masquerade wan_snat
|
||||
on wan
|
||||
src rfc1918;
|
||||
|
||||
policy input : Frame hook Input = {
|
||||
| Frame(_, IPv4(_, TCP(tcp, _)))
|
||||
if tcp.dport in open_ports -> Allow;
|
||||
| Frame(_, IPv4(_, UDP(udp, _)))
|
||||
if udp.dport == :51944 -> Allow;
|
||||
| _ -> Drop;
|
||||
};
|
||||
};
|
||||
|
||||
policy forward : Frame
|
||||
on { hook = Forward, table = Filter, priority = Filter }
|
||||
= {
|
||||
| _ if ct.state in { Established, Related } -> Allow;
|
||||
| _ if ct.status == DNAT -> Allow;
|
||||
policy forward : Frame hook Forward = {
|
||||
| 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;
|
||||
};
|
||||
};
|
||||
|
||||
@@ -33,22 +33,11 @@
|
||||
"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",
|
||||
"name": "wan_forwards_prerouting",
|
||||
"policy": "accept",
|
||||
"prio": -100,
|
||||
"table": "fwl",
|
||||
@@ -59,41 +48,13 @@
|
||||
"chain": {
|
||||
"family": "inet",
|
||||
"hook": "postrouting",
|
||||
"name": "nat_postrouting",
|
||||
"name": "wan_snat_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": [
|
||||
@@ -117,7 +78,7 @@
|
||||
"ipv4_addr",
|
||||
"inet_service"
|
||||
],
|
||||
"name": "forwards",
|
||||
"name": "wan_forwards",
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
@@ -125,6 +86,37 @@
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"elem": [
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "10.0.0.0",
|
||||
"len": 8
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "172.16.0.0",
|
||||
"len": 12
|
||||
}
|
||||
},
|
||||
{
|
||||
"prefix": {
|
||||
"addr": "192.168.0.0",
|
||||
"len": 16
|
||||
}
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"flags": [
|
||||
"interval"
|
||||
],
|
||||
"name": "rfc1918",
|
||||
"table": "fwl",
|
||||
"type": "ipv4_addr"
|
||||
}
|
||||
},
|
||||
{
|
||||
"set": {
|
||||
"elem": [
|
||||
@@ -152,7 +144,7 @@
|
||||
"table": "fwl",
|
||||
"type": [
|
||||
"inet_proto",
|
||||
"ipv4_addr",
|
||||
"ipv6_addr",
|
||||
"inet_service"
|
||||
]
|
||||
}
|
||||
@@ -168,12 +160,14 @@
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": [
|
||||
"op": "==",
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
@@ -210,17 +204,6 @@
|
||||
"rule": {
|
||||
"chain": "input",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv6"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
@@ -244,7 +227,7 @@
|
||||
"op": "==",
|
||||
"right": {
|
||||
"prefix": {
|
||||
"addr": "fe80:0:0:0:0:0:0:0",
|
||||
"addr": "fe80::",
|
||||
"len": 10
|
||||
}
|
||||
}
|
||||
@@ -373,12 +356,14 @@
|
||||
"key": "state"
|
||||
}
|
||||
},
|
||||
"op": "in",
|
||||
"right": [
|
||||
"op": "==",
|
||||
"right": {
|
||||
"set": [
|
||||
"established",
|
||||
"related"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
@@ -399,7 +384,7 @@
|
||||
"key": "status"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"op": "in",
|
||||
"right": "dnat"
|
||||
}
|
||||
},
|
||||
@@ -449,170 +434,6 @@
|
||||
"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",
|
||||
@@ -670,9 +491,8 @@
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"payload": {
|
||||
"field": "protocol",
|
||||
"protocol": "ip6"
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
@@ -758,9 +578,8 @@
|
||||
"left": {
|
||||
"concat": [
|
||||
{
|
||||
"payload": {
|
||||
"field": "protocol",
|
||||
"protocol": "ip6"
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
{
|
||||
@@ -803,19 +622,7 @@
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "output",
|
||||
"expr": [
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "nat_prerouting",
|
||||
"chain": "wan_forwards_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
@@ -835,46 +642,53 @@
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "tcp"
|
||||
"op": "in",
|
||||
"right": {
|
||||
"set": [
|
||||
"tcp",
|
||||
"udp"
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
"match": {
|
||||
"left": {
|
||||
"fib": {
|
||||
"flags": [
|
||||
"daddr"
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "nat_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
"result": "type"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv4"
|
||||
"right": "local"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"dnat": {
|
||||
"addr": {
|
||||
"map": {
|
||||
"data": "@wan_forwards",
|
||||
"key": {
|
||||
"concat": [
|
||||
{
|
||||
"meta": {
|
||||
"key": "l4proto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "udp"
|
||||
{
|
||||
"payload": {
|
||||
"field": "dport",
|
||||
"protocol": "th"
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
},
|
||||
{
|
||||
"accept": null
|
||||
"family": "ip"
|
||||
}
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
@@ -883,19 +697,7 @@
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "nat_prerouting",
|
||||
"expr": [
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "nat_postrouting",
|
||||
"chain": "wan_snat_postrouting",
|
||||
"expr": [
|
||||
{
|
||||
"match": {
|
||||
@@ -908,17 +710,6 @@
|
||||
"right": "wan"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
"meta": {
|
||||
"key": "nfproto"
|
||||
}
|
||||
},
|
||||
"op": "==",
|
||||
"right": "ipv4"
|
||||
}
|
||||
},
|
||||
{
|
||||
"match": {
|
||||
"left": {
|
||||
@@ -938,18 +729,6 @@
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
},
|
||||
{
|
||||
"rule": {
|
||||
"chain": "nat_postrouting",
|
||||
"expr": [
|
||||
{
|
||||
"accept": null
|
||||
}
|
||||
],
|
||||
"family": "inet",
|
||||
"table": "fwl"
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -30,6 +30,10 @@ data Decl
|
||||
| DFlow Name FlowExpr
|
||||
| DRule Name Type Expr
|
||||
| DPolicy Name Type PolicyMeta ArmBlock
|
||||
| DPortForward Name Name Type [(Expr, Expr)]
|
||||
-- ^ decl-name interface-name map-type map-entries
|
||||
| DMasquerade Name Name Name
|
||||
-- ^ decl-name interface-name src-set-name
|
||||
deriving (Show)
|
||||
|
||||
data PolicyMeta = PolicyMeta
|
||||
|
||||
@@ -50,6 +50,8 @@ buildEnv = foldl' addDecl Map.empty
|
||||
addDecl m (DFlow n _) = Map.insert n KFlow m
|
||||
addDecl m (DRule n _ _) = Map.insert n KRule m
|
||||
addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m
|
||||
addDecl m (DPortForward n _ _ _) = Map.insert n KLet m
|
||||
addDecl m (DMasquerade n _ _) = Map.insert n KLet m
|
||||
|
||||
findDups :: [Decl] -> [CheckError]
|
||||
findDups decls = go [] Set.empty decls
|
||||
@@ -70,6 +72,8 @@ declName (DPattern n _ _) = n
|
||||
declName (DFlow n _) = n
|
||||
declName (DRule n _ _) = n
|
||||
declName (DPolicy n _ _ _) = n
|
||||
declName (DPortForward n _ _ _) = n
|
||||
declName (DMasquerade n _ _) = n
|
||||
|
||||
declKindStr :: Decl -> String
|
||||
declKindStr (DInterface _ _ _) = "interface"
|
||||
@@ -80,6 +84,8 @@ declKindStr (DPattern _ _ _) = "pattern"
|
||||
declKindStr (DFlow _ _) = "flow"
|
||||
declKindStr (DRule _ _ _) = "rule"
|
||||
declKindStr (DPolicy _ _ _ _) = "policy"
|
||||
declKindStr (DPortForward _ _ _ _) = "portforward"
|
||||
declKindStr (DMasquerade _ _ _) = "masquerade"
|
||||
|
||||
-- ─── Name resolution ─────────────────────────────────────────────────────────
|
||||
|
||||
@@ -90,6 +96,12 @@ checkDecl env (DFlow _ fe) = checkFlow env fe
|
||||
checkDecl env (DRule _ _ e) = checkExpr env e
|
||||
checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab
|
||||
checkDecl env (DLet _ _ e) = checkExpr env e
|
||||
checkDecl env (DPortForward _ iface _ entries) =
|
||||
checkName env "interface" iface ++
|
||||
concatMap (\(k,v) -> checkExpr env k ++ checkExpr env v) entries
|
||||
checkDecl env (DMasquerade _ iface srcSet) =
|
||||
checkName env "interface" iface ++
|
||||
checkName env "set" srcSet
|
||||
checkDecl _ _ = []
|
||||
|
||||
checkName :: Env -> String -> String -> [CheckError]
|
||||
|
||||
@@ -32,7 +32,7 @@ compileProgram = programToValue
|
||||
programToValue :: Program -> Value
|
||||
programToValue (Program cfg decls) =
|
||||
object [ "nftables" .= toJSON
|
||||
(metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
|
||||
(metainfo : tableObj : allObjects) ]
|
||||
where
|
||||
env = buildEnv decls
|
||||
tbl = configTable cfg
|
||||
@@ -42,14 +42,164 @@ programToValue (Program cfg decls) =
|
||||
tableObj = object [ "table" .= tableValue tbl ]
|
||||
|
||||
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
|
||||
chainObjs = map (\(n, pm, _ ) -> chainDeclValue tbl n pm) policies
|
||||
ruleObjs = concatMap
|
||||
(\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab)
|
||||
policies
|
||||
portfwds = [ d | d@(DPortForward {}) <- decls ]
|
||||
masqs = [ d | d@(DMasquerade {}) <- decls ]
|
||||
hasPortFwd = not (null portfwds)
|
||||
|
||||
-- Chain declarations: policy chains + synthesised NAT chains
|
||||
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
|
||||
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
|
||||
masqChainObjs = concatMap (masqChainValue tbl) masqs
|
||||
|
||||
-- Rules: policy arms + implicit injections + synthesised NAT rules
|
||||
policyRuleObjs = concatMap
|
||||
(\(n, pm, ab) ->
|
||||
injectFilterRules env tbl n pm hasPortFwd ++
|
||||
concatMap (armToRuleValues env tbl n) ab)
|
||||
policies
|
||||
pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds
|
||||
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
|
||||
|
||||
-- Sets / maps from let-bindings
|
||||
letDecls = [ (n, t, e) | DLet n t e <- decls ]
|
||||
mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls
|
||||
|
||||
-- Synthesised maps from portforward decls
|
||||
pfMapObjs = concatMap (portfwdMapValue tbl) portfwds
|
||||
|
||||
allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs
|
||||
++ pfMapObjs ++ mapObjs
|
||||
++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs
|
||||
|
||||
-- ─── Implicit filter-hook rule injection ─────────────────────────────────────
|
||||
|
||||
-- | Prepend implicit rules for filter-hook chains (Input/Forward/Output).
|
||||
injectFilterRules :: CompileEnv -> String -> Name -> PolicyMeta -> Bool -> [Value]
|
||||
injectFilterRules env tbl chain pm hasPortFwd =
|
||||
case pmHook pm of
|
||||
HInput -> [statefulRule, loopbackRule, ndpRule]
|
||||
HForward -> statefulRule : if hasPortFwd then [ctDnatRule] else []
|
||||
HOutput -> [statefulRule]
|
||||
_ -> []
|
||||
where
|
||||
statefulRule = ruleValue tbl chain
|
||||
[ matchExpr "==" (object ["ct" .= object ["key" .= ("state" :: String)]])
|
||||
(setVal [A.String "established", A.String "related"])
|
||||
, object ["accept" .= Null]
|
||||
]
|
||||
loopbackRule = ruleValue tbl chain
|
||||
[ matchMeta "iifname" "lo"
|
||||
, object ["accept" .= Null]
|
||||
]
|
||||
ndpRule = ruleValue tbl chain
|
||||
[ matchPayload "ip6" "nexthdr" "ipv6-icmp"
|
||||
, matchExpr "==" (payloadVal "ip6" "saddr")
|
||||
(object ["prefix" .= object ["addr" .= A.String "fe80::", "len" .= (10 :: Int)]])
|
||||
, object ["accept" .= Null]
|
||||
]
|
||||
ctDnatRule = ruleValue tbl chain
|
||||
[ matchExpr "in" (object ["ct" .= object ["key" .= ("status" :: String)]])
|
||||
(A.String "dnat")
|
||||
, object ["accept" .= Null]
|
||||
]
|
||||
-- silence unused env warning
|
||||
_ = env
|
||||
|
||||
ruleValue :: String -> String -> [Value] -> Value
|
||||
ruleValue tbl chain exprs = object
|
||||
[ "rule" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "chain" .= chain
|
||||
, "expr" .= toJSON exprs
|
||||
]
|
||||
]
|
||||
|
||||
-- ─── DPortForward compilation ─────────────────────────────────────────────────
|
||||
|
||||
portfwdMapValue :: String -> Decl -> [Value]
|
||||
portfwdMapValue tbl (DPortForward n _ t entries) =
|
||||
case t of
|
||||
TName "Map" [tk, tv] ->
|
||||
[ object [ "map" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= renderNftType (fwlTypeToNft tk)
|
||||
, "map" .= renderNftType (fwlTypeToNft tv)
|
||||
, "elem" .= toJSON (map renderMapElem entries)
|
||||
] ]
|
||||
]
|
||||
_ -> []
|
||||
portfwdMapValue _ _ = []
|
||||
|
||||
portfwdChainValue :: String -> Decl -> [Value]
|
||||
portfwdChainValue tbl (DPortForward n _ _ _) =
|
||||
[ object [ "chain" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= (n ++ "_prerouting")
|
||||
, "type" .= ("nat" :: String)
|
||||
, "hook" .= ("prerouting" :: String)
|
||||
, "prio" .= priorityInt pDstNat
|
||||
, "policy" .= ("accept" :: String)
|
||||
] ]
|
||||
]
|
||||
portfwdChainValue _ _ = []
|
||||
|
||||
portfwdRuleValues :: CompileEnv -> String -> Decl -> [Value]
|
||||
portfwdRuleValues _ tbl (DPortForward n _ _ _) =
|
||||
let chainName = n ++ "_prerouting"
|
||||
in [ ruleValue tbl chainName
|
||||
[ matchMeta "nfproto" "ipv4"
|
||||
, matchInSet (metaVal "l4proto") [A.String "tcp", A.String "udp"]
|
||||
, matchExpr "==" (object ["fib" .= object ["result" .= ("type" :: String), "flags" .= toJSON (["daddr"] :: [String])]])
|
||||
(A.String "local")
|
||||
, object ["dnat" .= object
|
||||
[ "family" .= ("ip" :: String)
|
||||
, "addr" .= object
|
||||
[ "map" .= object
|
||||
[ "key" .= object ["concat" .= toJSON
|
||||
[ metaVal "l4proto"
|
||||
, payloadVal "th" "dport"
|
||||
]]
|
||||
, "data" .= A.String (toText ("@" ++ n))
|
||||
]
|
||||
]
|
||||
]]
|
||||
]
|
||||
]
|
||||
portfwdRuleValues _ _ _ = []
|
||||
|
||||
-- ─── DMasquerade compilation ──────────────────────────────────────────────────
|
||||
|
||||
masqChainValue :: String -> Decl -> [Value]
|
||||
masqChainValue tbl (DMasquerade n _ _) =
|
||||
[ object [ "chain" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= (n ++ "_postrouting")
|
||||
, "type" .= ("nat" :: String)
|
||||
, "hook" .= ("postrouting" :: String)
|
||||
, "prio" .= priorityInt pSrcNat
|
||||
, "policy" .= ("accept" :: String)
|
||||
] ]
|
||||
]
|
||||
masqChainValue _ _ = []
|
||||
|
||||
masqRuleValues :: CompileEnv -> String -> Decl -> [Value]
|
||||
masqRuleValues _ tbl (DMasquerade n iface srcSet) =
|
||||
let chainName = n ++ "_postrouting"
|
||||
in [ ruleValue tbl chainName
|
||||
[ matchMeta "oifname" iface
|
||||
, matchExpr "==" (payloadVal "ip" "saddr")
|
||||
(A.String (toText ("@" ++ srcSet)))
|
||||
, object ["masquerade" .= Null]
|
||||
]
|
||||
]
|
||||
masqRuleValues _ _ _ = []
|
||||
|
||||
|
||||
-- ─── Table / Chain declarations ──────────────────────────────────────────────
|
||||
|
||||
tableValue :: String -> Value
|
||||
@@ -125,6 +275,8 @@ buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty
|
||||
declNameOf (DPolicy n _ _ _) = n
|
||||
declNameOf (DLet n _ _) = n
|
||||
declNameOf (DImport n _ _) = n
|
||||
declNameOf (DPortForward n _ _ _) = n
|
||||
declNameOf (DMasquerade n _ _) = n
|
||||
|
||||
compilePat :: CompileEnv -> Pat -> [[Value]]
|
||||
compilePat _ PWild = [[]]
|
||||
@@ -234,12 +386,14 @@ letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
|
||||
]
|
||||
letToSetOrMapValue tbl n (TName "Set" [t]) (ESet entries) = Just $ object
|
||||
[ "set" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
( [ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= renderNftType (fwlTypeToNft t)
|
||||
, "elem" .= toJSON (map renderSetElem entries)
|
||||
]
|
||||
++ (if any isCidrElem entries then ["flags" .= toJSON (["interval"] :: [String])] else [])
|
||||
++ [ "elem" .= toJSON (map renderSetElem entries) ]
|
||||
)
|
||||
]
|
||||
letToSetOrMapValue _ _ _ _ = Nothing
|
||||
|
||||
@@ -287,6 +441,11 @@ renderMapElem (k, v) = toJSON
|
||||
renderSetElem :: Expr -> Value
|
||||
renderSetElem = renderMapOrSetKey
|
||||
|
||||
-- | True if an expression is a CIDR literal (requires 'interval' flag in nftables set)
|
||||
isCidrElem :: Expr -> Bool
|
||||
isCidrElem (ELit (LCIDR _ _)) = True
|
||||
isCidrElem _ = False
|
||||
|
||||
-- ─── Aeson building blocks ───────────────────────────────────────────────────
|
||||
|
||||
matchExpr :: String -> Value -> Value -> Value
|
||||
@@ -337,8 +496,10 @@ 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 ["meta", k]) = metaVal k
|
||||
exprVal _ (EQual ["th", k]) = payloadVal "th" k
|
||||
exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto" -- nexthdr alias via l4proto
|
||||
exprVal _ (EQual ["ip", "protocol"]) = metaVal "l4proto"
|
||||
exprVal _ (EQual [p, f]) = payloadVal p (mapField f)
|
||||
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns))
|
||||
exprVal env (EVar n)
|
||||
|
||||
@@ -20,9 +20,10 @@ fwlDef = emptyDef
|
||||
-- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must
|
||||
-- NOT be reserved so that `identifier` can consume them in those
|
||||
-- positions.
|
||||
[ "config", "table"
|
||||
[ "config"
|
||||
, "interface", "zone", "import", "from"
|
||||
, "let", "in", "pattern", "flow", "rule", "policy", "on"
|
||||
, "portforward", "masquerade", "via", "src"
|
||||
, "case", "of", "if", "then", "else", "do", "perform"
|
||||
, "within", "as", "dynamic", "cidr4", "cidr6"
|
||||
, "hook", "priority"
|
||||
|
||||
@@ -47,10 +47,10 @@ configBlock = do
|
||||
|
||||
configProp :: Parser (String, String)
|
||||
configProp = do
|
||||
reserved "table"
|
||||
n <- identifier -- "table" is no longer reserved
|
||||
reservedOp "="
|
||||
v <- stringLit
|
||||
return ("table", v)
|
||||
return (n, v)
|
||||
|
||||
-- ─── Declarations ────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -63,6 +63,8 @@ decl = interfaceDecl
|
||||
<|> flowDecl
|
||||
<|> ruleDecl
|
||||
<|> policyDecl
|
||||
<|> portforwardDecl
|
||||
<|> masqueradeDecl
|
||||
|
||||
interfaceDecl :: Parser Decl
|
||||
interfaceDecl = do
|
||||
@@ -158,26 +160,31 @@ policyDecl = do
|
||||
n <- identifier
|
||||
reservedOp ":"
|
||||
t <- typeP
|
||||
reserved "on"
|
||||
pm <- braces policyMeta
|
||||
reserved "hook"
|
||||
h <- hookP
|
||||
mp <- optionMaybe (reserved "priority" >> priorityP)
|
||||
let tb = hookDefaultTable h
|
||||
pr = maybe (hookDefaultPriority h) id mp
|
||||
reservedOp "="
|
||||
ab <- armBlock
|
||||
_ <- semi
|
||||
return (DPolicy n t pm ab)
|
||||
return (DPolicy n t (PolicyMeta h tb pr) ab)
|
||||
|
||||
policyMeta :: Parser PolicyMeta
|
||||
policyMeta = do
|
||||
props <- commaSep1 metaProp
|
||||
let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props
|
||||
tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props
|
||||
pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) pFilter props
|
||||
return (PolicyMeta h tb pr)
|
||||
-- | Infer table from hook
|
||||
hookDefaultTable :: Hook -> TableName
|
||||
hookDefaultTable HInput = TFilter
|
||||
hookDefaultTable HForward = TFilter
|
||||
hookDefaultTable HOutput = TFilter
|
||||
hookDefaultTable HPrerouting = TNAT
|
||||
hookDefaultTable HPostrouting = TNAT
|
||||
|
||||
metaProp :: Parser (Either Hook (Either TableName Priority))
|
||||
metaProp
|
||||
= (reserved "hook" >> reservedOp "=" >> fmap (Left) hookP)
|
||||
<|> (reserved "table" >> reservedOp "=" >> fmap (Right . Left) tableNameP)
|
||||
<|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right) priorityP)
|
||||
-- | Default priority per hook
|
||||
hookDefaultPriority :: Hook -> Priority
|
||||
hookDefaultPriority HInput = pFilter
|
||||
hookDefaultPriority HForward = pFilter
|
||||
hookDefaultPriority HOutput = pFilter
|
||||
hookDefaultPriority HPrerouting = pDstNat
|
||||
hookDefaultPriority HPostrouting = pSrcNat
|
||||
|
||||
hookP :: Parser Hook
|
||||
hookP = (reserved "Input" >> return HInput)
|
||||
@@ -186,9 +193,31 @@ hookP = (reserved "Input" >> return HInput)
|
||||
<|> (reserved "Prerouting" >> return HPrerouting)
|
||||
<|> (reserved "Postrouting" >> return HPostrouting)
|
||||
|
||||
tableNameP :: Parser TableName
|
||||
tableNameP = (reserved "Filter" >> return TFilter)
|
||||
<|> (reserved "NAT" >> return TNAT)
|
||||
-- portforward <name> on <iface> via <MapType> = { entries };
|
||||
portforwardDecl :: Parser Decl
|
||||
portforwardDecl = do
|
||||
reserved "portforward"
|
||||
n <- identifier
|
||||
reserved "on"
|
||||
iface <- identifier
|
||||
reserved "via"
|
||||
t <- typeP
|
||||
reservedOp "="
|
||||
entries <- braces (commaSep mapEntry)
|
||||
_ <- semi
|
||||
return (DPortForward n iface t entries)
|
||||
|
||||
-- masquerade <name> on <iface> src <set-name>;
|
||||
masqueradeDecl :: Parser Decl
|
||||
masqueradeDecl = do
|
||||
reserved "masquerade"
|
||||
n <- identifier
|
||||
reserved "on"
|
||||
iface <- identifier
|
||||
reserved "src"
|
||||
srcSet <- identifier
|
||||
_ <- semi
|
||||
return (DMasquerade n iface srcSet)
|
||||
|
||||
priorityP :: Parser Priority
|
||||
priorityP
|
||||
|
||||
@@ -31,11 +31,22 @@ prettyDecl (DFlow n f) =
|
||||
prettyDecl (DRule n t e) =
|
||||
"rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";"
|
||||
prettyDecl (DPolicy n t pm ab) =
|
||||
"policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++
|
||||
" on { hook = " ++ prettyHook (pmHook pm) ++
|
||||
", table = " ++ prettyTable (pmTable pm) ++
|
||||
", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++
|
||||
"policy " ++ n ++ " : " ++ prettyType t ++
|
||||
" hook " ++ prettyHook (pmHook pm) ++
|
||||
(if pmPriority pm /= prettyDefaultPriority (pmHook pm)
|
||||
then " priority " ++ prettyNamedPriority (pmPriority pm)
|
||||
else "") ++ "\n" ++
|
||||
" = " ++ prettyArmBlock ab ++ ";"
|
||||
prettyDecl (DPortForward n iface t entries) =
|
||||
"portforward " ++ n ++ "\n" ++
|
||||
" on " ++ iface ++ "\n" ++
|
||||
" via " ++ prettyType t ++ " = {\n" ++
|
||||
concatMap (\(k,v) -> " " ++ prettyExpr k ++ " -> " ++ prettyExpr v ++ "\n") entries ++
|
||||
" };"
|
||||
prettyDecl (DMasquerade n iface srcSet) =
|
||||
"masquerade " ++ n ++ "\n" ++
|
||||
" on " ++ iface ++ "\n" ++
|
||||
" src " ++ srcSet ++ ";"
|
||||
|
||||
prettyKind :: IfaceKind -> String
|
||||
prettyKind IWan = "WAN"
|
||||
@@ -58,12 +69,24 @@ prettyHook HOutput = "Output"
|
||||
prettyHook HPrerouting = "Prerouting"
|
||||
prettyHook HPostrouting = "Postrouting"
|
||||
|
||||
prettyTable :: TableName -> String
|
||||
prettyTable TFilter = "Filter"
|
||||
prettyTable TNAT = "NAT"
|
||||
-- | Default priority for a hook (for round-trip: omit when at default)
|
||||
prettyDefaultPriority :: Hook -> Priority
|
||||
prettyDefaultPriority HInput = pFilter
|
||||
prettyDefaultPriority HForward = pFilter
|
||||
prettyDefaultPriority HOutput = pFilter
|
||||
prettyDefaultPriority HPrerouting = pDstNat
|
||||
prettyDefaultPriority HPostrouting = pSrcNat
|
||||
|
||||
prettyPriority :: Priority -> String
|
||||
prettyPriority p = show (priorityValue p)
|
||||
-- | Emit a named priority constant when possible, otherwise decimal
|
||||
prettyNamedPriority :: Priority -> String
|
||||
prettyNamedPriority p
|
||||
| p == pFilter = "Filter"
|
||||
| p == pDstNat = "DstNat"
|
||||
| p == pSrcNat = "SrcNat"
|
||||
| p == pMangle = "Mangle"
|
||||
| p == pRaw = "Raw"
|
||||
| p == pConnTrack= "ConnTrack"
|
||||
| otherwise = show (priorityValue p)
|
||||
|
||||
prettyType :: Type -> String
|
||||
prettyType (TName n []) = n
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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,9 +184,8 @@ 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; \
|
||||
"policy input : Frame hook Input = \
|
||||
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
|
||||
\ | _ -> Drop; \
|
||||
\ };"
|
||||
arr <- nftArr v
|
||||
@@ -245,9 +197,8 @@ 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; \
|
||||
"policy input : Frame hook Input = \
|
||||
\ { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
|
||||
\ | _ -> Drop; \
|
||||
\ };"
|
||||
arr <- nftArr v
|
||||
@@ -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,15 +252,13 @@ 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; \
|
||||
"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; \
|
||||
"policy p1 : Frame hook Input = \
|
||||
\ { | Frame(_, IPv4(ip, _)) -> Allow; \
|
||||
\ | _ -> Drop; \
|
||||
\ };"
|
||||
v1 <- compileToValue withEther
|
||||
@@ -338,21 +276,10 @@ 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; \
|
||||
"policy input : Frame hook Input = \
|
||||
\ { | _ if ct.state in { Established } -> Allow; \
|
||||
\ | _ -> Drop; \
|
||||
\ };"
|
||||
arr <- nftArr v
|
||||
@@ -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
|
||||
]
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user