gemini fixes nft json compilation
This commit is contained in:
@@ -48,7 +48,7 @@ programToValue (Program cfg decls) =
|
||||
policies
|
||||
|
||||
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 ──────────────────────────────────────────────
|
||||
|
||||
@@ -149,8 +149,8 @@ compileCtorPat env ctor ps = case ctor of
|
||||
"Ether" -> children
|
||||
"IPv4" -> matchMeta "nfproto" "ipv4" : children
|
||||
"IPv6" -> matchMeta "nfproto" "ipv6" : children
|
||||
"TCP" -> matchPayload "th" "protocol" "tcp" : children
|
||||
"UDP" -> matchPayload "th" "protocol" "udp" : children
|
||||
"TCP" -> matchMeta "l4proto" "tcp" : children
|
||||
"UDP" -> matchMeta "l4proto" "udp" : children
|
||||
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
|
||||
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children
|
||||
_ -> children
|
||||
@@ -164,33 +164,39 @@ compileRecordPat proto = mapMaybe go
|
||||
go _ = Nothing
|
||||
|
||||
compilePathPat :: CompileEnv -> PathPat -> [Value]
|
||||
compilePathPat _ (PathPat ms md) =
|
||||
maybe [] (compileEndpoint "iifname") ms ++
|
||||
maybe [] (compileEndpoint "oifname") md
|
||||
compilePathPat env (PathPat ms md) =
|
||||
maybe [] (compileEndpoint env "iifname") ms ++
|
||||
maybe [] (compileEndpoint env "oifname") md
|
||||
|
||||
compileEndpoint :: String -> EndpointPat -> [Value]
|
||||
compileEndpoint _ EPWild = []
|
||||
compileEndpoint dir (EPName n) = [matchMeta dir n]
|
||||
compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]]
|
||||
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]]
|
||||
|
||||
-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
|
||||
|
||||
compileGuard :: CompileEnv -> Expr -> [Value]
|
||||
compileGuard env (EInfix OpAnd l r) = compileGuard env l ++ compileGuard env r
|
||||
compileGuard _ (EInfix OpIn l r) = [compileInExpr l r]
|
||||
compileGuard _ (EInfix OpEq l r) = [matchExpr "==" (exprVal l) (exprVal r)]
|
||||
compileGuard _ (EInfix OpNeq l r) = [matchExpr "!=" (exprVal l) (exprVal 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 :: Expr -> Expr -> Value
|
||||
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 l (ESet vs) =
|
||||
matchExpr "in" (exprVal l) (setVal (map exprToStr vs))
|
||||
compileInExpr l r =
|
||||
matchExpr "==" (exprVal l) (exprVal r)
|
||||
compileInExpr _ (EQual ["ct", "state"]) (ESet vs) = ctMatch "state" vs
|
||||
compileInExpr _ (EQual ["ct", "status"]) (ESet vs) = ctMatch "status" vs
|
||||
compileInExpr env l (ESet vs) =
|
||||
matchExpr "in" (exprVal env l) (setVal (map exprToStr vs))
|
||||
compileInExpr env l (EVar z)
|
||||
| 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 key vs = matchExpr "in"
|
||||
@@ -216,27 +222,66 @@ compileAction env (EApp (EVar rn) _) =
|
||||
_ -> Just (object ["accept" .= Null])
|
||||
compileAction _ _ = Just (object ["accept" .= Null])
|
||||
|
||||
-- ─── Let → Map object ────────────────────────────────────────────────────────
|
||||
|
||||
letToMapValue :: String -> Name -> Expr -> Maybe Value
|
||||
letToMapValue tbl n (EMap entries) = Just $ object
|
||||
letToSetOrMapValue :: String -> Name -> Type -> Expr -> Maybe Value
|
||||
letToSetOrMapValue tbl n (TName "Map" [tk, tv]) (EMap entries) = Just $ object
|
||||
[ "map" .= object
|
||||
[ "family" .= ("inet" :: String)
|
||||
, "table" .= tbl
|
||||
, "name" .= n
|
||||
, "type" .= ("inetproto . inetservice" :: String)
|
||||
, "map" .= ("ipv4_addr . inetservice" :: String)
|
||||
, "type" .= renderNftType (fwlTypeToNft tk)
|
||||
, "map" .= renderNftType (fwlTypeToNft tv)
|
||||
, "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 (k, v) = toJSON
|
||||
[ object ["concat" .= toJSON [exprToStr k]]
|
||||
, A.String (toText (exprToStr v))
|
||||
[ renderMapOrSetKey k
|
||||
, renderMapOrSetKey v
|
||||
]
|
||||
|
||||
renderSetElem :: Expr -> Value
|
||||
renderSetElem = renderMapOrSetKey
|
||||
|
||||
-- ─── Aeson building blocks ───────────────────────────────────────────────────
|
||||
|
||||
matchExpr :: String -> Value -> Value -> Value
|
||||
@@ -273,18 +318,42 @@ setVal vs = object ["set" .= toJSON vs]
|
||||
|
||||
-- ─── 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.
|
||||
exprVal :: Expr -> Value
|
||||
exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
|
||||
exprVal (EQual [p, f]) = payloadVal p f
|
||||
exprVal (EQual ns) = A.String (toText (intercalate "." ns))
|
||||
exprVal (EVar n) = metaVal n
|
||||
exprVal (ELit l) = A.String (toText (renderLit l))
|
||||
exprVal (ESet vs) = setVal (map exprToStr vs)
|
||||
exprVal e = A.String (toText (exprToStr e))
|
||||
exprVal :: CompileEnv -> Expr -> Value
|
||||
exprVal _ (EQual ["ct", k]) = object ["ct" .= object ["key" .= (k :: String)]]
|
||||
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)
|
||||
| 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 (EVar n) = n
|
||||
exprToStr (EVar n) = case n of
|
||||
"Established" -> "established"
|
||||
"Related" -> "related"
|
||||
"DNAT" -> "dnat"
|
||||
_ -> n
|
||||
exprToStr (ELit l) = renderLit l
|
||||
exprToStr (EQual ns) = intercalate "." ns
|
||||
exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
|
||||
|
||||
Reference in New Issue
Block a user