From 6d96e2d1599d2c3cc734d41c1d6fbe9d511ab500 Mon Sep 17 00:00:00 2001 From: Yuri Tatishchev Date: Mon, 4 May 2026 03:16:40 -0700 Subject: [PATCH] crazy mega refactor --- examples/simple-router.fwl | 80 ++----- examples/simple-router.fwl.json | 407 ++++++++------------------------ src/FWL/AST.hs | 20 +- src/FWL/Check.hs | 12 + src/FWL/Compile.hs | 225 +++++++++++++++--- src/FWL/Lexer.hs | 3 +- src/FWL/Parser.hs | 71 ++++-- src/FWL/Pretty.hs | 41 +++- test/CheckTests.hs | 34 +-- test/CompileTests.hs | 317 +++++++++++++++---------- test/ParserTests.hs | 92 +++++--- 11 files changed, 686 insertions(+), 616 deletions(-) diff --git a/examples/simple-router.fwl b/examples/simple-router.fwl index 9f1c454..09e5964 100644 --- a/examples/simple-router.fwl +++ b/examples/simple-router.fwl @@ -1,69 +1,37 @@ -interface wan : WAN { dynamic; }; -interface lan : LAN { cidr4 = { 10.0.0.0/24 }; }; +interface wan : WAN { dynamic; }; +interface lan : LAN { cidr4 = { 10.0.0.0/24 }; }; zone lan_zone = { lan }; let rfc1918 : Set = { 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 = { :22 }; --- IPv6 forwarded destination: tcp . 2001:db8::1 . 22000 -let forwards_v6 : Set<(Protocol, IP, Port)> = { - (tcp, 2001:db8::1, :22000) +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; + if tcp.dport in open_ports -> Allow; | Frame(_, IPv4(_, UDP(udp, _))) - if udp.dport == :51944 -> Allow; - | _ -> Drop; - }; + 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; +policy forward : Frame hook Forward = { + | Frame(iif in lan_zone -> wan, _) -> Allow; | Frame(wan -> iif in lan_zone, IPv6(ip6, TCP(th, _) | UDP(th, _))) - if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow; - | _ -> Drop; - }; - -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; - }; + if (ip6.protocol, ip6.dst, th.dport) in forwards_v6 -> Allow; + | _ -> Drop; +}; diff --git a/examples/simple-router.fwl.json b/examples/simple-router.fwl.json index 02a6dce..eeb89ad 100644 --- a/examples/simple-router.fwl.json +++ b/examples/simple-router.fwl.json @@ -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,11 +160,13 @@ "key": "state" } }, - "op": "in", - "right": [ - "established", - "related" - ] + "op": "==", + "right": { + "set": [ + "established", + "related" + ] + } } }, { @@ -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,11 +356,13 @@ "key": "state" } }, - "op": "in", - "right": [ - "established", - "related" - ] + "op": "==", + "right": { + "set": [ + "established", + "related" + ] + } } }, { @@ -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" - } - }, - { - "accept": null - } - ], - "family": "inet", - "table": "fwl" - } - }, - { - "rule": { - "chain": "nat_prerouting", - "expr": [ - { - "match": { - "left": { - "meta": { - "key": "nfproto" - } - }, - "op": "==", - "right": "ipv4" + "op": "in", + "right": { + "set": [ + "tcp", + "udp" + ] + } } }, { "match": { "left": { - "meta": { - "key": "l4proto" + "fib": { + "flags": [ + "daddr" + ], + "result": "type" } }, "op": "==", - "right": "udp" + "right": "local" } }, { - "accept": null + "dnat": { + "addr": { + "map": { + "data": "@wan_forwards", + "key": { + "concat": [ + { + "meta": { + "key": "l4proto" + } + }, + { + "payload": { + "field": "dport", + "protocol": "th" + } + } + ] + } + } + }, + "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" - } } ] } diff --git a/src/FWL/AST.hs b/src/FWL/AST.hs index e95aab9..ecefa2f 100644 --- a/src/FWL/AST.hs +++ b/src/FWL/AST.hs @@ -22,14 +22,18 @@ defaultConfig = Config { configTable = "fwl" } -- ─── Declarations ─────────────────────────────────────────────────────────── data Decl - = DInterface Name IfaceKind [IfaceProp] - | DZone Name [Name] - | DImport Name Type FilePath - | DLet Name Type Expr - | DPattern Name Type Pat - | DFlow Name FlowExpr - | DRule Name Type Expr - | DPolicy Name Type PolicyMeta ArmBlock + = DInterface Name IfaceKind [IfaceProp] + | DZone Name [Name] + | DImport Name Type FilePath + | DLet Name Type Expr + | DPattern Name Type Pat + | 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 diff --git a/src/FWL/Check.hs b/src/FWL/Check.hs index 9d7e59c..347fdd4 100644 --- a/src/FWL/Check.hs +++ b/src/FWL/Check.hs @@ -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] diff --git a/src/FWL/Compile.hs b/src/FWL/Compile.hs index f4043c1..54246a7 100644 --- a/src/FWL/Compile.hs +++ b/src/FWL/Compile.hs @@ -32,23 +32,173 @@ 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 + 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 + policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ] + 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 _ _ _ = [] - letDecls = [ (n, t, e) | DLet n t e <- decls ] - mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls -- ─── Table / Chain declarations ────────────────────────────────────────────── @@ -117,14 +267,16 @@ type CompileEnv = Map.Map String Decl buildEnv :: [Decl] -> CompileEnv buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty where - declNameOf (DInterface n _ _) = n - declNameOf (DZone n _) = n - declNameOf (DPattern n _ _) = n - declNameOf (DFlow n _) = n - declNameOf (DRule n _ _) = n - declNameOf (DPolicy n _ _ _) = n - declNameOf (DLet n _ _) = n - declNameOf (DImport n _ _) = n + declNameOf (DInterface n _ _) = n + declNameOf (DZone n _) = n + declNameOf (DPattern n _ _) = n + declNameOf (DFlow n _) = n + declNameOf (DRule n _ _) = n + declNameOf (DPolicy n _ _ _) = n + declNameOf (DLet n _ _) = n + declNameOf (DImport n _ _) = n + declNameOf (DPortForward n _ _ _) = n + declNameOf (DMasquerade n _ _) = n 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) - , "table" .= tbl - , "name" .= n - , "type" .= renderNftType (fwlTypeToNft t) - , "elem" .= toJSON (map renderSetElem entries) - ] + ( [ "family" .= ("inet" :: String) + , "table" .= tbl + , "name" .= n + , "type" .= renderNftType (fwlTypeToNft t) + ] + ++ (if any isCidrElem entries then ["flags" .= toJSON (["interval"] :: [String])] else []) + ++ [ "elem" .= toJSON (map renderSetElem entries) ] + ) ] letToSetOrMapValue _ _ _ _ = Nothing @@ -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 @@ -336,11 +495,13 @@ 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 _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]] +exprVal _ (EQual ["meta", k]) = metaVal k +exprVal _ (EQual ["th", k]) = payloadVal "th" k +exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto" -- 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) | Just (DInterface _ _ _) <- Map.lookup n env = A.String (toText n) | isSetOrMapRef env n = A.String ("@" <> toText n) diff --git a/src/FWL/Lexer.hs b/src/FWL/Lexer.hs index b6511e6..c0827fe 100644 --- a/src/FWL/Lexer.hs +++ b/src/FWL/Lexer.hs @@ -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" diff --git a/src/FWL/Parser.hs b/src/FWL/Parser.hs index 0db2f57..1a80914 100644 --- a/src/FWL/Parser.hs +++ b/src/FWL/Parser.hs @@ -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) + _ <- semi + return (DPolicy n t (PolicyMeta h tb pr) ab) -policyMeta :: Parser PolicyMeta -policyMeta = do - props <- commaSep1 metaProp - let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props - tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props - pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) pFilter props - return (PolicyMeta h tb pr) +-- | Infer table from hook +hookDefaultTable :: Hook -> TableName +hookDefaultTable HInput = TFilter +hookDefaultTable HForward = TFilter +hookDefaultTable HOutput = TFilter +hookDefaultTable HPrerouting = TNAT +hookDefaultTable HPostrouting = TNAT -metaProp :: Parser (Either Hook (Either TableName Priority)) -metaProp - = (reserved "hook" >> reservedOp "=" >> fmap (Left) hookP) - <|> (reserved "table" >> reservedOp "=" >> fmap (Right . Left) tableNameP) - <|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right) priorityP) +-- | Default priority per hook +hookDefaultPriority :: Hook -> Priority +hookDefaultPriority HInput = pFilter +hookDefaultPriority HForward = pFilter +hookDefaultPriority HOutput = pFilter +hookDefaultPriority HPrerouting = pDstNat +hookDefaultPriority HPostrouting = pSrcNat hookP :: Parser Hook hookP = (reserved "Input" >> return HInput) @@ -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 on via = { 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 on src ; +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 diff --git a/src/FWL/Pretty.hs b/src/FWL/Pretty.hs index 3cd7f3f..09def65 100644 --- a/src/FWL/Pretty.hs +++ b/src/FWL/Pretty.hs @@ -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 diff --git a/test/CheckTests.hs b/test/CheckTests.hs index ad00f4e..a6a9689 100644 --- a/test/CheckTests.hs +++ b/test/CheckTests.hs @@ -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 diff --git a/test/CompileTests.hs b/test/CompileTests.hs index 3a05ad1..27e97e0 100644 --- a/test/CompileTests.hs +++ b/test/CompileTests.hs @@ -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 = { 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 = { 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 + ] diff --git a/test/ParserTests.hs b/test/ParserTests.hs index d7f8708..3146e8f 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -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 ()