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

crazy mega refactor

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

20
src/FWL/AST.hs
View File

@@ -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

12
src/FWL/Check.hs
View File

@@ -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]

225
src/FWL/Compile.hs
View File

@@ -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)

3
src/FWL/Lexer.hs
View File

@@ -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"

71
src/FWL/Parser.hs
View File

@@ -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 <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

41
src/FWL/Pretty.hs
View File

@@ -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