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:
@@ -3,6 +3,11 @@
|
||||
All policies (Filter and NAT) go into one table named by Config.
|
||||
Layer stripping: Frame patterns that omit Ether compile identically
|
||||
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
|
||||
( compileProgram
|
||||
@@ -11,6 +16,8 @@ module FWL.Compile
|
||||
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Word (Word32)
|
||||
import Numeric (showHex)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Aeson ((.=), Value(..), object, toJSON)
|
||||
import qualified Data.Aeson as A
|
||||
@@ -29,12 +36,44 @@ compileToJson = encodePretty . programToValue
|
||||
compileProgram :: Program -> Value
|
||||
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 cfg decls) =
|
||||
object [ "nftables" .= toJSON
|
||||
(metainfo : tableObj : allObjects) ]
|
||||
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
|
||||
|
||||
metainfo = object [ "metainfo" .= object
|
||||
@@ -44,21 +83,32 @@ programToValue (Program cfg decls) =
|
||||
policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
|
||||
portfwds = [ d | d@(DPortForward {}) <- 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)
|
||||
|
||||
-- Chain declarations: policy chains + synthesised NAT chains
|
||||
-- ── Chain declarations ──────────────────────────────────────────────
|
||||
policyChainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies
|
||||
pfChainObjs = concatMap (portfwdChainValue tbl) portfwds
|
||||
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
|
||||
(\(n, pm, ab) ->
|
||||
injectFilterRules env tbl n pm hasPortFwd ++
|
||||
concatMap (armToRuleValues env tbl n) ab)
|
||||
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
|
||||
masqRuleObjs = concatMap (masqRuleValues env tbl) masqs
|
||||
-- Phase 4: synthesise _track chain rules
|
||||
flowTrackRules = concatMap (flowTrackRuleValues tbl ctMarks) flows
|
||||
|
||||
-- Sets / maps from let-bindings
|
||||
letDecls = [ (n, t, e) | DLet n t e <- decls ]
|
||||
@@ -68,13 +118,159 @@ programToValue (Program cfg decls) =
|
||||
pfMapObjs = concatMap (portfwdMapValue tbl) portfwds
|
||||
|
||||
allObjects = policyChainObjs ++ pfChainObjs ++ masqChainObjs
|
||||
++ ruleChainObjs -- Phase 1
|
||||
++ flowTimeoutObjs ++ flowChainObjs -- Phase 4
|
||||
++ pfMapObjs ++ mapObjs
|
||||
++ 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 ─────────────────────────────────────
|
||||
|
||||
-- | 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 =
|
||||
case pmHook pm of
|
||||
HInput -> [statefulRule, loopbackRule, ndpRule]
|
||||
@@ -102,8 +298,7 @@ injectFilterRules env tbl chain pm hasPortFwd =
|
||||
(A.String "dnat")
|
||||
, object ["accept" .= Null]
|
||||
]
|
||||
-- silence unused env warning
|
||||
_ = env
|
||||
_ = env -- silence unused warning
|
||||
|
||||
ruleValue :: String -> String -> [Value] -> Value
|
||||
ruleValue tbl chain exprs = object
|
||||
@@ -147,7 +342,7 @@ portfwdChainValue tbl (DPortForward n _ _ _) =
|
||||
]
|
||||
portfwdChainValue _ _ = []
|
||||
|
||||
portfwdRuleValues :: CompileEnv -> String -> Decl -> [Value]
|
||||
portfwdRuleValues :: Env -> String -> Decl -> [Value]
|
||||
portfwdRuleValues _ tbl (DPortForward n _ _ _) =
|
||||
let chainName = n ++ "_prerouting"
|
||||
in [ ruleValue tbl chainName
|
||||
@@ -187,7 +382,7 @@ masqChainValue tbl (DMasquerade n _ _) =
|
||||
]
|
||||
masqChainValue _ _ = []
|
||||
|
||||
masqRuleValues :: CompileEnv -> String -> Decl -> [Value]
|
||||
masqRuleValues :: Env -> String -> Decl -> [Value]
|
||||
masqRuleValues _ tbl (DMasquerade n iface srcSet) =
|
||||
let chainName = n ++ "_postrouting"
|
||||
in [ ruleValue tbl chainName
|
||||
@@ -243,11 +438,12 @@ defaultPolicyStr _ = "accept"
|
||||
|
||||
-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
|
||||
|
||||
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value]
|
||||
armToRuleValues :: Env -> String -> Name -> Arm -> [Value]
|
||||
armToRuleValues env tbl chain (Arm p mg body) =
|
||||
-- Phase 2: compileAction returns Maybe [Value]
|
||||
case compileAction env body of
|
||||
Nothing -> []
|
||||
Just verdict ->
|
||||
Just verdicts ->
|
||||
let patExprsAlts = compilePat env p
|
||||
guardExprs = maybe [] (compileGuard env) mg
|
||||
in [ object
|
||||
@@ -255,30 +451,21 @@ armToRuleValues env tbl chain (Arm p mg body) =
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "chain" .= chain
|
||||
, "expr" .= toJSON (patExprs ++ guardExprs ++ [verdict])
|
||||
, "expr" .= toJSON (patExprs ++ guardExprs ++ verdicts)
|
||||
]
|
||||
]
|
||||
| patExprs <- patExprsAlts ]
|
||||
|
||||
-- ─── 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
|
||||
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 (DPortForward n _ _ _) = n
|
||||
declNameOf (DMasquerade n _ _) = n
|
||||
-- Convenience accessor
|
||||
declEnv :: Env -> CompileEnv
|
||||
declEnv = envDecls
|
||||
|
||||
compilePat :: CompileEnv -> Pat -> [[Value]]
|
||||
compilePat :: Env -> Pat -> [[Value]]
|
||||
compilePat _ PWild = [[]]
|
||||
compilePat _ (PVar _) = [[]]
|
||||
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 env (POr p1 p2) = compilePat env p1 ++ compilePat env p2
|
||||
|
||||
expandNamedPat :: CompileEnv -> Name -> [[Value]]
|
||||
expandNamedPat :: Env -> Name -> [[Value]]
|
||||
expandNamedPat env n =
|
||||
case Map.lookup n env of
|
||||
case Map.lookup n (declEnv env) of
|
||||
Just (DPattern _ _ p) -> compilePat env p
|
||||
_ -> []
|
||||
|
||||
compileCtorPat :: CompileEnv -> String -> [Pat] -> [[Value]]
|
||||
compileCtorPat :: Env -> String -> [Pat] -> [[Value]]
|
||||
compileCtorPat env ctor ps = case ctor of
|
||||
"Ether" -> 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 _ = Nothing
|
||||
|
||||
compilePathPat :: CompileEnv -> PathPat -> [[Value]]
|
||||
compilePathPat :: Env -> PathPat -> [[Value]]
|
||||
compilePathPat env (PathPat ms md) =
|
||||
[ maybe [] (compileEndpoint env "iifname") ms ++
|
||||
maybe [] (compileEndpoint env "oifname") md ]
|
||||
|
||||
compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value]
|
||||
compileEndpoint :: Env -> String -> EndpointPat -> [Value]
|
||||
compileEndpoint _ _ EPWild = []
|
||||
compileEndpoint _ dir (EPName n) = [matchMeta dir n]
|
||||
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)]
|
||||
_ -> [matchInSet (metaVal dir) [A.String (toText z)]]
|
||||
|
||||
-- ─── 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 OpIn l r) = [compileInExpr env l 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 _ _ = []
|
||||
|
||||
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 :: Env -> Expr -> Expr -> Value
|
||||
compileInExpr env (EQual ["ct", "state"]) (ESet vs) =
|
||||
matchExpr "in" (object ["ct" .= object ["key" .= ("state" :: String)]]) (toJSON (map (exprVal env) vs))
|
||||
compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
|
||||
@@ -349,29 +534,82 @@ compileInExpr env (EQual ["ct", "status"]) (ESet vs) =
|
||||
compileInExpr env l (ESet vs) =
|
||||
matchExpr "==" (exprVal env l) (setVal (map (exprVal env) vs))
|
||||
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))
|
||||
compileInExpr env l 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 _ (EVar "Allow") = Just (object ["accept" .= Null])
|
||||
compileAction _ (EVar "Drop") = Just (object ["drop" .= Null])
|
||||
compileAction :: Env -> Expr -> Maybe [Value]
|
||||
-- Simple verdicts
|
||||
compileAction _ (EVar "Allow") = Just [object ["accept" .= Null]]
|
||||
compileAction _ (EVar "Drop") = Just [object ["drop" .= Null]]
|
||||
compileAction _ (EVar "Continue") = Nothing
|
||||
compileAction _ (EVar "Masquerade") = Just (object ["masquerade" .= Null])
|
||||
compileAction _ (EVar "Masquerade") = Just [object ["masquerade" .= Null]]
|
||||
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])) =
|
||||
Just $ object ["dnat" .= object ["addr" .= object
|
||||
Just [object ["dnat" .= object ["addr" .= object
|
||||
[ "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) _) =
|
||||
case Map.lookup rn env of
|
||||
Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
|
||||
_ -> Just (object ["accept" .= Null])
|
||||
compileAction _ _ = Just (object ["accept" .= Null])
|
||||
case Map.lookup rn (declEnv env) of
|
||||
Just (DRule _ _ _) -> Just [object ["jump" .= object ["target" .= rn]]]
|
||||
_ -> 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 tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
|
||||
@@ -441,7 +679,6 @@ 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
|
||||
@@ -482,8 +719,8 @@ setVal vs = object ["set" .= toJSON vs]
|
||||
|
||||
-- ─── Expression helpers ───────────────────────────────────────────────────────
|
||||
|
||||
isSetOrMapRef :: CompileEnv -> Name -> Bool
|
||||
isSetOrMapRef env n = case Map.lookup n env of
|
||||
isSetOrMapRef :: Env -> Name -> Bool
|
||||
isSetOrMapRef env n = case Map.lookup n (declEnv env) of
|
||||
Just (DLet _ _ _) -> True
|
||||
Just (DImport _ _ _) -> True
|
||||
_ -> False
|
||||
@@ -493,17 +730,16 @@ mapField "src" = "saddr"
|
||||
mapField "dst" = "daddr"
|
||||
mapField f = f
|
||||
|
||||
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
|
||||
exprVal :: CompileEnv -> Expr -> Value
|
||||
exprVal :: Env -> 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 ["ip6", "protocol"]) = metaVal "l4proto" -- nexthdr alias via l4proto
|
||||
exprVal _ (EQual ["ip6", "protocol"]) = metaVal "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)
|
||||
| Just (DInterface _ _ _) <- Map.lookup n (declEnv env) = A.String (toText n)
|
||||
| isSetOrMapRef env n = A.String ("@" <> toText n)
|
||||
| n == "iif" = metaVal "iifname"
|
||||
| n == "oif" = metaVal "oifname"
|
||||
@@ -533,9 +769,6 @@ exprToStr (EQual ns) = intercalate "." ns
|
||||
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
|
||||
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 = T.pack
|
||||
|
||||
@@ -553,3 +786,11 @@ renderLit (LDuration n Millis) = show n ++ "ms"
|
||||
renderLit (LDuration n Minutes) = show n ++ "m"
|
||||
renderLit (LDuration n Hours) = show n ++ "h"
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user