From 8a508ad7ccc5079cd081a8b4e7b337ecbb96f5fc Mon Sep 17 00:00:00 2001 From: Yuri Tatishchev Date: Sun, 3 May 2026 19:01:02 -0700 Subject: [PATCH] gemini fixes nft json compilation --- src/FWL/Compile.hs | 145 +++++++++++++++++++++++++++++++++------------ 1 file changed, 107 insertions(+), 38 deletions(-) diff --git a/src/FWL/Compile.hs b/src/FWL/Compile.hs index ad6033f..1ac9e74 100644 --- a/src/FWL/Compile.hs +++ b/src/FWL/Compile.hs @@ -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)