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

gemini fixes nft json compilation

Browse Source
This commit is contained in:
Yura
2026-05-03 19:01:02 -07:00
parent d01be7bc23
commit 8a508ad7cc
1 changed files with 107 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

145
src/FWL/Compile.hs
View File

@@ -48,7 +48,7 @@ programToValue (Program cfg decls) =
policies policies
letDecls = [ (n, t, e) | DLet n t e <- decls ] letDecls = [ (n, t, e) | DLet n t e <- decls ]
mapObjs = mapMaybe (\(n, _, e) -> letToMapValue tbl n e) letDecls mapObjs = mapMaybe (\(n, t, e) -> letToSetOrMapValue tbl n t e) letDecls
-- ─── Table / Chain declarations ────────────────────────────────────────────── -- ─── Table / Chain declarations ──────────────────────────────────────────────
@@ -149,8 +149,8 @@ compileCtorPat env ctor ps = case ctor of
"Ether" -> children "Ether" -> children
"IPv4" -> matchMeta "nfproto" "ipv4" : children "IPv4" -> matchMeta "nfproto" "ipv4" : children
"IPv6" -> matchMeta "nfproto" "ipv6" : children "IPv6" -> matchMeta "nfproto" "ipv6" : children
"TCP" -> matchPayload "th" "protocol" "tcp" : children "TCP" -> matchMeta "l4proto" "tcp" : children
"UDP" -> matchPayload "th" "protocol" "udp" : children "UDP" -> matchMeta "l4proto" "udp" : children
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children "ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children "ICMP" -> matchPayload "ip" "protocol" "icmp" : children
_ -> children _ -> children
@@ -164,33 +164,39 @@ compileRecordPat proto = mapMaybe go
go _ = Nothing go _ = Nothing
compilePathPat :: CompileEnv -> PathPat -> [Value] compilePathPat :: CompileEnv -> PathPat -> [Value]
compilePathPat _ (PathPat ms md) = compilePathPat env (PathPat ms md) =
maybe [] (compileEndpoint "iifname") ms ++ maybe [] (compileEndpoint env "iifname") ms ++
maybe [] (compileEndpoint "oifname") md maybe [] (compileEndpoint env "oifname") md
compileEndpoint :: String -> EndpointPat -> [Value] compileEndpoint :: CompileEnv -> String -> EndpointPat -> [Value]
compileEndpoint _ EPWild = [] compileEndpoint _ _ EPWild = []
compileEndpoint dir (EPName n) = [matchMeta dir n] compileEndpoint _ dir (EPName n) = [matchMeta dir n]
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]] compileEndpoint env dir (EPMember _ z) =
case Map.lookup z env of
Just (DZone _ ns) -> [matchInSet (metaVal dir) ns]
_ -> [matchInSet (metaVal dir) [z]]
-- ─── Guard → [Value] ───────────────────────────────────────────────────────── -- ─── Guard → [Value] ─────────────────────────────────────────────────────────
compileGuard :: CompileEnv -> Expr -> [Value] compileGuard :: CompileEnv -> 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 _ (EInfix OpIn l r) = [compileInExpr l r] compileGuard env (EInfix OpIn l r) = [compileInExpr env l r]
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)] compileGuard env (EInfix OpEq l r) = [matchExpr "==" (exprVal env l) (exprVal env r)]
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal r)] compileGuard env (EInfix OpNeq l r) = [matchExpr "!=" (exprVal env l) (exprVal env r)]
compileGuard _ _ = [] compileGuard _ _ = []
compileInExpr :: Expr -> Expr -> Value compileInExpr :: CompileEnv -> Expr -> Expr -> Value
-- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element -- Fix 4: put the more-specific ct patterns BEFORE the generic 2-element
-- EQual case to eliminate the overlapping pattern match warning. -- EQual case to eliminate the overlapping pattern match warning.
compileInExpr (EQual ["ct", "state"]) (ESet vs) = ctMatch "state" vs compileInExpr _ (EQual ["ct", "state"]) (ESet vs) = ctMatch "state" vs
compileInExpr (EQual ["ct", "status"]) (ESet vs) = ctMatch "status" vs compileInExpr _ (EQual ["ct", "status"]) (ESet vs) = ctMatch "status" vs
compileInExpr l (ESet vs) = compileInExpr env l (ESet vs) =
matchExpr "in" (exprVal l) (setVal (map exprToStr vs)) matchExpr "in" (exprVal env l) (setVal (map exprToStr vs))
compileInExpr l r = compileInExpr env l (EVar z)
matchExpr "==" (exprVal l) (exprVal r) | Just (DZone _ ns) <- Map.lookup z env =
matchExpr "in" (exprVal env l) (setVal ns)
compileInExpr env l r =
matchExpr "==" (exprVal env l) (exprVal env r)
ctMatch :: String -> [Expr] -> Value ctMatch :: String -> [Expr] -> Value
ctMatch key vs = matchExpr "in" ctMatch key vs = matchExpr "in"
@@ -216,27 +222,66 @@ compileAction env (EApp (EVar rn) _) =
_ -> Just (object ["accept" .= Null]) _ -> Just (object ["accept" .= Null])
compileAction _ _ = Just (object ["accept" .= Null]) compileAction _ _ = Just (object ["accept" .= Null])
-- ─── Let → Map object ──────────────────────────────────────────────────────── letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
letToMapValue :: String -> Name -> Expr -> Maybe Value
letToMapValue tbl n (EMap entries) = Just $ object
[ "map" .= object [ "map" .= object
[ "family" .= ("inet" :: String) [ "family" .= ("inet" :: String)
, "table" .= tbl , "table" .= tbl
, "name" .= n , "name" .= n
, "type" .= ("inetproto . inetservice" :: String) , "type" .= renderNftType (fwlTypeToNft tk)
, "map" .= ("ipv4_addr . inetservice" :: String) , "map" .= renderNftType (fwlTypeToNft tv)
, "elem" .= toJSON (map renderMapElem entries) , "elem" .= toJSON (map renderMapElem entries)
] ]
] ]
letToMapValue _ _ _ = Nothing 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)
]
]
letToSetOrMapValue _ _ _ _ = Nothing
fwlTypeToNft :: Type -> [String]
fwlTypeToNft (TName "Protocol" []) = ["inet_proto"]
fwlTypeToNft (TName "Port" []) = ["inet_service"]
fwlTypeToNft (TName "IP" []) = ["ipv4_addr"]
fwlTypeToNft (TName "IPv4" []) = ["ipv4_addr"]
fwlTypeToNft (TName "IPv6" []) = ["ipv6_addr"]
fwlTypeToNft (TTuple ts) = concatMap fwlTypeToNft ts
fwlTypeToNft _ = ["any"]
renderNftType :: [String] -> Value
renderNftType [t] = A.String (toText t)
renderNftType ts = toJSON ts
exprToVal :: Expr -> Value
exprToVal (ELit (LPort p)) = toJSON p
exprToVal (ELit (LInt n)) = toJSON n
exprToVal (ELit l) = A.String (toText (renderLit l))
exprToVal (EVar n) = A.String (toText n)
exprToVal (EQual ns) = A.String (toText (intercalate "." ns))
exprToVal _ = A.String "_"
exprToConcatList :: Expr -> [Value]
exprToConcatList (ETuple es) = concatMap exprToConcatList es
exprToConcatList e = [exprToVal e]
renderMapOrSetKey :: Expr -> Value
renderMapOrSetKey (ETuple es) = object ["concat" .= toJSON (exprToConcatList (ETuple es))]
renderMapOrSetKey e = exprToVal e
renderMapElem :: (Expr, Expr) -> Value renderMapElem :: (Expr, Expr) -> Value
renderMapElem (k, v) = toJSON renderMapElem (k, v) = toJSON
[ object ["concat" .= toJSON [exprToStr k]] [ renderMapOrSetKey k
, A.String (toText (exprToStr v)) , renderMapOrSetKey v
] ]
renderSetElem :: Expr -> Value
renderSetElem = renderMapOrSetKey
-- ─── Aeson building blocks ─────────────────────────────────────────────────── -- ─── Aeson building blocks ───────────────────────────────────────────────────
matchExpr :: String -> Value -> Value -> Value matchExpr :: String -> Value -> Value -> Value
@@ -273,18 +318,42 @@ setVal vs = object ["set" .= toJSON vs]
-- ─── Expression helpers ─────────────────────────────────────────────────────── -- ─── Expression helpers ───────────────────────────────────────────────────────
isSetOrMapRef :: CompileEnv -> Name -> Bool
isSetOrMapRef env n = case Map.lookup n env of
Just (DLet _ _ _) -> True
Just (DImport _ _ _) -> True
_ -> False
mapField :: String -> String
mapField "src" = "saddr"
mapField "dst" = "daddr"
mapField f = f
-- Fix 3 (overlap): specific ct pattern first, generic 2-element case second. -- Fix 3 (overlap): specific ct pattern first, generic 2-element case second.
exprVal :: 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 [p, f]) = payloadVal p 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 (EVar n) = metaVal n exprVal env (EVar n)
exprVal (ELit l) = A.String (toText (renderLit l)) | Just (DInterface _ _ _) <- Map.lookup n env = A.String (toText n)
exprVal (ESet vs) = setVal (map exprToStr vs) | isSetOrMapRef env n = A.String ("@" <> toText n)
exprVal e = A.String (toText (exprToStr e)) | n == "iif" = metaVal "iifname"
| n == "oif" = metaVal "oifname"
| n == "DNAT" = A.String "dnat"
| n == "Established" = A.String "established"
| n == "Related" = A.String "related"
| otherwise = metaVal n
exprVal _ (ELit l) = A.String (toText (renderLit l))
exprVal _ (ESet vs) = setVal (map exprToStr vs)
exprVal env (ETuple es) = object ["concat" .= toJSON (map (exprVal env) es)]
exprVal _ e = A.String (toText (exprToStr e))
exprToStr :: Expr -> String exprToStr :: Expr -> String
exprToStr (EVar n) = n exprToStr (EVar n) = case n of
"Established" -> "established"
"Related" -> "related"
"DNAT" -> "dnat"
_ -> n
exprToStr (ELit l) = renderLit l exprToStr (ELit l) = renderLit l
exprToStr (EQual ns) = intercalate "." ns exprToStr (EQual ns) = intercalate "." ns
exprToStr (ETuple es) = intercalate " . " (map exprToStr es) exprToStr (ETuple es) = intercalate " . " (map exprToStr es)