diff --git a/doc/fwl_grammar.md b/doc/fwl_grammar.md index 8c3724a..cbb95e1 100644 --- a/doc/fwl_grammar.md +++ b/doc/fwl_grammar.md @@ -165,6 +165,7 @@ pat ::= wildcardPat -- _ | bytesPat -- [ byteElem* ] | recordPat -- Ctor { field = lit, ... } | namedOrCtorPat -- Ctor(p,...) or bare identifier + | pat "|" pat -- Or-pattern wildcardPat ::= "_" framePat ::= "Frame" "(" frameArgs ")" diff --git a/examples/router.fwl b/examples/router.fwl index 889049a..3011184 100644 --- a/examples/router.fwl +++ b/examples/router.fwl @@ -7,7 +7,7 @@ interface wg0 : WireGuard {}; zone lan_zone = { lan, wg0 }; -import rfc1918 : CIDRSet from "builtin:rfc1918"; +let rfc1918 : Set = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 }; let forwards : Map<(Protocol, Port), (IP, Port)> = { (tcp, :8080) -> (10.17.1.10, :80), @@ -64,8 +64,8 @@ policy forward : Frame | _ if ct.status == DNAT -> Allow; | Frame(iif in lan_zone -> wan, _) -> Allow; | Frame(iif in lan_zone -> lan_zone, _) -> Allow; - | Frame(wan -> lan_zone, IPv4(ip, TCP(tcp, _))) - if (ip.dst, tcp.dport) in forwards -> Allow; + | Frame(wan -> lan_zone, IPv4(ip, TCP(th, _) | UDP(th, _))) + if (ip.protocol, th.dport) in forwards -> Allow; | _ -> Drop; }; @@ -80,9 +80,9 @@ policy output : Frame policy nat_prerouting : Frame on { hook = Prerouting, table = NAT, priority = DstNat } = { - | Frame(_, IPv4(ip, _)) -> + | Frame(_, IPv4(ip, TCP(th, _) | UDP(th, _))) -> if perform FIB.daddrLocal(ip.dst) - then DNATMap(forwards) + then DNATMap((ip.protocol, th.dport), forwards) else Allow; | _ -> Allow; }; diff --git a/src/FWL/AST.hs b/src/FWL/AST.hs index 2049661..e95aab9 100644 --- a/src/FWL/AST.hs +++ b/src/FWL/AST.hs @@ -82,6 +82,7 @@ data Pat | PTuple [Pat] | PFrame (Maybe PathPat) Pat | PBytes [ByteElem] + | POr Pat Pat deriving (Show) data FieldPat diff --git a/src/FWL/Check.hs b/src/FWL/Check.hs index 379f4d9..9d7e59c 100644 --- a/src/FWL/Check.hs +++ b/src/FWL/Check.hs @@ -20,6 +20,7 @@ data CheckError | PolicyNoContinue String -- policy name | PatternCycle [String] -- cycle path | DuplicateDecl String String -- kind, name + | OrPatternMismatch [String] [String] deriving (Show, Eq) type Env = Map.Map String DeclKind @@ -117,6 +118,25 @@ checkPat env (PRecord _ fs) = concatMap (checkFP env) fs checkPat env (PTuple ps) = concatMap (checkPat env) ps checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner checkPat _ (PBytes _) = [] +checkPat env (POr p1 p2) = + let v1 = boundVars p1 + v2 = boundVars p2 + errs = if Set.fromList v1 == Set.fromList v2 then [] else [OrPatternMismatch v1 v2] + in errs ++ checkPat env p1 ++ checkPat env p2 + +boundVars :: Pat -> [String] +boundVars (PVar n) = [n] +boundVars (PCtor _ ps) = concatMap boundVars ps +boundVars (PRecord _ fs) = concatMap boundFP fs +boundVars (PTuple ps) = concatMap boundVars ps +boundVars (PFrame _ p) = boundVars p +boundVars (POr p1 p2) = boundVars p1 +boundVars _ = [] + +boundFP :: FieldPat -> [String] +boundFP (FPBind n) = [n] +boundFP (FPAs _ v) = [v] +boundFP _ = [] checkFP :: Env -> FieldPat -> [CheckError] checkFP _ _ = [] -- field names checked by type-checker later @@ -153,6 +173,7 @@ addPat env (PFrame mp inner) = in case md of Just (EPName n) -> Map.insert n KLet env1; _ -> env1 Nothing -> env in addPat env' inner +addPat env (POr p1 _) = addPat env p1 addPat env _ = env addFP :: Env -> FieldPat -> Env @@ -211,6 +232,7 @@ checkPatternCycles decls = refsInPat (PCtor _ ps) = concatMap refsInPat ps refsInPat (PTuple ps) = concatMap refsInPat ps refsInPat (PFrame _ p) = refsInPat p + refsInPat (POr p1 p2) = refsInPat p1 ++ refsInPat p2 refsInPat _ = [] findCycles :: Map.Map String [String] -> [[String]] diff --git a/src/FWL/Compile.hs b/src/FWL/Compile.hs index 1ac9e74..75ade75 100644 --- a/src/FWL/Compile.hs +++ b/src/FWL/Compile.hs @@ -98,18 +98,17 @@ armToRuleValues env tbl chain (Arm p mg body) = case compileAction env body of Nothing -> [] Just verdict -> - let patExprs = compilePat env p - guardExprs = maybe [] (compileGuard env) mg - allExprs = patExprs ++ guardExprs ++ [verdict] + let patExprsAlts = compilePat env p + guardExprs = maybe [] (compileGuard env) mg in [ object [ "rule" .= object [ "family" .= ("inet" :: String) , "table" .= tbl , "chain" .= chain - , "expr" .= toJSON allExprs + , "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict]) ] ] - ] + | patExprs <- patExprsAlts ] -- ─── Pattern → [Value] ─────────────────────────────────────────────────────── @@ -127,54 +126,57 @@ buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty declNameOf (DLet n _ _) = n declNameOf (DImport n _ _) = n -compilePat :: CompileEnv -> Pat -> [Value] -compilePat _ PWild = [] -compilePat _ (PVar _) = [] +compilePat :: CompileEnv -> Pat -> [[Value]] +compilePat _ PWild = [[]] +compilePat _ (PVar _) = [[]] compilePat env (PNamed n) = expandNamedPat env n -compilePat env (PFrame mp inner) = - maybe [] (compilePathPat env) mp ++ compilePat env inner +compilePat env (PFrame mp inner) = do + pathConds <- maybe [[]] (compilePathPat env) mp + innerConds <- compilePat env inner + return (pathConds ++ innerConds) compilePat env (PCtor n ps) = compileCtorPat env n ps compilePat _ (PRecord n fs) = compileRecordPat n fs -compilePat env (PTuple ps) = concatMap (compilePat env) ps -compilePat _ (PBytes _) = [] +compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps)) +compilePat _ (PBytes _) = [[]] +compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2 -expandNamedPat :: CompileEnv -> Name -> [Value] +expandNamedPat :: CompileEnv -> Name -> [[Value]] expandNamedPat env n = case Map.lookup n env of Just (DPattern _ _ p) -> compilePat env p _ -> [] -compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value] +compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]] compileCtorPat env ctor ps = case ctor of "Ether" -> children - "IPv4" -> matchMeta "nfproto" "ipv4" : children - "IPv6" -> matchMeta "nfproto" "ipv6" : children - "TCP" -> matchMeta "l4proto" "tcp" : children - "UDP" -> matchMeta "l4proto" "udp" : children - "ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children - "ICMP" -> matchPayload "ip" "protocol" "icmp" : children + "IPv4" -> map (matchMeta "nfproto" "ipv4" :) children + "IPv6" -> map (matchMeta "nfproto" "ipv6" :) children + "TCP" -> map (matchMeta "l4proto" "tcp" :) children + "UDP" -> map (matchMeta "l4proto" "udp" :) children + "ICMPv6" -> map (matchPayload "ip6" "nexthdr" "ipv6-icmp" :) children + "ICMP" -> map (matchPayload "ip" "protocol" "icmp" :) children _ -> children where - children = concatMap (compilePat env) ps + children = map concat (sequence (map (compilePat env) ps)) -compileRecordPat :: String -> [FieldPat] -> [Value] -compileRecordPat proto = mapMaybe go +compileRecordPat :: String -> [FieldPat] -> [[Value]] +compileRecordPat proto fs = [mapMaybe go fs] where go (FPEq field lit) = Just (matchPayload proto field (renderLit lit)) go _ = Nothing -compilePathPat :: CompileEnv -> PathPat -> [Value] +compilePathPat :: CompileEnv -> PathPat -> [[Value]] compilePathPat env (PathPat ms md) = - maybe [] (compileEndpoint env "iifname") ms ++ - maybe [] (compileEndpoint env "oifname") md + [ maybe [] (compileEndpoint env "iifname") ms ++ + maybe [] (compileEndpoint env "oifname") md ] compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value] compileEndpoint _ _ EPWild = [] compileEndpoint _ dir (EPName n) = [matchMeta dir n] compileEndpoint env dir (EPMember _ z) = case Map.lookup z env of - Just (DZone _ ns) -> [matchInSet (metaVal dir) ns] - _ -> [matchInSet (metaVal dir) [z]] + Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)] + _ -> [matchInSet (metaVal dir) [A.String (toText z)]] -- ─── Guard → [Value] ───────────────────────────────────────────────────────── @@ -188,20 +190,20 @@ compileGuard _ _ = [] compileInExpr :: CompileEnv -> Expr -> Expr -> Value -- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element -- EQual case to eliminate the overlapping pattern match warning. -compileInExpr _ (EQual ["ct", "state"]) (ESet vs) = ctMatch "state" vs -compileInExpr _ (EQual ["ct", "status"]) (ESet vs) = ctMatch "status" vs +compileInExpr env (EQual ["ct", "state"]) (ESet vs) = ctMatch env "state" vs +compileInExpr env (EQual ["ct", "status"]) (ESet vs) = ctMatch env "status" vs compileInExpr env l (ESet vs) = - matchExpr "in" (exprVal env l) (setVal (map exprToStr vs)) + matchExpr "in" (exprVal env l) (setVal (map (exprVal env) vs)) compileInExpr env l (EVar z) | Just (DZone _ ns) <- Map.lookup z env = - matchExpr "in" (exprVal env l) (setVal ns) + matchExpr "in" (exprVal env l) (setVal (map (A.String . toText) ns)) compileInExpr env l r = matchExpr "==" (exprVal env l) (exprVal env r) -ctMatch :: String -> [Expr] -> Value -ctMatch key vs = matchExpr "in" +ctMatch :: CompileEnv -> String -> [Expr] -> Value +ctMatch env key vs = matchExpr "in" (object ["ct" .= object ["key" .= (key :: String)]]) - (setVal (map exprToStr vs)) + (setVal (map (exprVal env) vs)) -- ─── Action → Maybe Value ───────────────────────────────────────────────────── @@ -212,10 +214,10 @@ compileAction _ (EVar "Continue") = Nothing compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null]) compileAction _ (EApp (EVar "DNAT") arg) = Just $ object ["dnat" .= object ["addr" .= exprToStr arg]] -compileAction _ (EApp (EVar "DNATMap") arg) = +compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) = Just $ object ["dnat" .= object ["addr" .= object - [ "map" .= object [ "key" .= object ["concat" .= Array mempty] - , "data" .= exprToStr arg ]]]] + [ "map" .= object [ "key" .= exprVal env key + , "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]] compileAction env (EApp (EVar rn) _) = case Map.lookup rn env of Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]] @@ -300,7 +302,7 @@ matchPayload :: String -> String -> String -> Value matchPayload proto field val = matchExpr "==" (payloadVal proto field) (A.String (toText val)) -matchInSet :: Value -> [String] -> Value +matchInSet :: Value -> [Value] -> Value matchInSet lhs vals = matchExpr "in" lhs (setVal vals) metaVal :: String -> Value @@ -313,7 +315,7 @@ payloadVal proto field = , "field" .= (field :: String) ]] -setVal :: [String] -> Value +setVal :: [Value] -> Value setVal vs = object ["set" .= toJSON vs] -- ─── Expression helpers ─────────────────────────────────────────────────────── @@ -332,6 +334,8 @@ mapField f = f -- Fix 3 (overlap): specific ct pattern first, generic 2-element case second. exprVal :: CompileEnv -> Expr -> Value exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]] +exprVal _ (EQual ["meta", k])= metaVal k +exprVal _ (EQual ["th", k]) = payloadVal "th" k exprVal _ (EQual [p, f]) = payloadVal p (mapField f) exprVal _ (EQual ns) = A.String (toText (intercalate "." ns)) exprVal env (EVar n) @@ -343,8 +347,14 @@ exprVal env (EVar n) | n == "Established" = A.String "established" | n == "Related" = A.String "related" | otherwise = metaVal n +exprVal _ (ELit (LCIDR ip p)) = object + [ "prefix" .= object + [ "addr" .= A.String (toText (renderLit ip)) + , "len" .= p + ] + ] exprVal _ (ELit l) = A.String (toText (renderLit l)) -exprVal _ (ESet vs) = setVal (map exprToStr vs) +exprVal env (ESet vs) = setVal (map (exprVal env) vs) exprVal env (ETuple es) = object ["concat" .= toJSON (map (exprVal env) es)] exprVal _ e = A.String (toText (exprToStr e)) diff --git a/src/FWL/Parser.hs b/src/FWL/Parser.hs index 26e67e2..0db2f57 100644 --- a/src/FWL/Parser.hs +++ b/src/FWL/Parser.hs @@ -225,7 +225,12 @@ arm = do -- ─── Patterns ──────────────────────────────────────────────────────────────── pat :: Parser Pat -pat = wildcardPat +pat = Ex.buildExpressionParser patTable patAtom "pattern" + where + patTable = [ [Ex.Infix (reservedOp "|" >> return POr) Ex.AssocLeft] ] + +patAtom :: Parser Pat +patAtom = wildcardPat <|> try framePat <|> try tuplePat <|> bytesPat diff --git a/src/FWL/Pretty.hs b/src/FWL/Pretty.hs index 790309e..3cd7f3f 100644 --- a/src/FWL/Pretty.hs +++ b/src/FWL/Pretty.hs @@ -82,6 +82,7 @@ prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")" prettyPat (PFrame mp inner)= "Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")" prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]" +prettyPat (POr p1 p2) = prettyPat p1 ++ " | " ++ prettyPat p2 prettyFP :: FieldPat -> String prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l