diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..3aaf11b --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,57 @@ +module Main where + +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr) + +import FWL.Parser (parseFile) +import FWL.Pretty (prettyProgram) +import FWL.Check (checkProgram) +import FWL.Compile (compileToJson, compileProgram) + +main :: IO () +main = do + args <- getArgs + case args of + ["check", fp] -> runCheck fp + ["compile", fp] -> runCompile fp + ["pretty", fp] -> runPretty fp + _ -> do + putStrLn "Usage: fwlc " + putStrLn " check -- parse and static-check" + putStrLn " compile -- emit nftables JSON to stdout" + putStrLn " pretty -- parse and re-print" + exitFailure + +runCheck :: FilePath -> IO () +runCheck fp = do + result <- parseFile fp + case result of + Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure + Right prog -> do + let errs = checkProgram prog + if null errs + then putStrLn "OK" >> exitSuccess + else do + mapM_ (hPutStrLn stderr . show) errs + exitFailure + +runCompile :: FilePath -> IO () +runCompile fp = do + result <- parseFile fp + case result of + Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure + Right prog -> do + let errs = checkProgram prog + if null errs + then putStrLn (compileToJson prog) + else do + mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs + exitFailure + +runPretty :: FilePath -> IO () +runPretty fp = do + result <- parseFile fp + case result of + Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure + Right prog -> putStr (prettyProgram prog) diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..e6fdbad --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/fwl.cabal b/fwl.cabal new file mode 100644 index 0000000..8c03934 --- /dev/null +++ b/fwl.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.0 +name: fwl +version: 0.1.0.0 +synopsis: Firewall Language — MVP +build-type: Simple + +common shared + ghc-options: -Wall + default-language: Haskell2010 + +library + import: shared + hs-source-dirs: src + exposed-modules: + FWL.AST + , FWL.Lexer + , FWL.Parser + , FWL.Pretty + , FWL.Check + , FWL.Compile + build-depends: + base >= 4.14 + , parsec >= 3.1 + , aeson >= 2.0 + , aeson-pretty >= 0.8 + , text >= 1.2 + , containers >= 0.6 + , mtl >= 2.2 + , prettyprinter >= 1.7 + , bytestring >= 0.11 + , word8 >= 0.1 + +executable fwlc + import: shared + main-is: Main.hs + hs-source-dirs: app + build-depends: + base, fwl, text, aeson-pretty, bytestring diff --git a/src/FWL/AST.hs b/src/FWL/AST.hs new file mode 100644 index 0000000..6f18d0d --- /dev/null +++ b/src/FWL/AST.hs @@ -0,0 +1,160 @@ +module FWL.AST where + +import Data.Word (Word8, Word16) + +type Name = String + +-- ─── Program ──────────────────────────────────────────────────────────────── + +data Program = Program + { progConfig :: Config + , progDecls :: [Decl] + } deriving (Show) + +data Config = Config + { configTable :: String -- default "fwl" + } deriving (Show) + +defaultConfig :: Config +defaultConfig = Config { configTable = "fwl" } + +-- ─── Declarations ─────────────────────────────────────────────────────────── + +data Decl + = DInterface Name IfaceKind [IfaceProp] + | DZone Name [Name] + | DImport Name Type FilePath + | DLet Name Type Expr + | DPattern Name Type Pat + | DFlow Name FlowExpr + | DRule Name Type Expr -- body must be ELam + | DPolicy Name Type PolicyMeta ArmBlock + deriving (Show) + +data PolicyMeta = PolicyMeta + { pmHook :: Hook + , pmTable :: TableName + , pmPriority :: Priority + } deriving (Show) + +data Hook = HInput | HForward | HOutput | HPrerouting | HPostrouting + deriving (Show, Eq) +data TableName = TFilter | TNAT + deriving (Show, Eq) +data Priority = PFilter | PDstNat | PSrcNat | PMangle | PInt Int + deriving (Show, Eq) + +data IfaceKind = IWan | ILan | IWireGuard | IUser Name + deriving (Show) + +data IfaceProp + = IPDynamic + | IPCidr4 [CIDR] + | IPCidr6 [CIDR] + deriving (Show) + +-- ─── Patterns ─────────────────────────────────────────────────────────────── + +data Pat + = PWild + | PVar Name + | PNamed Name -- first-class named pattern ref + | PCtor Name [Pat] -- IPv4(ip, ...), TCP(tcp, ...) + | PRecord Name [FieldPat] -- udp { length = 156 } + | PTuple [Pat] + | PFrame (Maybe PathPat) Pat -- Frame(path?, inner) + | PBytes [ByteElem] + deriving (Show) + +data FieldPat + = FPEq Name Literal -- field = literal + | FPBind Name -- bind field to same-named var + | FPAs Name Name -- field as var + deriving (Show) + +data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat) + deriving (Show) + +data EndpointPat + = EPWild + | EPName Name + | EPMember Name Name -- iif `in` zone + deriving (Show) + +data ByteElem + = BEHex Word8 + | BEWild -- _ (one byte) + | BEWildStar -- _* (zero or more) + deriving (Show) + +-- ─── Flow ─────────────────────────────────────────────────────────────────── + +data FlowExpr + = FAtom Name + | FSeq FlowExpr FlowExpr (Maybe Duration) + deriving (Show) + +type Duration = (Int, TimeUnit) +data TimeUnit = Seconds | Millis | Minutes | Hours + deriving (Show) + +-- ─── Types ────────────────────────────────────────────────────────────────── + +data Type + = TName Name [Type] + | TTuple [Type] + | TFun Type Type + | TEffect [Name] Type + deriving (Show) + +-- ─── Expressions ──────────────────────────────────────────────────────────── + +data Expr + = EVar Name + | EQual [Name] -- qualified name, e.g. Log.emit + | ELit Literal + | ELam Name Expr + | EApp Expr Expr + | ECase Expr ArmBlock + | EIf Expr Expr Expr + | EDo [DoStmt] + | ELet Name Expr Expr + | ETuple [Expr] + | ESet [Expr] + | EMap [(Expr, Expr)] + | EPerform [Name] [Expr] -- perform QualName(args) + | EInfix InfixOp Expr Expr + | ENot Expr + deriving (Show) + +data InfixOp + = OpAnd | OpOr + | OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte + | OpIn -- `in` / `∈` + | OpConcat -- ++ + | OpThen -- >> + | OpBind -- >>= + deriving (Show, Eq) + +data DoStmt + = DSBind Name Expr + | DSExpr Expr + deriving (Show) + +type ArmBlock = [Arm] +data Arm = Arm Pat (Maybe Expr) Expr -- pattern, guard?, body + deriving (Show) + +-- ─── Literals ─────────────────────────────────────────────────────────────── + +data Literal + = LInt Int + | LString String + | LBool Bool + | LIPv4 (Word8,Word8,Word8,Word8) + | LIPv6 [Word16] + | LCIDR Literal Int + | LPort Int + | LDuration Int TimeUnit + | LHex Word8 + deriving (Show, Eq) diff --git a/src/FWL/Check.hs b/src/FWL/Check.hs new file mode 100644 index 0000000..f3bd15d --- /dev/null +++ b/src/FWL/Check.hs @@ -0,0 +1,207 @@ +{- | Static checks for MVP: + 1. Undefined name detection (interfaces, zones, patterns, rules/policies) + 2. Policy arm termination: last arm of a policy must not be Continue + 3. Named pattern cycle detection + 4. CIDR exhaustiveness stub (warns but does not error for MVP) +-} +module FWL.Check + ( checkProgram + , CheckError(..) + ) where + +import Data.List (foldl', nub) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import FWL.AST + +data CheckError + = UndefinedName String String -- kind, name + | PolicyNoContinue String -- policy name + | PatternCycle [String] -- cycle path + | DuplicateDecl String String -- kind, name + deriving (Show, Eq) + +type Env = Map.Map String DeclKind +data DeclKind = KInterface | KZone | KLet | KPattern | KFlow | KRule | KPolicy + deriving (Show, Eq) + +checkProgram :: Program -> [CheckError] +checkProgram (Program _ decls) = + dupErrs ++ nameErrs ++ policyErrs ++ cycleErrs + where + env = buildEnv decls + dupErrs = findDups decls + nameErrs = concatMap (checkDecl env) decls + policyErrs = concatMap checkPolicyTermination decls + cycleErrs = checkPatternCycles decls + +-- ─── Environment ───────────────────────────────────────────────────────────── + +buildEnv :: [Decl] -> Env +buildEnv = foldl' addDecl Map.empty + where + addDecl m (DInterface n _ _) = Map.insert n KInterface m + addDecl m (DZone n _) = Map.insert n KZone m + addDecl m (DLet n _ _) = Map.insert n KLet m + addDecl m (DPattern n _ _) = Map.insert n KPattern m + addDecl m (DFlow n _) = Map.insert n KFlow m + addDecl m (DRule n _ _) = Map.insert n KRule m + addDecl m (DPolicy n _ _ _) = Map.insert n KPolicy m + addDecl m _ = m + +findDups :: [Decl] -> [CheckError] +findDups decls = go [] Set.empty decls + where + go acc _ [] = acc + go acc seen (d:ds) = + let n = declName d in + if Set.member n seen + then go (DuplicateDecl (declKindStr d) n : acc) seen ds + else go acc (Set.insert n seen) ds + +declName :: Decl -> String +declName (DInterface n _ _) = n +declName (DZone n _) = n +declName (DImport n _ _) = n +declName (DLet n _ _) = n +declName (DPattern n _ _) = n +declName (DFlow n _) = n +declName (DRule n _ _) = n +declName (DPolicy n _ _ _) = n + +declKindStr :: Decl -> String +declKindStr (DInterface _ _ _) = "interface" +declKindStr (DZone _ _) = "zone" +declKindStr (DImport _ _ _) = "import" +declKindStr (DLet _ _ _) = "let" +declKindStr (DPattern _ _ _) = "pattern" +declKindStr (DFlow _ _) = "flow" +declKindStr (DRule _ _ _) = "rule" +declKindStr (DPolicy _ _ _ _) = "policy" + +-- ─── Name resolution ───────────────────────────────────────────────────────── + +checkDecl :: Env -> Decl -> [CheckError] +checkDecl env (DZone _ ns) = concatMap (checkName env "interface or zone") ns +checkDecl env (DPattern _ _ p) = checkPat env p +checkDecl env (DFlow _ fe) = checkFlow env fe +checkDecl env (DRule _ _ e) = checkExpr env e +checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab +checkDecl env (DLet _ _ e) = checkExpr env e +checkDecl _ _ = [] + +checkName :: Env -> String -> String -> [CheckError] +checkName env kind n + | Map.member n env = [] + | isBuiltin n = [] + | otherwise = [UndefinedName kind n] + +isBuiltin :: String -> Bool +isBuiltin n = n `elem` + [ "ct", "iif", "oif", "lo", "wan", "lan" + , "tcp", "udp", "ip", "ip6", "eth" + , "Established", "Related", "DNAT" + , "Allow", "Drop", "Continue", "Masquerade" + , "Matched", "Unmatched" + , "true", "false" + ] + +checkPat :: Env -> Pat -> [CheckError] +checkPat _ PWild = [] +checkPat _ (PVar _) = [] +checkPat env (PNamed n) = checkName env "pattern" n +checkPat env (PCtor _ ps) = concatMap (checkPat env) ps +checkPat env (PRecord _ fs) = concatMap (checkFP env) fs +checkPat env (PTuple ps) = concatMap (checkPat env) ps +checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner +checkPat _ (PBytes _) = [] + +checkFP :: Env -> FieldPat -> [CheckError] +checkFP _ _ = [] -- field names checked by type-checker later + +checkPath :: Env -> PathPat -> [CheckError] +checkPath env (PathPat ms md) = + maybe [] (checkEP env) ms ++ maybe [] (checkEP env) md + +checkEP :: Env -> EndpointPat -> [CheckError] +checkEP _ EPWild = [] +checkEP env (EPName n) = checkName env "interface or zone" n +checkEP env (EPMember _ z) = checkName env "zone" z + +checkFlow :: Env -> FlowExpr -> [CheckError] +checkFlow env (FAtom n) = checkName env "pattern" n +checkFlow env (FSeq a b _) = checkFlow env a ++ checkFlow env b + +checkArm :: Env -> Arm -> [CheckError] +checkArm env (Arm p mg e) = + checkPat env p ++ + maybe [] (checkExpr env) mg ++ + checkExpr env e + +checkExpr :: Env -> Expr -> [CheckError] +checkExpr env (EVar n) = checkName env "name" n +checkExpr _ (EQual _) = [] -- qualified names: deferred +checkExpr _ (ELit _) = [] +checkExpr env (ELam _ e) = checkExpr env e +checkExpr env (EApp f x) = checkExpr env f ++ checkExpr env x +checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab +checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f] +checkExpr env (EDo ss) = concatMap (checkStmt env) ss +checkExpr env (ELet _ e1 e2) = checkExpr env e1 ++ checkExpr env e2 +checkExpr env (ETuple es) = concatMap (checkExpr env) es +checkExpr env (ESet es) = concatMap (checkExpr env) es +checkExpr env (EMap ms) = concatMap (\(k,v) -> checkExpr env k ++ checkExpr env v) ms +checkExpr env (EPerform _ as_) = concatMap (checkExpr env) as_ +checkExpr env (EInfix _ l r) = checkExpr env l ++ checkExpr env r +checkExpr env (ENot e) = checkExpr env e + +checkStmt :: Env -> DoStmt -> [CheckError] +checkStmt env (DSBind _ e) = checkExpr env e +checkStmt env (DSExpr e) = checkExpr env e + +-- ─── Policy termination ─────────────────────────────────────────────────────── + +-- The last arm of a policy block must not unconditionally return Continue. +checkPolicyTermination :: Decl -> [CheckError] +checkPolicyTermination (DPolicy n _ _ arms) + | null arms = [PolicyNoContinue n] + | isContinue (last arms) = [PolicyNoContinue n] + | otherwise = [] + where + isContinue (Arm PWild Nothing (EVar "Continue")) = True + isContinue _ = False +checkPolicyTermination _ = [] + +-- ─── Pattern cycle detection ───────────────────────────────────────────────── + +checkPatternCycles :: [Decl] -> [CheckError] +checkPatternCycles decls = + [ PatternCycle c + | c <- findCycles graph + ] + where + patDecls = [(n, p) | DPattern n _ p <- decls] + graph = Map.fromList [(n, nub (refsInPat p)) | (n,p) <- patDecls] + allPats = Set.fromList (map fst patDecls) + + refsInPat :: Pat -> [String] + refsInPat (PNamed r) = [r | Set.member r allPats] + refsInPat (PCtor _ ps) = concatMap refsInPat ps + refsInPat (PTuple ps) = concatMap refsInPat ps + refsInPat (PFrame _ p) = refsInPat p + refsInPat _ = [] + +findCycles :: Map.Map String [String] -> [[String]] +findCycles graph = go Set.empty Set.empty [] (Map.keys graph) + where + go _ _ _ [] = [] + go visited onPath path (n:ns) + | Set.member n visited = go visited onPath path ns + | Set.member n onPath = [path] + | otherwise = + let onPath' = Set.insert n onPath + path' = path ++ [n] + deps = Map.findWithDefault [] n graph + cycles = go visited onPath' path' deps + in cycles ++ go (Set.insert n visited) onPath path ns diff --git a/src/FWL/Compile.hs b/src/FWL/Compile.hs new file mode 100644 index 0000000..4f7bb6e --- /dev/null +++ b/src/FWL/Compile.hs @@ -0,0 +1,316 @@ +{- | Compile a checked FWL program to nftables JSON using Aeson. + 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 — the compiler inserts protocol matches + from whatever constructor the user wrote. +-} +module FWL.Compile + ( compileProgram + , compileToJson + ) where + +import Data.List (intercalate) +import Data.Maybe (mapMaybe) +import qualified Data.Map.Strict as Map +import qualified Data.Aeson as A +import Data.Aeson ((.=), Value(..), object, toJSON) +import qualified Data.Aeson.Key as K +import qualified Data.ByteString.Lazy as BL +import qualified Data.Aeson.Encode.Pretty as Pretty + +import FWL.AST + +-- ─── Entry points ──────────────────────────────────────────────────────────── + +-- | Compile an FWL program and render to pretty-printed JSON bytes. +compileToJson :: Program -> BL.ByteString +compileToJson = Pretty.encodePretty . programToValue + +-- | Compile an FWL program to an Aeson Value (the nftables JSON schema). +programToValue :: Program -> Value +programToValue prog@(Program cfg decls) = + object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ] + where + env = buildEnv decls + tbl = configTable cfg + + metainfo = object [ "metainfo" .= object [ "json_schema_version" .= (1 :: Int) ] ] + tableObj = object [ "table" .= tableValue tbl ] + + policies = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ] + chainObjs = map (\(n, pm, _) -> chainDeclValue tbl n pm) policies + ruleObjs = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies + + letDecls = [ (n, t, e) | DLet n t e <- decls ] + mapObjs = mapMaybe (\(n, _, e) -> letToMapValue tbl n e) letDecls + +-- ─── Table / Chain declarations ────────────────────────────────────────────── + +tableValue :: String -> Value +tableValue tbl = object + [ "family" .= ("inet" :: String) + , "name" .= tbl + ] + +chainDeclValue :: String -> Name -> PolicyMeta -> Value +chainDeclValue tbl n pm = object + [ "chain" .= object + [ "family" .= ("inet" :: String) + , "table" .= tbl + , "name" .= n + , "type" .= chainTypeStr (pmTable pm) + , "hook" .= hookStr (pmHook pm) + , "prio" .= priorityStr (pmPriority pm) + , "policy" .= defaultPolicyStr (pmHook pm) + ] + ] + +chainTypeStr :: TableName -> String +chainTypeStr TFilter = "filter" +chainTypeStr TNAT = "nat" + +hookStr :: Hook -> String +hookStr HInput = "input" +hookStr HForward = "forward" +hookStr HOutput = "output" +hookStr HPrerouting = "prerouting" +hookStr HPostrouting = "postrouting" + +priorityStr :: Priority -> String +priorityStr PFilter = "filter" +priorityStr PDstNat = "dstnat" +priorityStr PSrcNat = "srcnat" +priorityStr PMangle = "mangle" +priorityStr (PInt n) = show n + +-- Input and Forward hooks default to drop; everything else to accept. +defaultPolicyStr :: Hook -> String +defaultPolicyStr HInput = "drop" +defaultPolicyStr HForward = "drop" +defaultPolicyStr _ = "accept" + +-- ─── Arm → Rule objects ────────────────────────────────────────────────────── + +-- Each policy arm becomes zero or more nftables rule objects. +-- An arm whose action is Continue compiles to zero rules. +armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value] +armToRuleValues env tbl chain (Arm p mg body) = + case compileAction env body of + Nothing -> [] -- Continue: emit nothing + Just verdict -> + let patExprs = compilePat env p + guardExprs = maybe [] (compileGuard env) mg + allExprs = patExprs ++ guardExprs ++ [verdict] + in [ object + [ "rule" .= object + [ "family" .= ("inet" :: String) + , "table" .= tbl + , "chain" .= chain + , "expr" .= toJSON allExprs + ] + ] + ] + +-- ─── Pattern → [Value] ─────────────────────────────────────────────────────── + +type CompileEnv = Map.Map String Decl + +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 + +compilePat :: CompileEnv -> Pat -> [Value] +compilePat _ PWild = [] +compilePat _ (PVar _) = [] +compilePat env (PNamed n) = expandNamedPat env n +compilePat env (PFrame mp inner) = + maybe [] (compilePathPat env) mp ++ compilePat env inner +compilePat env (PCtor n ps) = compileCtorPat env n ps +compilePat _ (PRecord n fs) = compileRecordPat n fs +compilePat env (PTuple ps) = concatMap (compilePat env) ps +compilePat _ (PBytes _) = [] -- handled by flow/ct mark (future) + +-- Named patterns are inlined at compile time. +expandNamedPat :: CompileEnv -> Name -> [Value] +expandNamedPat env n = + case Map.lookup n env of + Just (DPattern _ _ p) -> compilePat env p + _ -> [] + +-- Layer stripping: Ether is transparent; IPv4/IPv6/TCP/UDP/ICMPv6 each emit +-- the appropriate protocol-selector match then recurse into their children. +-- Omitting Ether produces identical output. +compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value] +compileCtorPat env ctor ps = case ctor of + "Ether" -> children -- transparent layer + "IPv4" -> matchMeta "nfproto" "ipv4" : children + "IPv6" -> matchMeta "nfproto" "ipv6" : children + "TCP" -> matchPayload "th" "protocol" "tcp" : children + "UDP" -> matchPayload "th" "protocol" "udp" : children + "ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children + "ICMP" -> matchPayload "ip" "protocol" "icmp" : children + _ -> children + where + children = concatMap (compilePat env) ps + +-- Record patterns emit field equality matches, e.g. tcp { dport = :22 }. +compileRecordPat :: String -> [FieldPat] -> [Value] +compileRecordPat proto = mapMaybe go + where + go (FPEq field lit) = Just (matchPayload proto field (renderLit lit)) + go _ = Nothing + +-- Path patterns (iif/oif). +compilePathPat :: CompileEnv -> PathPat -> [Value] +compilePathPat _ (PathPat ms md) = + maybe [] (compileEndpoint "iifname") ms ++ + maybe [] (compileEndpoint "oifname") md + +compileEndpoint :: String -> EndpointPat -> [Value] +compileEndpoint _ EPWild = [] +compileEndpoint dir (EPName n) = [matchMeta dir n] +compileEndpoint dir (EPMember _ z) = [matchInSet (metaVal dir) [z]] + -- zone membership: for MVP we emit the zone name as a set element. + -- A later pass would expand zones to their member interface names. + +-- ─── 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 _ _ = [] + +compileInExpr :: Expr -> Expr -> Value +-- ct.state in { Established, Related } +compileInExpr (EQual ["ct","state"]) (ESet vs) = ctMatch "state" vs +compileInExpr (EQual ["ct","status"]) (ESet vs) = ctMatch "status" vs +-- generic set membership +compileInExpr l (ESet vs) = matchExpr "in" (exprVal l) (setVal (map exprToStr vs)) +compileInExpr l r = matchExpr "==" (exprVal l) (exprVal r) + +ctMatch :: String -> [Expr] -> Value +ctMatch key vs = matchExpr "in" + (object ["ct" .= object ["key" .= key]]) + (setVal (map exprToStr vs)) + +-- ─── Action → Maybe Value (Nothing = Continue = no rule) ───────────────────── + +compileAction :: CompileEnv -> Expr -> Maybe Value +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 _ (EApp (EVar "DNAT") arg) = + Just $ object ["dnat" .= object ["addr" .= exprToStr arg]] +compileAction _ (EApp (EVar "DNATMap") arg) = + Just $ object ["dnat" .= object ["addr" .= object + ["map" .= object ["key" .= object ["concat" .= Array mempty] + ,"data" .= exprToStr arg]]]] +-- Rule invocation → 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]) + +-- ─── Let → Map object ──────────────────────────────────────────────────────── + +letToMapValue :: String -> Name -> Expr -> Maybe Value +letToMapValue tbl n (EMap entries) = Just $ object + [ "map" .= object + [ "family" .= ("inet" :: String) + , "table" .= tbl + , "name" .= n + , "type" .= ("inetproto . inetservice" :: String) + , "map" .= ("ipv4_addr . inetservice" :: String) + , "elem" .= toJSON (map renderMapElem entries) + ] + ] +letToMapValue _ _ _ = Nothing + +renderMapElem :: (Expr, Expr) -> Value +renderMapElem (k, v) = toJSON + [ object ["concat" .= toJSON [exprToStr k]] + , exprToStr v + ] + +-- ─── Aeson building blocks ─────────────────────────────────────────────────── + +-- { "match": { "op": op, "left": left, "right": right } } +matchExpr :: String -> Value -> Value -> Value +matchExpr op l r = object + [ "match" .= object + [ "op" .= op + , "left" .= l + , "right" .= r + ] + ] + +matchMeta :: String -> String -> Value +matchMeta key val = matchExpr "==" (metaVal key) (A.String (strText val)) + +matchPayload :: String -> String -> String -> Value +matchPayload proto field val = + matchExpr "==" (payloadVal proto field) (A.String (strText val)) + +matchInSet :: Value -> [String] -> Value +matchInSet lhs vals = + matchExpr "in" lhs (setVal vals) + +metaVal :: String -> Value +metaVal key = object ["meta" .= object ["key" .= key]] + +payloadVal :: String -> String -> Value +payloadVal proto field = + object ["payload" .= object ["protocol" .= proto, "field" .= field]] + +setVal :: [String] -> Value +setVal vs = object ["set" .= toJSON vs] + +-- ─── Expression → Value helpers ────────────────────────────────────────────── + +exprVal :: Expr -> Value +exprVal (EQual [p, f]) = payloadVal p f +exprVal (EQual ["ct", k]) = object ["ct" .= object ["key" .= k]] +exprVal (EVar n) = metaVal n +exprVal (ELit l) = A.String (strText (renderLit l)) +exprVal (ESet vs) = setVal (map exprToStr vs) +exprVal e = A.String (strText (exprToStr e)) + +exprToStr :: Expr -> String +exprToStr (EVar n) = n +exprToStr (ELit l) = renderLit l +exprToStr (EQual ns) = intercalate "." ns +exprToStr (ETuple es) = intercalate " . " (map exprToStr es) +exprToStr _ = "_" + +strText :: String -> A.Text +strText = \s -> read (show s) -- simple String→Text without extra dep + +renderLit :: Literal -> String +renderLit (LInt n) = show n +renderLit (LString s) = s +renderLit (LBool True) = "true" +renderLit (LBool False) = "false" +renderLit (LIPv4 (a,b,c,d)) = + show a++"."++show b++"."++show c++"."++show d +renderLit (LIPv6 _) = "::1" +renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p +renderLit (LPort p) = show p +renderLit (LDuration n Seconds) = show n +renderLit (LDuration n _) = show n +renderLit (LHex b) = show b + +-- Data.Aeson.Key helper (aeson >= 2.0 uses Key, not Text, for object keys) +(.=) :: A.ToJSON v => String -> v -> A.Pair +k .= v = (K.fromString k, toJSON v) diff --git a/src/FWL/Lexer.hs b/src/FWL/Lexer.hs new file mode 100644 index 0000000..3d442c3 --- /dev/null +++ b/src/FWL/Lexer.hs @@ -0,0 +1,100 @@ +module FWL.Lexer where + +import Text.Parsec +import Text.Parsec.String (Parser) +import qualified Text.Parsec.Token as Tok +import Text.Parsec.Language (emptyDef) + +-- ─── Language definition ───────────────────────────────────────────────────── + +fwlDef :: Tok.LanguageDef () +fwlDef = emptyDef + { Tok.commentLine = "--" + , Tok.commentStart = "{-" + , Tok.commentEnd = "-}" + , Tok.identStart = letter <|> char '_' + , Tok.identLetter = alphaNum <|> char '_' + , Tok.reservedNames = + [ "config", "table" + , "interface", "zone", "import", "from" + , "let", "in", "pattern", "flow", "rule", "policy", "on" + , "case", "of", "if", "then", "else", "do", "perform" + , "within", "as", "dynamic", "cidr4", "cidr6" + , "hook", "priority" + , "WAN", "LAN", "WireGuard" + , "Input", "Forward", "Output", "Prerouting", "Postrouting" + , "Filter", "NAT", "Mangle", "DstNat", "SrcNat" + , "Allow", "Drop", "Continue", "Masquerade", "DNAT", "DNATMap" + , "Log", "Info", "Warn", "Error" + , "Matched", "Unmatched" + , "Frame", "FlowPattern" + , "true", "false" + ] + , Tok.reservedOpNames = + [ "->", "<-", "=>", "::", ":", "=", ".", ".." + , "\\", "|", "," + , "&&", "||", "!", "==" , "!=", "<", "<=", ">", ">=" + , "++", ">>", ">>=" + , "∈" + ] + , Tok.caseSensitive = True + } + +lexer :: Tok.TokenParser () +lexer = Tok.makeTokenParser fwlDef + +-- ─── Token helpers ─────────────────────────────────────────────────────────── + +identifier :: Parser String +identifier = Tok.identifier lexer + +reserved :: String -> Parser () +reserved = Tok.reserved lexer + +reservedOp :: String -> Parser () +reservedOp = Tok.reservedOp lexer + +symbol :: String -> Parser String +symbol = Tok.symbol lexer + +parens :: Parser a -> Parser a +parens = Tok.parens lexer + +braces :: Parser a -> Parser a +braces = Tok.braces lexer + +angles :: Parser a -> Parser a +angles = Tok.angles lexer + +brackets :: Parser a -> Parser a +brackets = Tok.brackets lexer + +semi :: Parser String +semi = Tok.semi lexer + +comma :: Parser String +comma = Tok.comma lexer + +colon :: Parser String +colon = Tok.colon lexer + +dot :: Parser String +dot = Tok.dot lexer + +whiteSpace :: Parser () +whiteSpace = Tok.whiteSpace lexer + +stringLit :: Parser String +stringLit = Tok.stringLiteral lexer + +natural :: Parser Integer +natural = Tok.natural lexer + +commaSep :: Parser a -> Parser [a] +commaSep = Tok.commaSep lexer + +commaSep1 :: Parser a -> Parser [a] +commaSep1 = Tok.commaSep1 lexer + +semiSep :: Parser a -> Parser [a] +semiSep = Tok.semiSep lexer diff --git a/src/FWL/Parser.hs b/src/FWL/Parser.hs new file mode 100644 index 0000000..ebd79c9 --- /dev/null +++ b/src/FWL/Parser.hs @@ -0,0 +1,553 @@ +module FWL.Parser + ( parseProgram + , parseFile + ) where + +import Control.Monad (void) +import Data.Word (Word8) +import Numeric (readHex) +import Text.Parsec +import Text.Parsec.String (Parser) +import qualified Text.Parsec.Expr as Ex + +import FWL.AST +import FWL.Lexer + +-- ─── Entry points ──────────────────────────────────────────────────────────── + +parseProgram :: String -> String -> Either ParseError Program +parseProgram src input = parse program src input + +parseFile :: FilePath -> IO (Either ParseError Program) +parseFile fp = parseProgram fp <$> readFile fp + +-- ─── Top-level ─────────────────────────────────────────────────────────────── + +program :: Parser Program +program = do + whiteSpace + cfg <- option defaultConfig configBlock + ds <- many decl + eof + return (Program cfg ds) + +configBlock :: Parser Config +configBlock = do + reserved "config" + props <- braces (semiSep configProp) + optional semi + return $ foldr applyProp defaultConfig props + where + applyProp ("table", v) c = c { configTable = v } + applyProp _ c = c + +configProp :: Parser (String, String) +configProp = do + reserved "table" + reservedOp "=" + v <- stringLit + return ("table", v) + +-- ─── Declarations ──────────────────────────────────────────────────────────── + +decl :: Parser Decl +decl = interfaceDecl + <|> zoneDecl + <|> importDecl + <|> letDecl + <|> patternDecl + <|> flowDecl + <|> ruleDecl + <|> policyDecl + +interfaceDecl :: Parser Decl +interfaceDecl = do + reserved "interface" + n <- identifier + reservedOp ":" + k <- ifaceKind + ps <- braces (semiSep ifaceProp) + semi + return (DInterface n k ps) + +ifaceKind :: Parser IfaceKind +ifaceKind = (reserved "WAN" >> return IWan) + <|> (reserved "LAN" >> return ILan) + <|> (reserved "WireGuard" >> return IWireGuard) + <|> (IUser <$> identifier) + +ifaceProp :: Parser IfaceProp +ifaceProp = (reserved "dynamic" >> return IPDynamic) + <|> (reserved "cidr4" >> reservedOp "=" >> IPCidr4 <$> cidrSet) + <|> (reserved "cidr6" >> reservedOp "=" >> IPCidr6 <$> cidrSet) + +cidrSet :: Parser [CIDR] +cidrSet = braces (commaSep1 cidrLit) + +zoneDecl :: Parser Decl +zoneDecl = do + reserved "zone" + n <- identifier + reservedOp "=" + ns <- braces (commaSep1 identifier) + semi + return (DZone n ns) + +importDecl :: Parser Decl +importDecl = do + reserved "import" + n <- identifier + reservedOp ":" + t <- typeP + reserved "from" + s <- stringLit + semi + return (DImport n t s) + +letDecl :: Parser Decl +letDecl = do + reserved "let" + n <- identifier + reservedOp ":" + t <- typeP + reservedOp "=" + e <- expr + semi + return (DLet n t e) + +patternDecl :: Parser Decl +patternDecl = do + reserved "pattern" + n <- identifier + reservedOp ":" + t <- typeP + reservedOp "=" + p <- pat + semi + return (DPattern n t p) + +flowDecl :: Parser Decl +flowDecl = do + reserved "flow" + n <- identifier + reservedOp ":" + reserved "FlowPattern" + reservedOp "=" + f <- flowExpr + semi + return (DFlow n f) + +ruleDecl :: Parser Decl +ruleDecl = do + reserved "rule" + n <- identifier + reservedOp ":" + t <- typeP + reservedOp "=" + e <- expr + semi + return (DRule n t e) + +policyDecl :: Parser Decl +policyDecl = do + reserved "policy" + n <- identifier + reservedOp ":" + t <- typeP + reserved "on" + pm <- braces policyMeta + reservedOp "=" + ab <- armBlock + semi + return (DPolicy n t pm ab) + +policyMeta :: Parser PolicyMeta +policyMeta = do + props <- commaSep1 metaProp + let h = foldr (\p a -> case p of Left v -> v; _ -> a) HInput props + tb = foldr (\p a -> case p of Right (Left v) -> v; _ -> a) TFilter props + pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) PFilter props + return (PolicyMeta h tb pr) + +metaProp :: Parser (Either Hook (Either TableName Priority)) +metaProp + = (reserved "hook" >> reservedOp "=" >> fmap (Left) hookP) + <|> (reserved "table" >> reservedOp "=" >> fmap (Right . Left) tableNameP) + <|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right) priorityP) + +hookP :: Parser Hook +hookP = (reserved "Input" >> return HInput) + <|> (reserved "Forward" >> return HForward) + <|> (reserved "Output" >> return HOutput) + <|> (reserved "Prerouting" >> return HPrerouting) + <|> (reserved "Postrouting" >> return HPostrouting) + +tableNameP :: Parser TableName +tableNameP = (reserved "Filter" >> return TFilter) + <|> (reserved "NAT" >> return TNAT) + +priorityP :: Parser Priority +priorityP = (reserved "Filter" >> return PFilter) + <|> (reserved "DstNat" >> return PDstNat) + <|> (reserved "SrcNat" >> return PSrcNat) + <|> (reserved "Mangle" >> return PMangle) + <|> (PInt . fromIntegral <$> natural) + +-- ─── Arm blocks ────────────────────────────────────────────────────────────── + +armBlock :: Parser ArmBlock +armBlock = braces (many arm) + +arm :: Parser Arm +arm = do + symbol "|" + p <- pat + g <- optionMaybe (reserved "if" >> expr) + reservedOp "->" + e <- expr + semi + return (Arm p g e) + +-- ─── Patterns ──────────────────────────────────────────────────────────────── + +pat :: Parser Pat +pat = wildcardPat + <|> framePat + <|> try tuplePat + <|> bytesPat + <|> try recordPat + <|> try namedOrCtorPat + +wildcardPat :: Parser Pat +wildcardPat = symbol "_" >> return PWild + +-- Frame(...) — optional path then inner pattern +-- Layer stripping: if the inner pattern is not Ether/IPv4/IPv6/etc the +-- type-checker will peel outer layers automatically. Parser just stores +-- whatever the user wrote. +framePat :: Parser Pat +framePat = do + reserved "Frame" + (mp, inner) <- parens frameArgs + return (PFrame mp inner) + +frameArgs :: Parser (Maybe PathPat, Pat) +frameArgs = try withPath <|> withoutPath + where + withPath = do + pp <- pathPat + comma + inner <- pat + return (Just pp, inner) + withoutPath = do + inner <- pat + return (Nothing, inner) + +pathPat :: Parser PathPat +pathPat = do + src <- optionMaybe (try endpointPat) + dst <- optionMaybe (try (reservedOp "->" >> endpointPat)) + case (src, dst) of + (Nothing, Nothing) -> fail "empty path pattern" + _ -> return (PathPat src dst) + +endpointPat :: Parser EndpointPat +endpointPat + = (symbol "_" >> return EPWild) + <|> try (do n <- identifier + memberOp + z <- identifier + return (EPMember n z)) + <|> (EPName <$> identifier) + +memberOp :: Parser () +memberOp = (reservedOp "∈" <|> reserved "in") >> return () + +tuplePat :: Parser Pat +tuplePat = do + ps <- parens (commaSep2 pat) + return (PTuple ps) + +commaSep2 :: Parser a -> Parser [a] +commaSep2 p = do + x <- p + comma + xs <- commaSep1 p + return (x:xs) + +bytesPat :: Parser Pat +bytesPat = brackets (PBytes <$> many byteElem) + +byteElem :: Parser ByteElem +byteElem + = try (symbol "_*" >> return BEWildStar) + <|> try (symbol "_" >> return BEWild) + <|> (BEHex <$> hexByte) + +hexByte :: Parser Word8 +hexByte = do + void (string "0x") + h1 <- hexDigit + h2 <- hexDigit + whiteSpace + let [(v,"")] = readHex [h1,h2] + return (fromIntegral v) + +-- Record pattern: ident { fields } +recordPat :: Parser Pat +recordPat = do + n <- identifier + fs <- braces (commaSep fieldPat) + return (PRecord n fs) + +fieldPat :: Parser FieldPat +fieldPat = do + n <- identifier + try (reservedOp "=" >> FPEq n <$> literal) + <|> try (reserved "as" >> FPAs n <$> identifier) + <|> return (FPBind n) + +-- Named pattern reference OR constructor: starts with uppercase-ish ident +namedOrCtorPat :: Parser Pat +namedOrCtorPat = do + n <- identifier + args <- optionMaybe (try (parens (commaSep pat))) + case args of + Nothing -> return (PNamed n) -- bare name = named pattern ref + Just ps -> return (PCtor n ps) + +-- ─── Flow expressions ──────────────────────────────────────────────────────── + +flowExpr :: Parser FlowExpr +flowExpr = do + first <- FAtom <$> identifier + rest <- many (reservedOp "." >> identifier) + mw <- optionMaybe (reserved "within" >> durationLit) + return $ buildSeq (first : map FAtom rest) mw + where + buildSeq [x] mw = case mw of + Nothing -> x + Just w -> FSeq x x (Just w) -- degenerate + buildSeq (x:xs) mw = FSeq x (buildSeq xs mw) mw + buildSeq [] _ = error "impossible" + +durationLit :: Parser Duration +durationLit = do + n <- fromIntegral <$> natural + u <- (char 's' >> return Seconds) + <|> (string "ms" >> return Millis) + <|> (char 'm' >> return Minutes) + <|> (char 'h' >> return Hours) + whiteSpace + return (n, u) + +-- ─── Types ─────────────────────────────────────────────────────────────────── + +typeP :: Parser Type +typeP = do + t <- baseType + option t (reservedOp "->" >> TFun t <$> typeP) + +baseType :: Parser Type +baseType + = effectType + <|> try tupleTy + <|> simpleTy + +effectType :: Parser Type +effectType = do + effs <- angles (commaSep identifier) + t <- simpleTy + return (TEffect effs t) + +tupleTy :: Parser Type +tupleTy = TTuple <$> parens (commaSep2 typeP) + +simpleTy :: Parser Type +simpleTy = do + n <- identifier + args <- option [] (angles (commaSep typeP)) + return (TName n args) + +-- ─── Expressions ───────────────────────────────────────────────────────────── + +expr :: Parser Expr +expr = lamExpr + <|> ifExpr + <|> doExpr + <|> caseExpr + <|> letExpr + <|> infixExpr + +lamExpr :: Parser Expr +lamExpr = do + reservedOp "\\" + n <- identifier + reservedOp "->" + e <- expr + return (ELam n e) + +ifExpr :: Parser Expr +ifExpr = do + reserved "if" + c <- expr + reserved "then" + t <- expr + reserved "else" + f <- expr + return (EIf c t f) + +doExpr :: Parser Expr +doExpr = reserved "do" >> braces (EDo <$> semiSep doStmt) + +doStmt :: Parser DoStmt +doStmt = try bindStmt <|> (DSExpr <$> expr) + +bindStmt :: Parser DoStmt +bindStmt = do + n <- identifier + reservedOp "<-" + e <- expr + return (DSBind n e) + +caseExpr :: Parser Expr +caseExpr = do + reserved "case" + e <- expr + reserved "of" + ab <- armBlock + return (ECase e ab) + +letExpr :: Parser Expr +letExpr = do + reserved "let" + n <- identifier + reservedOp "=" + e1 <- expr + reserved "in" + e2 <- expr + return (ELet n e1 e2) + +-- Operator table for infix expressions +infixExpr :: Parser Expr +infixExpr = Ex.buildExpressionParser opTable appExpr + +opTable :: Ex.OperatorTable String () Identity Expr +opTable = + [ [ prefix "!" ENot ] + , [ infixL "==" OpEq, infixL "!=" OpNeq + , infixL "<" OpLt, infixL "<=" OpLte + , infixL ">" OpGt, infixL ">=" OpGte + , infixIn ] + , [ infixR "&&" OpAnd ] + , [ infixR "||" OpOr ] + , [ infixR "++" OpConcat ] + , [ infixL ">>=" OpBind ] + , [ infixL ">>" OpThen ] + ] + where + prefix op f = Ex.Prefix (reservedOp op >> return f) + infixL op c = Ex.Infix (reservedOp op >> return (EInfix c)) Ex.AssocLeft + infixR op c = Ex.Infix (reservedOp op >> return (EInfix c)) Ex.AssocRight + infixIn = Ex.Infix + ((memberOp <|> reserved "in") >> return (EInfix OpIn)) + Ex.AssocNone + +appExpr :: Parser Expr +appExpr = do + f <- atom + args <- many atom + return (foldl EApp f args) + +atom :: Parser Expr +atom + = try performExpr + <|> try mapLit + <|> try setLit + <|> try tupleLit + <|> try (parens expr) + <|> try litExpr + <|> try portExpr + <|> qualNameExpr + +performExpr :: Parser Expr +performExpr = do + reserved "perform" + parts <- sepBy1 identifier dot + args <- parens (commaSep expr) + return (EPerform parts args) + +qualNameExpr :: Parser Expr +qualNameExpr = do + parts <- sepBy1 identifier (try (dot <* notFollowedBy digit)) + case parts of + [n] -> return (EVar n) + ns -> return (EQual ns) + +litExpr :: Parser Expr +litExpr = ELit <$> literal + +portExpr :: Parser Expr +portExpr = do + void (char ':') + n <- fromIntegral <$> natural + return (ELit (LPort n)) + +tupleLit :: Parser Expr +tupleLit = ETuple <$> parens (commaSep2 expr) + +setLit :: Parser Expr +setLit = braces $ do + items <- commaSep expr + return (ESet items) + +-- map literal: { expr -> expr, ... } +mapLit :: Parser Expr +mapLit = braces $ do + entries <- commaSep1 mapEntry + return (EMap entries) + +mapEntry :: Parser (Expr, Expr) +mapEntry = do + k <- expr + reservedOp "->" + v <- expr + return (k, v) + +-- ─── Literals ──────────────────────────────────────────────────────────────── + +literal :: Parser Literal +literal + = try cidrOrIpLit + <|> try hexLit + <|> try (LBool True <$ reserved "true") + <|> try (LBool False <$ reserved "false") + <|> try (LString <$> stringLit) + <|> try (LInt . fromIntegral <$> natural) + +hexLit :: Parser Literal +hexLit = LHex <$> hexByte + +cidrOrIpLit :: Parser Literal +cidrOrIpLit = do + a <- fromIntegral <$> natural + void (char '.') + b <- fromIntegral <$> natural + void (char '.') + c <- fromIntegral <$> natural + void (char '.') + d <- fromIntegral <$> natural + whiteSpace + mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural) + whiteSpace + let ip = LIPv4 (a,b,c,d) + return $ case mPrefix of + Nothing -> ip + Just p -> LCIDR ip p + +cidrLit :: Parser CIDR +cidrLit = do + l <- cidrOrIpLit + case l of + LCIDR ip p -> return (ip, p) + _ -> fail "expected CIDR notation" diff --git a/src/FWL/Pretty.hs b/src/FWL/Pretty.hs new file mode 100644 index 0000000..17267a6 --- /dev/null +++ b/src/FWL/Pretty.hs @@ -0,0 +1,191 @@ +-- | Pretty printer: round-trips the AST back to FWL source. +module FWL.Pretty (prettyProgram) where + +import Data.List (intercalate) +import FWL.AST + +prettyProgram :: Program -> String +prettyProgram (Program cfg ds) = + prettyConfig cfg ++ "\n" ++ unlines (map prettyDecl ds) + +prettyConfig :: Config -> String +prettyConfig (Config t) + | t == "fwl" = "" + | otherwise = "config { table = \"" ++ t ++ "\"; }\n" + +prettyDecl :: Decl -> String +prettyDecl (DInterface n k ps) = + "interface " ++ n ++ " : " ++ prettyKind k ++ " {\n" ++ + concatMap (\p -> " " ++ prettyIfaceProp p ++ ";\n") ps ++ + "};" +prettyDecl (DZone n ns) = + "zone " ++ n ++ " = { " ++ intercalate ", " ns ++ " };" +prettyDecl (DImport n t s) = + "import " ++ n ++ " : " ++ prettyType t ++ " from \"" ++ s ++ "\";" +prettyDecl (DLet n t e) = + "let " ++ n ++ " : " ++ prettyType t ++ " = " ++ prettyExpr e ++ ";" +prettyDecl (DPattern n t p) = + "pattern " ++ n ++ " : " ++ prettyType t ++ " = " ++ prettyPat p ++ ";" +prettyDecl (DFlow n f) = + "flow " ++ n ++ " : FlowPattern = " ++ prettyFlow f ++ ";" +prettyDecl (DRule n t e) = + "rule " ++ n ++ " : " ++ prettyType t ++ " =\n " ++ prettyExpr e ++ ";" +prettyDecl (DPolicy n t pm ab) = + "policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++ + " on { hook = " ++ prettyHook (pmHook pm) ++ + ", table = " ++ prettyTable (pmTable pm) ++ + ", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++ + " = " ++ prettyArmBlock ab ++ ";" + +prettyKind :: IfaceKind -> String +prettyKind IWan = "WAN" +prettyKind ILan = "LAN" +prettyKind IWireGuard = "WireGuard" +prettyKind (IUser n) = n + +prettyIfaceProp :: IfaceProp -> String +prettyIfaceProp IPDynamic = "dynamic" +prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }" +prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }" + +prettyCidr :: CIDR -> String +prettyCidr (LIPv4 (a,b,c,d), p) = + show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ "/" ++ show p +prettyCidr (ip, p) = prettyLit ip ++ "/" ++ show p + +prettyHook :: Hook -> String +prettyHook HInput = "Input" +prettyHook HForward = "Forward" +prettyHook HOutput = "Output" +prettyHook HPrerouting = "Prerouting" +prettyHook HPostrouting = "Postrouting" + +prettyTable :: TableName -> String +prettyTable TFilter = "Filter" +prettyTable TNAT = "NAT" + +prettyPriority :: Priority -> String +prettyPriority PFilter = "Filter" +prettyPriority PDstNat = "DstNat" +prettyPriority PSrcNat = "SrcNat" +prettyPriority PMangle = "Mangle" +prettyPriority (PInt n)= show n + +prettyType :: Type -> String +prettyType (TName n []) = n +prettyType (TName n ts) = n ++ "<" ++ intercalate ", " (map prettyType ts) ++ ">" +prettyType (TTuple ts) = "(" ++ intercalate ", " (map prettyType ts) ++ ")" +prettyType (TFun a b) = prettyType a ++ " -> " ++ prettyType b +prettyType (TEffect es t) = "<" ++ intercalate ", " es ++ "> " ++ prettyType t + +prettyPat :: Pat -> String +prettyPat PWild = "_" +prettyPat (PVar n) = n +prettyPat (PNamed n) = n +prettyPat (PCtor n ps) = n ++ "(" ++ intercalate ", " (map prettyPat ps) ++ ")" +prettyPat (PRecord n fs) = n ++ " { " ++ intercalate ", " (map prettyFP fs) ++ " }" +prettyPat (PTuple ps) = "(" ++ intercalate ", " (map prettyPat ps) ++ ")" +prettyPat (PFrame mp inner)= + "Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")" +prettyPat (PBytes bs) = "[" ++ unwords (map prettyBE bs) ++ "]" + +prettyFP :: FieldPat -> String +prettyFP (FPEq n l) = n ++ " = " ++ prettyLit l +prettyFP (FPBind n) = n +prettyFP (FPAs n v) = n ++ " as " ++ v + +prettyPath :: PathPat -> String +prettyPath (PathPat ms md) = + maybe "_" prettyEP ms ++ maybe "" (\d -> " -> " ++ prettyEP d) md + +prettyEP :: EndpointPat -> String +prettyEP EPWild = "_" +prettyEP (EPName n) = n +prettyEP (EPMember n z) = n ++ " in " ++ z + +prettyBE :: ByteElem -> String +prettyBE (BEHex w) = "0x" ++ pad (show w) -- simplified + where pad s = if length s < 2 then '0':s else s +prettyBE BEWild = "_" +prettyBE BEWildStar = "_*" + +prettyFlow :: FlowExpr -> String +prettyFlow (FAtom n) = n +prettyFlow (FSeq a b mw) = + prettyFlow a ++ " . " ++ prettyFlow b ++ + maybe "" (\(n,u) -> " within " ++ show n ++ prettyUnit u) mw + +prettyUnit :: TimeUnit -> String +prettyUnit Seconds = "s" +prettyUnit Millis = "ms" +prettyUnit Minutes = "m" +prettyUnit Hours = "h" + +prettyExpr :: Expr -> String +prettyExpr (EVar n) = n +prettyExpr (EQual ns) = intercalate "." ns +prettyExpr (ELit l) = prettyLit l +prettyExpr (ELam n e) = "\\" ++ n ++ " -> " ++ prettyExpr e +prettyExpr (EApp f x) = prettyExpr f ++ " " ++ prettyAtom x +prettyExpr (ECase e ab) = + "case " ++ prettyExpr e ++ " of " ++ prettyArmBlock ab +prettyExpr (EIf c t f) = + "if " ++ prettyExpr c ++ " then " ++ prettyExpr t ++ " else " ++ prettyExpr f +prettyExpr (EDo ss) = + "do { " ++ intercalate "; " (map prettyStmt ss) ++ " }" +prettyExpr (ELet n e1 e2) = + "let " ++ n ++ " = " ++ prettyExpr e1 ++ " in " ++ prettyExpr e2 +prettyExpr (ETuple es) = "(" ++ intercalate ", " (map prettyExpr es) ++ ")" +prettyExpr (ESet es) = "{ " ++ intercalate ", " (map prettyExpr es) ++ " }" +prettyExpr (EMap ms) = + "{ " ++ intercalate ", " (map (\(k,v) -> prettyExpr k ++ " -> " ++ prettyExpr v) ms) ++ " }" +prettyExpr (EPerform ns as_) = + "perform " ++ intercalate "." ns ++ "(" ++ intercalate ", " (map prettyExpr as_) ++ ")" +prettyExpr (EInfix op l r) = + prettyAtom l ++ " " ++ prettyOp op ++ " " ++ prettyAtom r +prettyExpr (ENot e) = "!" ++ prettyAtom e + +prettyAtom :: Expr -> String +prettyAtom e@(EInfix _ _ _) = "(" ++ prettyExpr e ++ ")" +prettyAtom e@(ELam _ _) = "(" ++ prettyExpr e ++ ")" +prettyAtom e = prettyExpr e + +prettyOp :: InfixOp -> String +prettyOp OpAnd = "&&" +prettyOp OpOr = "||" +prettyOp OpEq = "==" +prettyOp OpNeq = "!=" +prettyOp OpLt = "<" +prettyOp OpLte = "<=" +prettyOp OpGt = ">" +prettyOp OpGte = ">=" +prettyOp OpIn = "in" +prettyOp OpConcat = "++" +prettyOp OpThen = ">>" +prettyOp OpBind = ">>=" + +prettyStmt :: DoStmt -> String +prettyStmt (DSBind n e) = n ++ " <- " ++ prettyExpr e +prettyStmt (DSExpr e) = prettyExpr e + +prettyArmBlock :: ArmBlock -> String +prettyArmBlock arms = + "{\n" ++ + concatMap (\(Arm p mg e) -> + " | " ++ prettyPat p ++ + maybe "" (\g -> " if " ++ prettyExpr g) mg ++ + " -> " ++ prettyExpr e ++ ";\n") arms ++ + " }" + +prettyLit :: Literal -> String +prettyLit (LInt n) = show n +prettyLit (LString s) = "\"" ++ s ++ "\"" +prettyLit (LBool True) = "true" +prettyLit (LBool False) = "false" +prettyLit (LIPv4 (a,b,c,d)) = + show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d +prettyLit (LIPv6 _) = "" +prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p +prettyLit (LPort p) = ":" ++ show p +prettyLit (LDuration n u) = show n ++ prettyUnit u +prettyLit (LHex b) = "0x" ++ show b