Phase 1+2: DRule regular chains + compileAction returns [Value]

- compileAction now returns Maybe [Value] (single-element lists for all
  existing verdicts); armToRuleValues updated accordingly
- programToValue emits one regular chain declaration per DRule (no
  hook/type/prio/policy fields), placed after policy chains
- CompileEnv promoted to a record (Env) carrying envDecls and a stub
  envCtMarks field (populated in Phase 4)
- All callers of compileAction threaded through new Env type
This commit is contained in:
2026-05-04 21:50:42 -07:00
parent e584d9ac2d
commit 8b5191c8bf

View File

@@ -3,6 +3,11 @@
All policies (Filter and NAT) go into one table named by Config. All policies (Filter and NAT) go into one table named by Config.
Layer stripping: Frame patterns that omit Ether compile identically Layer stripping: Frame patterns that omit Ether compile identically
to those that include it. to those that include it.
Phase 1: DRule declarations compile to regular (no-hook) chains.
Phase 2: compileAction returns Maybe [Value] to support multi-step arms.
Phase 3: Log.emit -> {"log": ...} effect statement.
Phase 4: DFlow declarations -> ct mark state machines (_track chains).
-} -}
module FWL.Compile module FWL.Compile
( compileProgram ( compileProgram
@@ -11,6 +16,8 @@ module FWL.Compile
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Word (Word32)
import Numeric (showHex)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Aeson ((.=), Value(..), object, toJSON) import Data.Aeson ((.=), Value(..), object, toJSON)
import qualified Data.Aeson as A import qualified Data.Aeson as A
@@ -29,12 +36,44 @@ compileToJson = encodePretty . programToValue
compileProgram :: Program -> Value compileProgram :: Program -> Value
compileProgram = programToValue compileProgram = programToValue
-- ─── Compile environment ─────────────────────────────────────────────────────
-- | Per-compile environment threaded through all helpers.
data Env = Env
{ envDecls :: Map.Map String Decl
-- ^ all top-level declarations, keyed by name
, envCtMarks :: Map.Map String (Word32, Word32)
-- ^ flow-name -> (inProgress mark, confirmed mark)
-- populated in Phase 4; empty for Phases 1-3
}
buildEnv :: [Decl] -> Env
buildEnv decls = Env
{ envDecls = Map.fromList [ (declNameOf d, d) | d <- decls ]
, envCtMarks = 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 (DPortForward n _ _ _) = n
declNameOf (DMasquerade n _ _) = n
-- ─── Top-level program ───────────────────────────────────────────────────────
programToValue :: Program -> Value programToValue :: Program -> Value
programToValue (Program cfg decls) = programToValue (Program cfg decls) =
object [ "nftables" .= toJSON object [ "nftables" .= toJSON
(metainfo : tableObj : allObjects) ] (metainfo : tableObj : allObjects) ]
where where
env = buildEnv decls -- Phase 4: allocate ct marks for all DFlow declarations
ctMarks = allocateCtMarks cfg decls
env = (buildEnv decls) { envCtMarks = ctMarks }
tbl = configTable cfg tbl = configTable cfg
metainfo = object [ "metainfo" .= object metainfo = object [ "metainfo" .= object
@@ -44,21 +83,32 @@ programToValue (Program cfg decls) =
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ] policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
portfwds = [ d | d@(DPortForward {}) <- decls ] portfwds = [ d | d@(DPortForward {}) <- decls ]
masqs = [ d | d@(DMasquerade {}) <- decls ] masqs = [ d | d@(DMasquerade {}) <- decls ]
rules = [ (n, e) | DRule n _ e <- decls ] -- Phase 1
flows = [ (n, fe) | DFlow n fe <- decls ] -- Phase 4
hasPortFwd = not (null portfwds) hasPortFwd = not (null portfwds)
-- Chain declarations: policy chains + synthesised NAT chains -- ── Chain declarations ──────────────────────────────────────────────
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
masqChainObjs = concatMap (masqChainValue tbl) masqs masqChainObjs = concatMap (masqChainValue tbl) masqs
-- Phase 1: one regular chain per DRule
ruleChainObjs = map (\(n, _) -> regularChainValue tbl n) rules
-- Phase 4: one _track chain per DFlow + optional ct timeout objects
flowChainObjs = concatMap (flowTrackChainValue tbl ctMarks) flows
flowTimeoutObjs = concatMap (flowTimeoutValue tbl) flows
-- Rules: policy arms + implicit injections + synthesised NAT rules -- ── Rules ───────────────────────────────────────────────────────────
policyRuleObjs = concatMap policyRuleObjs = concatMap
(\(n, pm, ab) -> (\(n, pm, ab) ->
injectFilterRules env tbl n pm hasPortFwd ++ injectFilterRules env tbl n pm hasPortFwd ++
concatMap (armToRuleValues env tbl n) ab) concatMap (armToRuleValues env tbl n) ab)
policies policies
-- Phase 1: compile the lambda body of each DRule into its chain
ruleRuleObjs = concatMap (\(n, e) -> ruleBodyToValues env tbl n e) rules
pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds pfRuleObjs = concatMap (portfwdRuleValues env tbl) portfwds
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
-- Phase 4: synthesise _track chain rules
flowTrackRules = concatMap (flowTrackRuleValues tbl ctMarks) flows
-- Sets / maps from let-bindings -- Sets / maps from let-bindings
letDecls = [ (n, t, e) | DLet n t e <- decls ] letDecls = [ (n, t, e) | DLet n t e <- decls ]
@@ -68,13 +118,159 @@ programToValue (Program cfg decls) =
pfMapObjs = concatMap (portfwdMapValue tbl) portfwds pfMapObjs = concatMap (portfwdMapValue tbl) portfwds
allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs
++ ruleChainObjs -- Phase 1
++ flowTimeoutObjs ++ flowChainObjs -- Phase 4
++ pfMapObjs ++ mapObjs ++ pfMapObjs ++ mapObjs
++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs ++ policyRuleObjs ++ pfRuleObjs ++ masqRuleObjs
++ ruleRuleObjs -- Phase 1
++ flowTrackRules -- Phase 4
-- ─── Phase 1: Regular chain declarations ─────────────────────────────────────
-- | Emit a *regular* chain (no type/hook/prio/policy) for a DRule.
regularChainValue :: String -> Name -> Value
regularChainValue tbl n = object
[ "chain" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= n
]
]
-- | Compile the body of a DRule (a lambda / case expression) into rules
-- belonging to the rule's own chain.
ruleBodyToValues :: Env -> String -> Name -> Expr -> [Value]
ruleBodyToValues env tbl chain expr =
case expr of
ELam _ body -> ruleBodyToValues env tbl chain body
ECase _ ab -> concatMap (armToRuleValues env tbl chain) ab
_ -> [] -- bare expressions are not yet compilable here
-- ─── Phase 4: ct mark allocation ─────────────────────────────────────────────
-- | Allocate (inProgress, confirmed) ct mark pairs for every DFlow decl.
-- Marks are in the range [prefix+1, prefix+2n] where prefix = 0xfee10000
-- (or the value from config { ct_mark_prefix = 0x????; }).
allocateCtMarks :: Config -> [Decl] -> Map.Map String (Word32, Word32)
allocateCtMarks cfg decls =
Map.fromList (zipWith mk flowNames [0..])
where
flowNames = [ n | DFlow n _ <- decls ]
base :: Word32
base = fromIntegral (configCtMarkPrefix cfg) `shiftL32` 16
mk n (i :: Word32) = (n, (base + 2*i + 1, base + 2*i + 2))
-- Portable left-shift for Word32 (avoids importing Data.Bits at top level)
shiftL32 :: Word32 -> Int -> Word32
shiftL32 w n = w * (2 ^ n)
-- ─── Phase 4: _track chain + rules ───────────────────────────────────────────
-- | Emit the regular _track chain declaration for a DFlow.
flowTrackChainValue :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackChainValue tbl _ctMarks (n, _) =
[ regularChainValue tbl (n ++ "_track") ]
-- | Emit the ct timeout object for a DFlow that has a `within` clause.
flowTimeoutValue :: String -> (Name, FlowExpr) -> [Value]
flowTimeoutValue tbl (n, fe) =
case withinDuration fe of
Nothing -> []
Just (secs, _) ->
[ object
[ "ct timeout" .= object
[ "family" .= ("inet" :: String)
, "table" .= tbl
, "name" .= (n ++ "_timeout")
, "protocol" .= ("udp" :: String)
, "state" .= object
[ "untracked" .= (show secs ++ "s" :: String) ]
]
]
]
where
withinDuration (FSeq _ _ (Just d)) = Just d
withinDuration (FSeq a b Nothing) =
case withinDuration a of
Just d -> Just d
Nothing -> withinDuration b
withinDuration _ = Nothing
-- | Synthesise the two tracking rules inside the _track chain.
-- Rule 1: ct mark 0 + init-pattern-match -> set mark to inProgress, return
-- Rule 2: ct mark inProgress + resp-match -> set mark to confirmed, return
flowTrackRuleValues :: String -> Map.Map String (Word32, Word32)
-> (Name, FlowExpr) -> [Value]
flowTrackRuleValues tbl ctMarks (n, fe) =
case Map.lookup n ctMarks of
Nothing -> []
Just (inProg, confirmed) ->
let chain = n ++ "_track"
(initAtom, respAtom) = flowAtoms fe
rule1 = ruleValue tbl chain $
[ ctMarkMatch "==" 0 ] ++
atomMatchExprs initAtom ++
[ ctMangleExpr inProg
, object ["return" .= Null]
]
rule2 = ruleValue tbl chain $
[ ctMarkMatch "==" inProg ] ++
atomMatchExprs respAtom ++
[ ctMangleExpr confirmed
, object ["return" .= Null]
]
in [rule1, rule2]
-- | Extract (init, response) atoms from a FlowExpr.
flowAtoms :: FlowExpr -> (Name, Name)
flowAtoms (FAtom n) = (n, n)
flowAtoms (FSeq (FAtom a) b _)= let (_, r) = flowAtoms b in (a, r)
flowAtoms (FSeq a _ _) = let (i, _) = flowAtoms a in (i, i)
-- | Pattern-match expressions for a known flow atom.
-- WGInitiation -> meta l4proto udp + @th,0,8 == 0x01
-- WGResponse -> meta l4proto udp + @th,0,8 == 0x02
atomMatchExprs :: Name -> [Value]
atomMatchExprs "WGInitiation" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 1
]
atomMatchExprs "WGResponse" =
[ matchMeta "l4proto" "udp"
, rawBitsMatch 0 8 2
]
atomMatchExprs _ = [] -- unknown atom: no-op (comment only in real impl)
-- | Match on @th,<offset>,<len> (raw transport-header bits).
rawBitsMatch :: Int -> Int -> Int -> Value
rawBitsMatch offset len val = matchExpr "=="
(object ["payload" .= object
[ "base" .= ("transport" :: String)
, "offset" .= offset
, "len" .= len
]])
(toJSON val)
-- | Match ct mark with operator and numeric value.
ctMarkMatch :: String -> Word32 -> Value
ctMarkMatch op val = matchExpr op
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON val)
-- | Mangle (set) ct mark to a value.
ctMangleExpr :: Word32 -> Value
ctMangleExpr val = object
[ "mangle" .= object
[ "key" .= object ["ct" .= object ["key" .= ("mark" :: String)]]
, "value" .= toJSON val
]
]
-- ─── Implicit filter-hook rule injection ───────────────────────────────────── -- ─── Implicit filter-hook rule injection ─────────────────────────────────────
-- | Prepend implicit rules for filter-hook chains (Input/Forward/Output). -- | Prepend implicit rules for filter-hook chains (Input/Forward/Output).
injectFilterRules :: CompileEnv -> String -> Name -> PolicyMeta -> Bool -> [Value] injectFilterRules :: Env -> String -> Name -> PolicyMeta -> Bool -> [Value]
injectFilterRules env tbl chain pm hasPortFwd = injectFilterRules env tbl chain pm hasPortFwd =
case pmHook pm of case pmHook pm of
HInput -> [statefulRule, loopbackRule, ndpRule] HInput -> [statefulRule, loopbackRule, ndpRule]
@@ -102,8 +298,7 @@ injectFilterRules env tbl chain pm hasPortFwd =
(A.String "dnat") (A.String "dnat")
, object ["accept" .= Null] , object ["accept" .= Null]
] ]
-- silence unused env warning _ = env -- silence unused warning
_ = env
ruleValue :: String -> String -> [Value] -> Value ruleValue :: String -> String -> [Value] -> Value
ruleValue tbl chain exprs = object ruleValue tbl chain exprs = object
@@ -147,7 +342,7 @@ portfwdChainValue tbl (DPortForward n _ _ _) =
] ]
portfwdChainValue _ _ = [] portfwdChainValue _ _ = []
portfwdRuleValues :: CompileEnv -> String -> Decl -> [Value] portfwdRuleValues :: Env -> String -> Decl -> [Value]
portfwdRuleValues _ tbl (DPortForward n _ _ _) = portfwdRuleValues _ tbl (DPortForward n _ _ _) =
let chainName = n ++ "_prerouting" let chainName = n ++ "_prerouting"
in [ ruleValue tbl chainName in [ ruleValue tbl chainName
@@ -187,7 +382,7 @@ masqChainValue tbl (DMasquerade n _ _) =
] ]
masqChainValue _ _ = [] masqChainValue _ _ = []
masqRuleValues :: CompileEnv -> String -> Decl -> [Value] masqRuleValues :: Env -> String -> Decl -> [Value]
masqRuleValues _ tbl (DMasquerade n iface srcSet) = masqRuleValues _ tbl (DMasquerade n iface srcSet) =
let chainName = n ++ "_postrouting" let chainName = n ++ "_postrouting"
in [ ruleValue tbl chainName in [ ruleValue tbl chainName
@@ -243,11 +438,12 @@ defaultPolicyStr _ = "accept"
-- ─── Arm → Rule objects ────────────────────────────────────────────────────── -- ─── Arm → Rule objects ──────────────────────────────────────────────────────
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value] armToRuleValues :: Env -> String -> Name -> Arm -> [Value]
armToRuleValues env tbl chain (Arm p mg body) = armToRuleValues env tbl chain (Arm p mg body) =
-- Phase 2: compileAction returns Maybe [Value]
case compileAction env body of case compileAction env body of
Nothing -> [] Nothing -> []
Just verdict -> Just verdicts ->
let patExprsAlts = compilePat env p let patExprsAlts = compilePat env p
guardExprs = maybe [] (compileGuard env) mg guardExprs = maybe [] (compileGuard env) mg
in [ object in [ object
@@ -255,30 +451,21 @@ armToRuleValues env tbl chain (Arm p mg body) =
[ "family" .= ("inet" :: String) [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "chain" .= chain , "chain" .= chain
, "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict]) , "expr" .= toJSON (patExprs ++ guardExprs ++ verdicts)
] ]
] ]
| patExprs <- patExprsAlts ] | patExprs <- patExprsAlts ]
-- ─── Pattern → [Value] ─────────────────────────────────────────────────────── -- ─── Pattern → [Value] ───────────────────────────────────────────────────────
type CompileEnv = Map.Map String Decl type CompileEnv = Map.Map String Decl -- kept for internal helpers that only
-- need the decl map
buildEnv :: [Decl] -> CompileEnv -- Convenience accessor
buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty declEnv :: Env -> CompileEnv
where declEnv = envDecls
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 :: Env -> Pat -> [[Value]]
compilePat _ PWild = [[]] compilePat _ PWild = [[]]
compilePat _ (PVar _) = [[]] compilePat _ (PVar _) = [[]]
compilePat env (PNamed n) = expandNamedPat env n compilePat env (PNamed n) = expandNamedPat env n
@@ -292,13 +479,13 @@ compilePat env (PTuple ps) = map concat (sequence (map (compilePat env) ps
compilePat _ (PBytes _) = [[]] compilePat _ (PBytes _) = [[]]
compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2 compilePat env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
expandNamedPat :: CompileEnv -> Name -> [[Value]] expandNamedPat :: Env -> Name -> [[Value]]
expandNamedPat env n = expandNamedPat env n =
case Map.lookup n env of case Map.lookup n (declEnv env) of
Just (DPattern _ _ p) -> compilePat env p Just (DPattern _ _ p) -> compilePat env p
_ -> [] _ -> []
compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]] compileCtorPat :: Env -> String -> [Pat] -> [[Value]]
compileCtorPat env ctor ps = case ctor of compileCtorPat env ctor ps = case ctor of
"Ether" -> children "Ether" -> children
"IPv4" -> map (matchMeta "nfproto" "ipv4" :) children "IPv4" -> map (matchMeta "nfproto" "ipv4" :) children
@@ -317,31 +504,29 @@ compileRecordPat proto fs = [mapMaybe go fs]
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit)) go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
go _ = Nothing go _ = Nothing
compilePathPat :: CompileEnv -> PathPat -> [[Value]] compilePathPat :: Env -> PathPat -> [[Value]]
compilePathPat env (PathPat ms md) = compilePathPat env (PathPat ms md) =
[ maybe [] (compileEndpoint env "iifname") ms ++ [ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint env "oifname") md ] maybe [] (compileEndpoint env "oifname") md ]
compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value] compileEndpoint :: Env -> String -> EndpointPat -> [Value]
compileEndpoint _ _ EPWild = [] compileEndpoint _ _ EPWild = []
compileEndpoint _ dir (EPName n) = [matchMeta dir n] compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint env dir (EPMember _ z) = compileEndpoint env dir (EPMember _ z) =
case Map.lookup z env of case Map.lookup z (declEnv env) of
Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)] Just (DZone _ ns) -> [matchInSet (metaVal dir) (map (A.String . toText) ns)]
_ -> [matchInSet (metaVal dir) [A.String (toText z)]] _ -> [matchInSet (metaVal dir) [A.String (toText z)]]
-- ─── Guard → [Value] ───────────────────────────────────────────────────────── -- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: CompileEnv -> Expr -> [Value] compileGuard :: Env -> Expr -> [Value]
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
compileGuard env (EInfix OpIn l r) = [compileInExpr env l r] compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)] compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)] compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
compileGuard _ _ = [] compileGuard _ _ = []
compileInExpr :: CompileEnv -> Expr -> Expr -> Value compileInExpr :: Env -> 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 env (EQual ["ct", "state"]) (ESet vs) = compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs)) matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
compileInExpr env (EQual ["ct", "status"]) (ESet vs) = compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
@@ -349,29 +534,82 @@ compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
compileInExpr env l (ESet vs) = compileInExpr env l (ESet vs) =
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs)) matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
compileInExpr env l (EVar z) compileInExpr env l (EVar z)
| Just (DZone _ ns) <- Map.lookup z env = | Just (DZone _ ns) <- Map.lookup z (declEnv env) =
matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns)) matchExpr "==" (exprVal env l) (setVal (map (A.String . toText) ns))
compileInExpr env l r = compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r) matchExpr "==" (exprVal env l) (exprVal env r)
-- ─── Action → Maybe Value ───────────────────────────────────────────────────── -- ─── Action → Maybe [Value] (Phase 2) ───────────────────────────────────────
--
-- Returns Nothing for Continue (arm is silently dropped).
-- Returns Just [..] for everything else.
-- Single-verdict arms return a one-element list.
-- Multi-step do-block arms return a multi-element list.
compileAction :: CompileEnv -> Expr -> Maybe Value compileAction :: Env -> Expr -> Maybe [Value]
compileAction _ (EVar "Allow") = Just (object ["accept" .= Null]) -- Simple verdicts
compileAction _ (EVar "Drop") = Just (object ["drop" .= Null]) compileAction _ (EVar "Allow") = Just [object ["accept" .= Null]]
compileAction _ (EVar "Drop") = Just [object ["drop" .= Null]]
compileAction _ (EVar "Continue") = Nothing compileAction _ (EVar "Continue") = Nothing
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null]) compileAction _ (EVar "Masquerade") = Just [object ["masquerade" .= Null]]
compileAction _ (EApp (EVar "DNAT") arg) = compileAction _ (EApp (EVar "DNAT") arg) =
Just $ object ["dnat" .= object ["addr" .= exprToStr arg]] Just [object ["dnat" .= object ["addr" .= exprToStr arg]]]
compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) = compileAction env (EApp (EVar "DNATMap") (ETuple [key, arg])) =
Just $ object ["dnat" .= object ["addr" .= object Just [object ["dnat" .= object ["addr" .= object
[ "map" .= object [ "key" .= exprVal env key [ "map" .= object [ "key" .= exprVal env key
, "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]] , "data" .= A.String ("@" <> toText (exprToStr arg)) ]]]]]
-- Phase 1: rule call -> jump
compileAction env (EApp (EVar rn) _) = compileAction env (EApp (EVar rn) _) =
case Map.lookup rn env of case Map.lookup rn (declEnv env) of
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]] Just (DRule _ _ _) -> Just [object ["jump" .= object ["target" .= rn]]]
_ -> Just (object ["accept" .= Null]) _ -> Just [object ["accept" .= Null]]
compileAction _ _ = Just (object ["accept" .= Null]) -- Phase 3: Log.emit effect
compileAction env (EPerform ["Log", "emit"] [levelExpr, msgExpr]) =
let lvl = case levelExpr of
EVar "Warn" -> "warn"
EVar "Info" -> "info"
EVar "Debug" -> "debug"
_ -> "warn"
msg = case msgExpr of
ELit (LString s) -> s
_ -> exprToStr msgExpr
logStmt = object ["log" .= object
[ "prefix" .= A.String (toText msg)
, "level" .= A.String (toText lvl)
]]
in Just [logStmt] -- single statement; do-block handles sequencing
compileAction _ (EPerform ["Log", "emit"] _) =
Just [object ["log" .= object ["prefix" .= A.String ""]]]
-- Phase 4: FlowMatch.check effect
compileAction env (EPerform ["FlowMatch", "check"] (EVar flowName : _)) =
case Map.lookup flowName (envCtMarks env) of
Just (_inProg, confirmed) ->
Just
[ object ["jump" .= object ["target" .= (flowName ++ "_track")]]
, matchExpr "=="
(object ["ct" .= object ["key" .= ("mark" :: String)]])
(toJSON confirmed)
]
Nothing ->
-- flow not found; emit jump only
Just [object ["jump" .= object ["target" .= (flowName ++ "_track")]]]
compileAction _ (EPerform ["FlowMatch", "check"] _) =
Just [object ["accept" .= Null]]
-- do-block: sequence statements, collecting all effects + final verdict
compileAction env (EDo stmts) = compileDo env stmts
-- Fallback
compileAction _ _ = Just [object ["accept" .= Null]]
-- | Compile a do-block: each DSExpr is compiled and its [Value] contributions
-- are concatenated in order. DSBind is ignored for now.
compileDo :: Env -> [DoStmt] -> Maybe [Value]
compileDo _ [] = Nothing
compileDo env stmts =
let results = concatMap compileStmt stmts
in if null results then Nothing else Just results
where
compileStmt (DSBind _ e) = maybe [] id (compileAction env e)
compileStmt (DSExpr e) = maybe [] id (compileAction env e)
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
@@ -441,7 +679,6 @@ renderMapElem (k, v) = toJSON
renderSetElem :: Expr -> Value renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey renderSetElem = renderMapOrSetKey
-- | True if an expression is a CIDR literal (requires 'interval' flag in nftables set)
isCidrElem :: Expr -> Bool isCidrElem :: Expr -> Bool
isCidrElem (ELit (LCIDR _ _)) = True isCidrElem (ELit (LCIDR _ _)) = True
isCidrElem _ = False isCidrElem _ = False
@@ -482,8 +719,8 @@ setVal vs = object ["set" .= toJSON vs]
-- ─── Expression helpers ─────────────────────────────────────────────────────── -- ─── Expression helpers ───────────────────────────────────────────────────────
isSetOrMapRef :: CompileEnv -> Name -> Bool isSetOrMapRef :: Env -> Name -> Bool
isSetOrMapRef env n = case Map.lookup n env of isSetOrMapRef env n = case Map.lookup n (declEnv env) of
Just (DLet _ _ _) -> True Just (DLet _ _ _) -> True
Just (DImport _ _ _) -> True Just (DImport _ _ _) -> True
_ -> False _ -> False
@@ -493,17 +730,16 @@ mapField "src" = "saddr"
mapField "dst" = "daddr" mapField "dst" = "daddr"
mapField f = f mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second. exprVal :: Env -> Expr -> Value
exprVal :: CompileEnv -> Expr -> Value
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]] 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 ["th", k]) = payloadVal "th" k
exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto" -- nexthdr alias via l4proto exprVal _ (EQual ["ip6", "protocol"]) = metaVal "l4proto"
exprVal _ (EQual ["ip", "protocol"]) = metaVal "l4proto" exprVal _ (EQual ["ip", "protocol"]) = metaVal "l4proto"
exprVal _ (EQual [p, f]) = payloadVal p (mapField f) exprVal _ (EQual [p, f]) = payloadVal p (mapField f)
exprVal _ (EQual ns) = A.String (toText (intercalate "." ns)) exprVal _ (EQual ns) = A.String (toText (intercalate "." ns))
exprVal env (EVar n) exprVal env (EVar n)
| Just (DInterface _ _ _) <- Map.lookup n env = A.String (toText n) | Just (DInterface _ _ _) <- Map.lookup n (declEnv env) = A.String (toText n)
| isSetOrMapRef env n = A.String ("@" <> toText n) | isSetOrMapRef env n = A.String ("@" <> toText n)
| n == "iif" = metaVal "iifname" | n == "iif" = metaVal "iifname"
| n == "oif" = metaVal "oifname" | n == "oif" = metaVal "oifname"
@@ -533,9 +769,6 @@ exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es) exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
exprToStr _ = "_" exprToStr _ = "_"
-- Fix 2: Use Data.Text.pack via OverloadedStrings + fromString instead of
-- the fragile read(show s) hack. With OverloadedStrings enabled, string
-- literals already produce the correct Text/Key types; for runtime String
toText :: String -> T.Text toText :: String -> T.Text
toText = T.pack toText = T.pack
@@ -553,3 +786,11 @@ renderLit (LDuration n Millis) = show n ++ "ms"
renderLit (LDuration n Minutes) = show n ++ "m" renderLit (LDuration n Minutes) = show n ++ "m"
renderLit (LDuration n Hours) = show n ++ "h" renderLit (LDuration n Hours) = show n ++ "h"
renderLit (LHex b) = show b renderLit (LHex b) = show b
-- ─── Hex rendering helper (for ct mark values in comments) ───────────────────
hex32 :: Word32 -> String
hex32 w = "0x" ++ showHex w ""
-- silence unused warning for hex32 (used in potential debug output)
_ = hex32