v2 perplexed
This commit is contained in:
233
src/FWL/AST.hs
Normal file
233
src/FWL/AST.hs
Normal file
@@ -0,0 +1,233 @@
|
||||
module FWL.AST where
|
||||
|
||||
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
|
||||
import Data.Word (Word8) -- Word8 still used for ByteElem/hex literals
|
||||
|
||||
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
|
||||
| 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)
|
||||
-- Priority is always an integer in the nftables JSON.
|
||||
-- Named constants are resolved to their numeric values at parse time.
|
||||
newtype Priority = Priority { priorityValue :: Int }
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Standard nftables priority constants
|
||||
pRaw, pConnTrackDefrag, pConnTrack, pMangle, pDstNat, pFilter, pSecurity, pSrcNat :: Priority
|
||||
pRaw = Priority (-300)
|
||||
pConnTrackDefrag = Priority (-400)
|
||||
pConnTrack = Priority (-200)
|
||||
pMangle = Priority (-150)
|
||||
pDstNat = Priority (-100)
|
||||
pFilter = Priority 0
|
||||
pSecurity = Priority 50
|
||||
pSrcNat = Priority 100
|
||||
|
||||
data IfaceKind = IWan | ILan | IWireGuard | IUser Name
|
||||
deriving (Show)
|
||||
|
||||
data IfaceProp
|
||||
= IPDynamic
|
||||
| IPCidr4 [CIDR]
|
||||
| IPCidr6 [CIDR]
|
||||
deriving (Show)
|
||||
|
||||
-- | A CIDR block: base address literal paired with prefix length.
|
||||
-- e.g. (LIPv4 (10,0,0,0), 8) represents 10.0.0.0/8
|
||||
type CIDR = (Literal, Int)
|
||||
|
||||
-- ─── Patterns ───────────────────────────────────────────────────────────────
|
||||
|
||||
data Pat
|
||||
= PWild
|
||||
| PVar Name
|
||||
| PNamed Name
|
||||
| PCtor Name [Pat]
|
||||
| PRecord Name [FieldPat]
|
||||
| PTuple [Pat]
|
||||
| PFrame (Maybe PathPat) Pat
|
||||
| PBytes [ByteElem]
|
||||
deriving (Show)
|
||||
|
||||
data FieldPat
|
||||
= FPEq Name Literal
|
||||
| FPBind Name
|
||||
| FPAs Name Name
|
||||
deriving (Show)
|
||||
|
||||
data PathPat = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
|
||||
deriving (Show)
|
||||
|
||||
data EndpointPat
|
||||
= EPWild
|
||||
| EPName Name
|
||||
| EPMember Name Name
|
||||
deriving (Show)
|
||||
|
||||
data ByteElem
|
||||
= BEHex Word8
|
||||
| BEWild
|
||||
| BEWildStar
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Flow ───────────────────────────────────────────────────────────────────
|
||||
|
||||
data FlowExpr
|
||||
= FAtom Name
|
||||
| FSeq FlowExpr FlowExpr (Maybe Duration)
|
||||
deriving (Show)
|
||||
|
||||
type Duration = (Int, TimeUnit)
|
||||
|
||||
-- Fix 1: TimeUnit must derive Eq because Literal (which embeds it via
|
||||
-- LDuration) derives Eq, requiring all constituent types to also have Eq.
|
||||
data TimeUnit = Seconds | Millis | Minutes | Hours
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ─── Types ──────────────────────────────────────────────────────────────────
|
||||
|
||||
data Type
|
||||
= TName Name [Type]
|
||||
| TTuple [Type]
|
||||
| TFun Type Type
|
||||
| TEffect [Name] Type
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Expressions ────────────────────────────────────────────────────────────
|
||||
|
||||
data Expr
|
||||
= EVar Name
|
||||
| EQual [Name]
|
||||
| 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]
|
||||
| EInfix InfixOp Expr Expr
|
||||
| ENot Expr
|
||||
deriving (Show)
|
||||
|
||||
data InfixOp
|
||||
= OpAnd | OpOr
|
||||
| OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
|
||||
| OpIn
|
||||
| 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
|
||||
deriving (Show)
|
||||
|
||||
-- ─── Literals ───────────────────────────────────────────────────────────────
|
||||
|
||||
-- IP addresses are stored as plain Integers for easy arithmetic,
|
||||
-- CIDR validation (mask host bits), and future subnet math.
|
||||
-- IPv4: 32-bit value in the low 32 bits.
|
||||
-- IPv6: 128-bit value.
|
||||
-- CIDR host-bit validation: (addr .&. hostMask prefix bits) == 0
|
||||
data IPVersion = IPv4 | IPv6
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Literal
|
||||
= LInt Int
|
||||
| LString String
|
||||
| LBool Bool
|
||||
| LIP IPVersion Integer -- unified IP address representation
|
||||
| LCIDR Literal Int -- base address + prefix length
|
||||
| LPort Int
|
||||
| LDuration Int TimeUnit
|
||||
| LHex Word8
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ─── IP address helpers ──────────────────────────────────────────────────────
|
||||
|
||||
-- | Build an IPv4 literal from four octets.
|
||||
ipv4Lit :: Int -> Int -> Int -> Int -> Literal
|
||||
ipv4Lit a b c d =
|
||||
LIP IPv4 (fromIntegral a `shiftL` 24
|
||||
.|. fromIntegral b `shiftL` 16
|
||||
.|. fromIntegral c `shiftL` 8
|
||||
.|. fromIntegral d)
|
||||
|
||||
-- | Check that a CIDR has no host bits set.
|
||||
cidrHostBitsZero :: Integer -> Int -> Int -> Bool
|
||||
cidrHostBitsZero addr prefix bits =
|
||||
let hostBits = bits - prefix
|
||||
hostMask = (1 `shiftL` hostBits) - 1
|
||||
in (addr .&. hostMask) == 0
|
||||
|
||||
-- | Render an IPv4 integer as a dotted-decimal string.
|
||||
renderIPv4 :: Integer -> String
|
||||
renderIPv4 n =
|
||||
show ((n `shiftR` 24) .&. 0xff) ++ "." ++
|
||||
show ((n `shiftR` 16) .&. 0xff) ++ "." ++
|
||||
show ((n `shiftR` 8) .&. 0xff) ++ "." ++
|
||||
show (n .&. 0xff)
|
||||
|
||||
-- | Render an IPv6 integer as a condensed colon-hex string.
|
||||
renderIPv6 :: Integer -> String
|
||||
renderIPv6 n =
|
||||
let groups = [ fromIntegral ((n `shiftR` (i * 16)) .&. 0xffff) :: Int
|
||||
| i <- [7,6..0] ]
|
||||
hexGroups = map (`showHex` "") groups
|
||||
in concatIntersperse ":" hexGroups
|
||||
where
|
||||
showHex x s = let h = showHexInt x in h ++ s
|
||||
showHexInt x
|
||||
| x == 0 = "0"
|
||||
| otherwise = reverse (go x)
|
||||
where go 0 = []
|
||||
go v = let (q,r) = v `divMod` 16
|
||||
c = "0123456789abcdef" !! r
|
||||
in c : go q
|
||||
concatIntersperse _ [] = ""
|
||||
concatIntersperse _ [x] = x
|
||||
concatIntersperse s (x:xs) = x ++ s ++ concatIntersperse s xs
|
||||
207
src/FWL/Check.hs
Normal file
207
src/FWL/Check.hs
Normal file
@@ -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
|
||||
313
src/FWL/Compile.hs
Normal file
313
src/FWL/Compile.hs
Normal file
@@ -0,0 +1,313 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{- | 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.
|
||||
-}
|
||||
module FWL.Compile
|
||||
( compileProgram
|
||||
, compileToJson
|
||||
) where
|
||||
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Aeson ((.=), Value(..), object, toJSON)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
|
||||
import FWL.AST
|
||||
|
||||
-- ─── Entry points ────────────────────────────────────────────────────────────
|
||||
|
||||
compileToJson :: Program -> BL.ByteString
|
||||
compileToJson = encodePretty . programToValue
|
||||
|
||||
-- exposed for tests
|
||||
compileProgram :: Program -> Value
|
||||
compileProgram = programToValue
|
||||
|
||||
programToValue :: Program -> Value
|
||||
programToValue (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" .= priorityInt (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"
|
||||
|
||||
-- Priority is emitted as an integer in nftables JSON.
|
||||
priorityInt :: Priority -> Int
|
||||
priorityInt = priorityValue
|
||||
|
||||
defaultPolicyStr :: Hook -> String
|
||||
defaultPolicyStr HInput = "drop"
|
||||
defaultPolicyStr HForward = "drop"
|
||||
defaultPolicyStr _ = "accept"
|
||||
|
||||
-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
|
||||
|
||||
armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value]
|
||||
armToRuleValues env tbl chain (Arm p mg body) =
|
||||
case compileAction env body of
|
||||
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 _) = []
|
||||
|
||||
expandNamedPat :: CompileEnv -> Name -> [Value]
|
||||
expandNamedPat env n =
|
||||
case Map.lookup n env of
|
||||
Just (DPattern _ _ p) -> compilePat env p
|
||||
_ -> []
|
||||
|
||||
compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
|
||||
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
|
||||
"ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
|
||||
"ICMP" -> matchPayload "ip" "protocol" "icmp" : children
|
||||
_ -> children
|
||||
where
|
||||
children = concatMap (compilePat env) ps
|
||||
|
||||
compileRecordPat :: String -> [FieldPat] -> [Value]
|
||||
compileRecordPat proto = mapMaybe go
|
||||
where
|
||||
go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
|
||||
go _ = Nothing
|
||||
|
||||
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]]
|
||||
|
||||
-- ─── 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
|
||||
-- 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)
|
||||
|
||||
ctMatch :: String -> [Expr] -> Value
|
||||
ctMatch key vs = matchExpr "in"
|
||||
(object ["ct" .= object ["key" .= (key :: String)]])
|
||||
(setVal (map exprToStr vs))
|
||||
|
||||
-- ─── Action → Maybe Value ─────────────────────────────────────────────────────
|
||||
|
||||
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 ]]]]
|
||||
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]]
|
||||
, A.String (toText (exprToStr v))
|
||||
]
|
||||
|
||||
-- ─── Aeson building blocks ───────────────────────────────────────────────────
|
||||
|
||||
matchExpr :: String -> Value -> Value -> Value
|
||||
matchExpr op l r = object
|
||||
[ "match" .= object
|
||||
[ "op" .= (op :: String)
|
||||
, "left" .= l
|
||||
, "right" .= r
|
||||
]
|
||||
]
|
||||
|
||||
matchMeta :: String -> String -> Value
|
||||
matchMeta key val = matchExpr "==" (metaVal key) (A.String (toText val))
|
||||
|
||||
matchPayload :: String -> String -> String -> Value
|
||||
matchPayload proto field val =
|
||||
matchExpr "==" (payloadVal proto field) (A.String (toText val))
|
||||
|
||||
matchInSet :: Value -> [String] -> Value
|
||||
matchInSet lhs vals = matchExpr "in" lhs (setVal vals)
|
||||
|
||||
metaVal :: String -> Value
|
||||
metaVal key = object ["meta" .= object ["key" .= (key :: String)]]
|
||||
|
||||
payloadVal :: String -> String -> Value
|
||||
payloadVal proto field =
|
||||
object ["payload" .= object
|
||||
[ "protocol" .= (proto :: String)
|
||||
, "field" .= (field :: String)
|
||||
]]
|
||||
|
||||
setVal :: [String] -> Value
|
||||
setVal vs = object ["set" .= toJSON vs]
|
||||
|
||||
-- ─── Expression helpers ───────────────────────────────────────────────────────
|
||||
|
||||
-- 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))
|
||||
|
||||
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 _ = "_"
|
||||
|
||||
-- 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
|
||||
|
||||
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 ++ "s"
|
||||
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
|
||||
101
src/FWL/Lexer.hs
Normal file
101
src/FWL/Lexer.hs
Normal file
@@ -0,0 +1,101 @@
|
||||
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 =
|
||||
-- Only genuine syntactic keywords belong here.
|
||||
-- Semantic values used as constructors, actions, type names, or
|
||||
-- pattern references (Allow, Drop, Log, Matched, Frame, etc.) must
|
||||
-- NOT be reserved so that `identifier` can consume them in those
|
||||
-- positions.
|
||||
[ "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", "Raw", "ConnTrack"
|
||||
, "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
|
||||
659
src/FWL/Parser.hs
Normal file
659
src/FWL/Parser.hs
Normal file
@@ -0,0 +1,659 @@
|
||||
module FWL.Parser
|
||||
( parseProgram
|
||||
, parseFile
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.Bits ((.&.), (.|.), shiftL)
|
||||
import Data.List (foldl')
|
||||
import Data.Word (Word8)
|
||||
import Numeric (readHex)
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
import Data.Functor.Identity (Identity)
|
||||
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 (endBy ifaceProp semi)
|
||||
_ <- 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)
|
||||
<|> (reserved "Raw" >> return pRaw)
|
||||
<|> (reserved "ConnTrack" >> return pConnTrack)
|
||||
<|> (Priority . fromIntegral <$> integerP)
|
||||
where
|
||||
-- Accept optional leading minus for negative priorities
|
||||
integerP = do
|
||||
neg <- option 1 (char '-' >> return (-1))
|
||||
n <- natural
|
||||
whiteSpace
|
||||
return (neg * fromIntegral n)
|
||||
|
||||
-- ─── 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
|
||||
<|> try 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
|
||||
case (readHex [h1,h2] :: [(Integer, String)]) of
|
||||
[(v,"")] -> return (fromIntegral v)
|
||||
_ -> fail "invalid hex byte"
|
||||
|
||||
-- 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 <$> fieldLiteral)
|
||||
<|> try (reserved "as" >> FPAs n <$> identifier)
|
||||
<|> return (FPBind n)
|
||||
|
||||
-- Port literals (:22) are valid in record field position as well as plain literals.
|
||||
fieldLiteral :: Parser Literal
|
||||
fieldLiteral = try portLit <|> literal
|
||||
where
|
||||
portLit = do
|
||||
void (char ':')
|
||||
n <- fromIntegral <$> natural
|
||||
return (LPort 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 ipOrCidrLit
|
||||
<|> 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
|
||||
|
||||
-- ─── IP / CIDR parsing ───────────────────────────────────────────────────────
|
||||
|
||||
-- | Parse an IPv4 or IPv6 address, optionally followed by /prefix.
|
||||
-- Tries IPv6 first (it can start with hex digits too), then IPv4.
|
||||
ipOrCidrLit :: Parser Literal
|
||||
ipOrCidrLit = do
|
||||
ip <- try ipv6Lit <|> ipv4Lit_
|
||||
mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural)
|
||||
whiteSpace
|
||||
return $ case mPrefix of
|
||||
Nothing -> ip
|
||||
Just p -> LCIDR ip p
|
||||
|
||||
-- | IPv4: four decimal octets separated by dots → LIP IPv4 (32-bit Integer)
|
||||
ipv4Lit_ :: Parser Literal
|
||||
ipv4Lit_ = do
|
||||
a <- octet
|
||||
void (char '.')
|
||||
b <- octet
|
||||
void (char '.')
|
||||
c <- octet
|
||||
void (char '.')
|
||||
d <- octet
|
||||
return $ LIP IPv4
|
||||
( fromIntegral a `shiftL` 24
|
||||
.|. fromIntegral b `shiftL` 16
|
||||
.|. fromIntegral c `shiftL` 8
|
||||
.|. fromIntegral d)
|
||||
where
|
||||
octet = do
|
||||
n <- fromIntegral <$> natural
|
||||
if n > 255 then fail "octet out of range" else return n
|
||||
|
||||
-- | IPv6: full notation, :: abbreviation, and optional embedded IPv4.
|
||||
-- Stores as LIP IPv6 (128-bit Integer).
|
||||
ipv6Lit :: Parser Literal
|
||||
ipv6Lit = do
|
||||
(left, right) <- ipv6Groups
|
||||
let missing = 8 - length left - length right
|
||||
when (missing < 0) $ fail "too many groups in IPv6 address"
|
||||
let groups = left ++ replicate missing 0 ++ right
|
||||
when (length groups /= 8) $ fail "invalid IPv6 address"
|
||||
let val = foldl' (\acc g -> (acc `shiftL` 16) .|. fromIntegral g) (0::Integer) groups
|
||||
return (LIP IPv6 val)
|
||||
|
||||
-- Returns (left-of-::, right-of-::).
|
||||
-- If no :: present, left has all 8 groups and right is empty.
|
||||
ipv6Groups :: Parser ([Int], [Int])
|
||||
ipv6Groups = do
|
||||
-- must start with a hex digit or ':' (for ::)
|
||||
ahead <- lookAhead (hexDigit <|> char ':')
|
||||
case ahead of
|
||||
':' -> do
|
||||
void (string "::")
|
||||
right <- ipv6RightGroups
|
||||
return ([], right)
|
||||
_ -> do
|
||||
left <- ipv6LeftGroups
|
||||
mDbl <- optionMaybe (try (string "::"))
|
||||
case mDbl of
|
||||
Nothing -> return (left, [])
|
||||
Just _ -> do
|
||||
right <- ipv6RightGroups
|
||||
return (left, right)
|
||||
|
||||
-- Parse a run of hex16:hex16:... stopping before :: or end
|
||||
ipv6LeftGroups :: Parser [Int]
|
||||
ipv6LeftGroups = do
|
||||
first <- hex16
|
||||
rest <- many (try (char ':' >> notFollowedBy (char ':') >> hex16))
|
||||
return (first : rest)
|
||||
|
||||
-- Parse groups to the right of ::, including optional embedded IPv4
|
||||
ipv6RightGroups :: Parser [Int]
|
||||
ipv6RightGroups = option [] $
|
||||
try ipv4EmbeddedGroups <|> ipv6LeftGroups
|
||||
|
||||
-- IPv4-mapped groups: e.g. ffff:192.168.1.1 -> [0xffff, 0xc0a8, 0x0101]
|
||||
ipv4EmbeddedGroups :: Parser [Int]
|
||||
ipv4EmbeddedGroups = do
|
||||
prefix <- many (try (hex16 <* char ':' <* lookAhead digit))
|
||||
a <- octet_; void (char '.')
|
||||
b <- octet_; void (char '.')
|
||||
c <- octet_; void (char '.')
|
||||
d <- octet_
|
||||
let hi = (a `shiftL` 8) .|. b
|
||||
lo = (c `shiftL` 8) .|. d
|
||||
return (prefix ++ [hi, lo])
|
||||
where
|
||||
octet_ = do
|
||||
n <- fromIntegral <$> natural
|
||||
if n > 255 then fail "IPv4 octet out of range" else return n
|
||||
|
||||
hex16 :: Parser Int
|
||||
hex16 = do
|
||||
digits <- many1 hexDigit
|
||||
case (reads ("0x" ++ digits)) :: [(Int,String)] of
|
||||
[(v,"")] -> if v > 0xffff then fail "hex16 out of range" else return v
|
||||
_ -> fail "invalid hex group"
|
||||
|
||||
cidrLit :: Parser CIDR
|
||||
cidrLit = do
|
||||
l <- ipOrCidrLit
|
||||
case l of
|
||||
LCIDR ip p -> return (ip, p)
|
||||
_ -> fail "expected CIDR notation (address/prefix)"
|
||||
187
src/FWL/Pretty.hs
Normal file
187
src/FWL/Pretty.hs
Normal file
@@ -0,0 +1,187 @@
|
||||
-- | 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 p = show (priorityValue p)
|
||||
|
||||
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 _) = "<ipv6>"
|
||||
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
|
||||
Reference in New Issue
Block a user