v2 perplexed

test/CheckTests.hs

@@ -0,0 +1,224 @@
+module CheckTests (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import FWL.Check
+import FWL.Util
+
+tests :: TestTree
+tests = testGroup "Check"
+  [ undefinedNameTests
+  , duplicateTests
+  , policyTerminationTests
+  , patternCycleTests
+  , cleanProgramTests
+  ]
+
+-- ─── Helper ──────────────────────────────────────────────────────────────────
+
+checkSrc :: String -> IO [CheckError]
+checkSrc src = do
+  p <- parseOk src
+  return (checkProgram p)
+
+assertNoErrors :: String -> IO ()
+assertNoErrors src = do
+  errs <- checkSrc src
+  case errs of
+    [] -> return ()
+    _  -> assertFailure ("Unexpected errors: " ++ show errs)
+
+assertHasError :: (CheckError -> Bool) -> String -> IO ()
+assertHasError p src = do
+  errs <- checkSrc src
+  if any p errs
+    then return ()
+    else assertFailure ("Expected error not found. Got: " ++ show errs)
+
+isUndefined :: String -> CheckError -> Bool
+isUndefined n (UndefinedName _ m) = m == n
+isUndefined _ _                   = False
+
+isDuplicate :: String -> CheckError -> Bool
+isDuplicate n (DuplicateDecl _ m) = m == n
+isDuplicate _ _                   = False
+
+isNoContinue :: String -> CheckError -> Bool
+isNoContinue n (PolicyNoContinue m) = m == n
+isNoContinue _ _                    = False
+
+isCycle :: CheckError -> Bool
+isCycle (PatternCycle _) = True
+isCycle _                = False
+
+-- ─── Undefined name tests ────────────────────────────────────────────────────
+
+undefinedNameTests :: TestTree
+undefinedNameTests = testGroup "undefined names"
+  [ testCase "zone references unknown interface" $
+      assertHasError (isUndefined "ghost")
+        "zone bad_zone = { lan, ghost };"
+
+  , testCase "zone references known interface — no error" $
+      assertNoErrors
+        "interface lan : LAN {}; \
+        \zone good = { lan };"
+
+  , testCase "pattern references undefined named pattern" $
+      assertHasError (isUndefined "Undefined")
+        "pattern Bad : Frame = Frame(_, IPv4(ip, Undefined));"
+
+  , testCase "pattern references known named pattern — no error" $
+      assertNoErrors
+        "pattern WGInit : (UDPHeader,Bytes) = (udp { length = 156 }, [0x01 _*]); \
+        \pattern Compound : Frame = Frame(_, IPv4(ip, WGInit));"
+
+  , testCase "flow references undefined pattern" $
+      assertHasError (isUndefined "Ghost")
+        "flow Bad : FlowPattern = Ghost;"
+
+  , testCase "flow references known pattern — no error" $
+      assertNoErrors
+        "pattern P : T = udp { length = 1 }; \
+        \flow F : FlowPattern = P;"
+
+  , testCase "policy guard references undeclared zone" $
+      -- 'unknown_zone' not declared; check should flag it
+      assertHasError (isUndefined "unknown_zone")
+        "policy fwd : Frame \
+        \  on { hook = Forward, table = Filter, priority = Filter } \
+        \  = { | Frame(iif in unknown_zone -> wan, _) -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+
+  , testCase "policy references known zone — no error" $
+      assertNoErrors
+        "interface lan : LAN {}; \
+        \zone trusted = { lan }; \
+        \policy fwd : Frame \
+        \  on { hook = Forward, table = Filter, priority = Filter } \
+        \  = { | Frame(iif in trusted -> wan, _) -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+  ]
+
+-- ─── Duplicate declaration tests ─────────────────────────────────────────────
+
+duplicateTests :: TestTree
+duplicateTests = testGroup "duplicates"
+  [ testCase "duplicate interface" $
+      assertHasError (isDuplicate "lan")
+        "interface lan : LAN {}; \
+        \interface lan : WAN {};"
+
+  , testCase "duplicate zone" $
+      assertHasError (isDuplicate "z")
+        "zone z = { a }; \
+        \zone z = { b };"
+
+  , testCase "duplicate pattern" $
+      assertHasError (isDuplicate "P")
+        "pattern P : T = udp { length = 1 }; \
+        \pattern P : T = udp { length = 2 };"
+
+  , testCase "duplicate policy" $
+      assertHasError (isDuplicate "input")
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; }; \
+        \policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+
+  , testCase "distinct names — no error" $
+      assertNoErrors
+        "interface lan : LAN {}; \
+        \interface wan : WAN { dynamic; }; \
+        \zone z = { lan };"
+  ]
+
+-- ─── Policy termination tests ────────────────────────────────────────────────
+
+policyTerminationTests :: TestTree
+policyTerminationTests = testGroup "policy termination"
+  [ testCase "last arm is Continue — error" $
+      assertHasError (isNoContinue "bad_policy")
+        "policy bad_policy : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Continue; };"
+
+  , testCase "last arm is Drop — ok" $
+      assertNoErrors
+        "policy good : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ if ct.state in { Established } -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+
+  , testCase "last arm is Allow — ok" $
+      assertNoErrors
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+
+  , testCase "Continue in non-last arm is fine" $
+      assertNoErrors
+        "rule r : Frame -> Action = \
+        \  \\f -> case f of { \
+        \    | Frame(_, IPv4(ip, _)) -> Continue; \
+        \    | _ -> Drop; \
+        \  };"
+
+  , testCase "empty policy body — error" $
+      assertHasError (isNoContinue "empty")
+        "policy empty : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = {};"
+  ]
+
+-- ─── Pattern cycle tests ─────────────────────────────────────────────────────
+
+patternCycleTests :: TestTree
+patternCycleTests = testGroup "pattern cycles"
+  [ testCase "direct self-reference — cycle error" $
+      assertHasError isCycle
+        "pattern Loop : T = Frame(_, Loop);"
+
+  , testCase "mutual cycle — cycle error" $
+      assertHasError isCycle
+        "pattern A : T = Frame(_, B); \
+        \pattern B : T = Frame(_, A);"
+
+  , testCase "linear chain — no cycle" $
+      assertNoErrors
+        "pattern Base : T = udp { length = 1 }; \
+        \pattern Mid  : T = Frame(_, Base); \
+        \pattern Top  : T = Frame(_, Mid);"
+  ]
+
+-- ─── Clean full programs ──────────────────────────────────────────────────────
+
+cleanProgramTests :: TestTree
+cleanProgramTests = testGroup "clean programs"
+  [ testCase "minimal router skeleton" $
+      assertNoErrors
+        "interface wan : WAN { dynamic; }; \
+        \interface lan : LAN { cidr4 = { 10.17.1.0/24 }; }; \
+        \interface wg0 : WireGuard {}; \
+        \zone lan_zone = { lan, wg0 }; \
+        \policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ if ct.state in { Established, Related } -> Allow; \
+        \      | _ -> Drop; \
+        \  }; \
+        \policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+
+  , testCase "pattern and flow declarations" $
+      assertNoErrors
+        "pattern WGInit : (UDPHeader,Bytes) = (udp { length = 156 }, [0x01 _*]); \
+        \pattern WGResp : (UDPHeader,Bytes) = (udp { length = 100 }, [0x02 _*]); \
+        \flow WGHandshake : FlowPattern = WGInit . WGResp within 5s;"
+  ]

test/CompileTests.hs

@@ -0,0 +1,384 @@
+{-# LANGUAGE OverloadedStrings #-}
+module CompileTests (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as AKM
+import qualified Data.Vector as V
+import qualified Data.ByteString.Lazy.Char8 as BL8
+
+import FWL.AST
+import FWL.Compile
+import FWL.Util
+
+tests :: TestTree
+tests = testGroup "Compile"
+  [ jsonStructureTests
+  , chainTests
+  , ruleExprTests
+  , verdictTests
+  , layerStrippingTests
+  , continueTests
+  , configTests
+  ]
+
+-- ─── Helpers ─────────────────────────────────────────────────────────────────
+
+compileToValue :: String -> IO A.Value
+compileToValue src = do
+  p <- parseOk src
+  case A.decode (compileToJson p) of
+    Nothing -> assertFailure "Compiled output is not valid JSON" >> undefined
+    Just v  -> return v
+
+-- Navigate a Value by a list of string keys / numeric indices.
+at :: [String] -> A.Value -> Maybe A.Value
+at []     v                   = Just v
+at (k:ks) (A.Object o)        =
+  case AKM.lookup (AK.fromString k) o of
+    Nothing -> Nothing
+    Just v  -> at ks v
+at (k:ks) (A.Array arr)       =
+  case reads k of
+    [(i,"")] | i < V.length arr -> at ks (arr V.! i)
+    _                           -> Nothing
+at _ _ = Nothing
+
+nftArr :: A.Value -> IO [A.Value]
+nftArr v =
+  case at ["nftables"] v of
+    Just (A.Array arr) -> return (V.toList arr)
+    _                  -> assertFailure "Missing top-level 'nftables' array" >> undefined
+
+withKey :: String -> [A.Value] -> [A.Value]
+withKey k = filter (\v -> case at [k] v of Just _ -> True; _ -> False)
+
+-- ─── JSON structure tests ────────────────────────────────────────────────────
+
+jsonStructureTests :: TestTree
+jsonStructureTests = testGroup "JSON structure"
+  [ testCase "output is valid JSON" $ do
+      _ <- compileToValue
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      return ()
+
+  , testCase "top-level nftables array present" $ do
+      v <- compileToValue "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      _ <- nftArr v
+      return ()
+
+  , testCase "metainfo is first element" $ do
+      v <- compileToValue "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case arr of
+        (first:_) -> case at ["metainfo"] first of
+          Just _  -> return ()
+          Nothing -> assertFailure "First element is not metainfo"
+        [] -> assertFailure "Empty nftables array"
+
+  , testCase "table object present" $ do
+      v <- compileToValue "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      assertBool "Expected at least one table object"
+        (not (null (withKey "table" arr)))
+
+  , testCase "default table name is fwl" $ do
+      v <- compileToValue "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case withKey "table" arr of
+        (t:_) -> at ["table","name"] t @?= Just (A.String "fwl")
+        []    -> assertFailure "No table object"
+
+  , testCase "custom table name respected" $ do
+      v <- compileToValue
+        "config { table = \"custom\"; } \
+        \policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case withKey "table" arr of
+        (t:_) -> at ["table","name"] t @?= Just (A.String "custom")
+        []    -> assertFailure "No table object"
+  ]
+
+-- ─── Chain declaration tests ─────────────────────────────────────────────────
+
+chainTests :: TestTree
+chainTests = testGroup "chain declarations"
+  [ testCase "filter input chain has correct hook" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","hook"] c @?= Just (A.String "input")
+        []    -> assertFailure "No chain"
+
+  , testCase "filter chain type is filter" $ do
+      v <- compileToValue
+        "policy fwd : Frame \
+        \  on { hook = Forward, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","type"] c @?= Just (A.String "filter")
+        []    -> assertFailure "No chain"
+
+  , testCase "NAT chain type is nat" $ do
+      v <- compileToValue
+        "policy nat_post : Frame \
+        \  on { hook = Postrouting, table = NAT, priority = SrcNat } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","type"] c @?= Just (A.String "nat")
+        []    -> assertFailure "No chain"
+
+  , testCase "input chain default policy is drop" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","policy"] c @?= Just (A.String "drop")
+        []    -> assertFailure "No chain"
+
+  , testCase "output chain default policy is accept" $ do
+      v <- compileToValue
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","policy"] c @?= Just (A.String "accept")
+        []    -> assertFailure "No chain"
+
+  , testCase "chain name matches policy name" $ do
+      v <- compileToValue
+        "policy my_input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      case withKey "chain" arr of
+        (c:_) -> at ["chain","name"] c @?= Just (A.String "my_input")
+        []    -> assertFailure "No chain"
+
+  , testCase "two policies produce two chains" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; }; \
+        \policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      length (withKey "chain" arr) @?= 2
+  ]
+
+-- ─── Rule expression tests ───────────────────────────────────────────────────
+
+ruleExprs :: [A.Value] -> [A.Value]
+ruleExprs arr =
+  [ e | r  <- withKey "rule" arr
+      , Just (A.Array es) <- [at ["rule","expr"] r]
+      , e  <- V.toList es ]
+
+ruleExprTests :: TestTree
+ruleExprTests = testGroup "rule expressions"
+  [ testCase "two arms produce two rules" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ if ct.state in { Established, Related } -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+      arr <- nftArr v
+      length (withKey "rule" arr) @?= 2
+
+  , testCase "arm without guard produces one rule" $ do
+      v <- compileToValue
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      length (withKey "rule" arr) @?= 1
+
+  , testCase "rule expr array is present" $ do
+      v <- compileToValue
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      case withKey "rule" arr of
+        (r:_) -> case at ["rule","expr"] r of
+          Just (A.Array _) -> return ()
+          _                -> assertFailure "Missing or non-array 'expr'"
+        [] -> assertFailure "No rule"
+
+  , testCase "IPv4 ctor emits nfproto match" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | Frame(_, IPv4(ip, _)) -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+      arr <- nftArr v
+      let matches   = withKey "match" (ruleExprs arr)
+          hasNfp    = any (\m ->
+            at ["match","left","meta","key"] m == Just (A.String "nfproto"))
+            matches
+      assertBool "Expected nfproto match for IPv4 ctor" hasNfp
+
+  , testCase "record field pat emits payload match" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | Frame(_, TCP(tcp { dport = :22 }, _)) -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+      arr <- nftArr v
+      let matches  = withKey "match" (ruleExprs arr)
+          hasPort  = any (\m ->
+            at ["match","right"] m == Just (A.String "22"))
+            matches
+      assertBool "Expected port 22 payload match" hasPort
+  ]
+
+-- ─── Verdict tests ───────────────────────────────────────────────────────────
+
+allExprs :: [A.Value] -> [A.Value]
+allExprs arr =
+  concatMap (\r -> case at ["rule","expr"] r of
+    Just (A.Array es) -> V.toList es; _ -> [])
+  (withKey "rule" arr)
+
+verdictTests :: TestTree
+verdictTests = testGroup "verdicts"
+  [ testCase "Allow compiles to accept" $ do
+      v <- compileToValue
+        "policy output : Frame \
+        \  on { hook = Output, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+      arr <- nftArr v
+      assertBool "Expected accept verdict"
+        (not (null (withKey "accept" (allExprs arr))))
+
+  , testCase "Drop compiles to drop" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      assertBool "Expected drop verdict"
+        (not (null (withKey "drop" (allExprs arr))))
+
+  , testCase "Masquerade compiles to masquerade" $ do
+      v <- compileToValue
+        "policy nat_post : Frame \
+        \  on { hook = Postrouting, table = NAT, priority = SrcNat } \
+        \  = { | _ -> Masquerade; };"
+      arr <- nftArr v
+      assertBool "Expected masquerade verdict"
+        (not (null (withKey "masquerade" (allExprs arr))))
+
+  , testCase "rule call compiles to jump" $ do
+      v <- compileToValue
+        "rule blockAll : Frame -> Action = \\f -> case f of { | _ -> Drop; }; \
+        \policy fwd : Frame \
+        \  on { hook = Forward, table = Filter, priority = Filter } \
+        \  = { | frame -> blockAll(frame); };"
+      arr <- nftArr v
+      assertBool "Expected jump verdict for rule call"
+        (not (null (withKey "jump" (allExprs arr))))
+  ]
+
+-- ─── Layer stripping tests ───────────────────────────────────────────────────
+
+layerStrippingTests :: TestTree
+layerStrippingTests = testGroup "layer stripping"
+  [ testCase "Frame with and without Ether both emit nfproto match" $ do
+      let withEther =
+            "policy p1 : Frame \
+            \  on { hook = Input, table = Filter, priority = Filter } \
+            \  = { | Frame(_, Ether(_, IPv4(ip, _))) -> Allow; \
+            \      | _ -> Drop; \
+            \  };"
+          withoutEther =
+            "policy p1 : Frame \
+            \  on { hook = Input, table = Filter, priority = Filter } \
+            \  = { | Frame(_, IPv4(ip, _)) -> Allow; \
+            \      | _ -> Drop; \
+            \  };"
+      v1 <- compileToValue withEther
+      v2 <- compileToValue withoutEther
+      arr1 <- nftArr v1
+      arr2 <- nftArr v2
+      let nfp arr = filter
+            (\m -> at ["match","left","meta","key"] m == Just (A.String "nfproto"))
+            (withKey "match" (ruleExprs arr))
+      assertBool "Both should produce nfproto matches"
+        (not (null (nfp arr1)) && not (null (nfp arr2)))
+  ]
+
+-- ─── Continue tests ───────────────────────────────────────────────────────────
+
+continueTests :: TestTree
+continueTests = testGroup "Continue"
+  [ testCase "two terminal arms produce two rules" $ do
+      v <- compileToValue
+        "policy fwd : Frame \
+        \  on { hook = Forward, table = Filter, priority = Filter } \
+        \  = { | _ if ct.state in { Established } -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+      arr <- nftArr v
+      length (withKey "rule" arr) @?= 2
+
+  , testCase "non-Continue arms still produce rules" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ if ct.state in { Established } -> Allow; \
+        \      | _ -> Drop; \
+        \  };"
+      arr <- nftArr v
+      assertBool "Should have rules for non-Continue arms"
+        (not (null (withKey "rule" arr)))
+  ]
+
+-- ─── Config tests ─────────────────────────────────────────────────────────────
+
+configTests :: TestTree
+configTests = testGroup "config"
+  [ testCase "all rule objects reference correct table" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      mapM_ (\r -> at ["rule","table"] r @?= Just (A.String "fwl"))
+        (withKey "rule" arr)
+
+  , testCase "chain objects reference correct table" $ do
+      v <- compileToValue
+        "policy input : Frame \
+        \  on { hook = Input, table = Filter, priority = Filter } \
+        \  = { | _ -> Drop; };"
+      arr <- nftArr v
+      mapM_ (\c -> at ["chain","table"] c @?= Just (A.String "fwl"))
+        (withKey "chain" arr)
+  ]

test/FWL/Util.hs

@@ -0,0 +1,44 @@
+-- | Shared test utilities.
+module FWL.Util where
+
+import Test.Tasty.HUnit
+import Text.Parsec.String (Parser)
+import Text.Parsec (parse)
+
+import FWL.Parser (parseProgram)
+import FWL.AST
+
+-- | Assert a parser succeeds and return the result.
+shouldParse :: (Show a) => Parser a -> String -> IO a
+shouldParse p input =
+  case parse p "<test>" input of
+    Left err -> assertFailure ("Unexpected parse error:\n" ++ show err)
+                >> undefined
+    Right v  -> return v
+
+-- | Assert a parser fails.
+shouldFailParse :: (Show a) => Parser a -> String -> IO ()
+shouldFailParse p input =
+  case parse p "<test>" input of
+    Left _  -> return ()
+    Right v -> assertFailure ("Expected parse failure but got: " ++ show v)
+
+-- | Parse a full program, asserting success.
+parseOk :: String -> IO Program
+parseOk src =
+  case parseProgram "<test>" src of
+    Left err -> assertFailure ("Parse error:\n" ++ show err) >> undefined
+    Right p  -> return p
+
+-- | Parse a full program, asserting failure.
+parseFail :: String -> IO ()
+parseFail src =
+  case parseProgram "<test>" src of
+    Left _  -> return ()
+    Right p -> assertFailure ("Expected parse failure, got:\n" ++ show p)
+
+-- | Extract the single declaration from a one-decl program.
+singleDecl :: Program -> IO Decl
+singleDecl (Program _ [d]) = return d
+singleDecl (Program _ ds)  =
+  assertFailure ("Expected 1 decl, got " ++ show (length ds)) >> undefined

test/ParserTests.hs

@@ -0,0 +1,516 @@
+module ParserTests (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import FWL.AST
+import FWL.Util
+
+tests :: TestTree
+tests = testGroup "Parser"
+  [ interfaceTests
+  , zoneTests
+  , importTests
+  , letTests
+  , patternTests
+  , flowTests
+  , typeTests
+  , exprTests
+  , policyTests
+  , ruleTests
+  , configTests
+  , errorTests
+  ]
+
+-- ─── Interface ───────────────────────────────────────────────────────────────
+
+interfaceTests :: TestTree
+interfaceTests = testGroup "interface"
+  [ testCase "WAN dynamic" $ do
+      p <- parseOk "interface wan : WAN { dynamic; };"
+      d <- singleDecl p
+      case d of
+        DInterface "wan" IWan [IPDynamic] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "LAN with cidr4" $ do
+      p <- parseOk "interface lan : LAN { cidr4 = { 10.0.0.0/8 }; };"
+      d <- singleDecl p
+      case d of
+        DInterface "lan" ILan [IPCidr4 [(LIPv4 (10,0,0,0), 8)]] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "LAN with cidr4 and cidr6" $ do
+      p <- parseOk
+            "interface lan : LAN { \
+            \  cidr4 = { 10.17.1.0/24 }; \
+            \  cidr6 = { 192.168.0.0/16 }; \
+            \};"
+      d <- singleDecl p
+      case d of
+        DInterface "lan" ILan [IPCidr4 _, IPCidr6 _] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "WireGuard interface" $ do
+      p <- parseOk "interface wg0 : WireGuard {};"
+      d <- singleDecl p
+      case d of
+        DInterface "wg0" IWireGuard [] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "user-defined kind" $ do
+      p <- parseOk "interface eth0 : Bridge {};"
+      d <- singleDecl p
+      case d of
+        DInterface "eth0" (IUser "Bridge") [] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "multiple CIDRs in set" $ do
+      p <- parseOk
+            "interface lan : LAN { \
+            \  cidr4 = { 10.0.0.0/8, 172.16.0.0/12, 192.168.0.0/16 }; \
+            \};"
+      d <- singleDecl p
+      case d of
+        DInterface _ _ [IPCidr4 cidrs] -> length cidrs @?= 3
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Zone ────────────────────────────────────────────────────────────────────
+
+zoneTests :: TestTree
+zoneTests = testGroup "zone"
+  [ testCase "single member" $ do
+      p <- parseOk "zone trusted = { lan };"
+      d <- singleDecl p
+      case d of
+        DZone "trusted" ["lan"] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "multiple members" $ do
+      p <- parseOk "zone lan_zone = { lan, wg0, vlan10 };"
+      d <- singleDecl p
+      case d of
+        DZone "lan_zone" ["lan","wg0","vlan10"] -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Import ──────────────────────────────────────────────────────────────────
+
+importTests :: TestTree
+importTests = testGroup "import"
+  [ testCase "basic import" $ do
+      p <- parseOk "import rfc1918 : CIDRSet from \"builtin:rfc1918\";"
+      d <- singleDecl p
+      case d of
+        DImport "rfc1918" (TName "CIDRSet" []) "builtin:rfc1918" -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Let ─────────────────────────────────────────────────────────────────────
+
+letTests :: TestTree
+letTests = testGroup "let"
+  [ testCase "simple integer" $ do
+      p <- parseOk "let timeout : Int = 30;"
+      d <- singleDecl p
+      case d of
+        DLet "timeout" (TName "Int" []) (ELit (LInt 30)) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "map literal" $ do
+      p <- parseOk
+            "let forwards : Map<(Protocol,Port),(IP,Port)> = { \
+            \  (tcp, :8080) -> (10.0.0.1, :80) \
+            \};"
+      d <- singleDecl p
+      case d of
+        DLet "forwards" _ (EMap [_]) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "string literal" $ do
+      p <- parseOk "let name : String = \"hello\";"
+      d <- singleDecl p
+      case d of
+        DLet "name" _ (ELit (LString "hello")) -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Pattern ─────────────────────────────────────────────────────────────────
+
+patternTests :: TestTree
+patternTests = testGroup "pattern"
+  [ testCase "tuple with record field" $ do
+      p <- parseOk
+            "pattern WGInitiation : (UDPHeader, Bytes) = \
+            \  (udp { length = 156 }, [0x01 _*]);"
+      d <- singleDecl p
+      case d of
+        DPattern "WGInitiation" _ (PTuple [PRecord "udp" _, PBytes _]) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "byte pattern elements" $ do
+      p <- parseOk
+            "pattern WGResponse : (UDPHeader, Bytes) = \
+            \  (udp { length = 100 }, [0x02 _ _*]);"
+      d <- singleDecl p
+      case d of
+        DPattern "WGResponse" _ (PTuple [_, PBytes [BEHex 0x02, BEWild, BEWildStar]]) ->
+          return ()
+        _ -> assertFailure (show d)
+
+  , testCase "named pattern reference in ctor" $ do
+      p <- parseOk
+            "pattern Complex : Frame = \
+            \  Frame(_, IPv4(ip, WGInitiation));"
+      d <- singleDecl p
+      case d of
+        DPattern "Complex" _ (PFrame Nothing (PCtor "IPv4" [PVar "ip", PNamed "WGInitiation"])) ->
+          return ()
+        _ -> assertFailure (show d)
+
+  , testCase "record with field bind" $ do
+      p <- parseOk "pattern HasTCP : TCP = tcp { dport };"
+      d <- singleDecl p
+      case d of
+        DPattern "HasTCP" _ (PRecord "tcp" [FPBind "dport"]) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "record with field equality" $ do
+      p <- parseOk "pattern SSH : TCP = tcp { dport = :22 };"
+      d <- singleDecl p
+      case d of
+        DPattern "SSH" _ (PRecord "tcp" [FPEq "dport" (LPort 22)]) -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Flow ────────────────────────────────────────────────────────────────────
+
+flowTests :: TestTree
+flowTests = testGroup "flow"
+  [ testCase "two-step sequence with within" $ do
+      p <- parseOk
+            "flow WireGuardHandshake : FlowPattern = \
+            \  WGInitiation . WGResponse within 5s;"
+      d <- singleDecl p
+      case d of
+        DFlow "WireGuardHandshake" (FSeq (FAtom "WGInitiation") (FAtom "WGResponse") (Just (5, Seconds))) ->
+          return ()
+        _ -> assertFailure (show d)
+
+  , testCase "single atom flow" $ do
+      p <- parseOk "flow Simple : FlowPattern = Ping;"
+      d <- singleDecl p
+      case d of
+        DFlow "Simple" (FAtom "Ping") -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "duration in milliseconds" $ do
+      p <- parseOk "flow Fast : FlowPattern = A . B within 500ms;"
+      d <- singleDecl p
+      case d of
+        DFlow "Fast" (FSeq _ _ (Just (500, Millis))) -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Types ───────────────────────────────────────────────────────────────────
+
+typeTests :: TestTree
+typeTests = testGroup "types"
+  [ testCase "simple name" $ do
+      p <- parseOk "let x : Frame = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TName "Frame" []) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "generic type" $ do
+      p <- parseOk "let x : Map<Int, String> = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TName "Map" [TName "Int" [], TName "String" []]) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "function type" $ do
+      p <- parseOk "let x : Frame -> Action = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TFun (TName "Frame" []) (TName "Action" [])) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "effect type" $ do
+      p <- parseOk "let x : <Log, FlowMatch> Action = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TEffect ["Log","FlowMatch"] (TName "Action" [])) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "tuple type" $ do
+      p <- parseOk "let x : (Int, String) = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TTuple [TName "Int" [], TName "String" []]) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "function with effects" $ do
+      p <- parseOk "let x : Frame -> <Log> Action = Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ (TFun _ (TEffect ["Log"] _)) _ -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Expressions ─────────────────────────────────────────────────────────────
+
+exprTests :: TestTree
+exprTests = testGroup "expressions"
+  [ testCase "boolean and" $ do
+      p <- parseOk "let x : Bool = a && b;"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EInfix OpAnd (EVar "a") (EVar "b")) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "set membership with 'in'" $ do
+      p <- parseOk "let x : Bool = ct.state in { Established, Related };"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EInfix OpIn (EQual ["ct","state"]) (ESet _)) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "equality comparison" $ do
+      p <- parseOk "let x : Bool = tcp.dport == :22;"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EInfix OpEq (EQual ["tcp","dport"]) (ELit (LPort 22))) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "if-then-else" $ do
+      p <- parseOk "let x : Action = if a then Allow else Drop;"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EIf (EVar "a") (EVar "Allow") (EVar "Drop")) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "perform expression" $ do
+      p <- parseOk "let x : Action = perform Log.emit(Info, \"msg\");"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EPerform ["Log","emit"] [ELit (LString "Info"), ELit (LString "msg")]) -> return ()
+        DLet _ _ (EPerform ["Log","emit"] _) -> return ()  -- arg parsing flexible
+        _ -> assertFailure (show d)
+
+  , testCase "do block" $ do
+      p <- parseOk "let x : Action = do { y <- foo; y };"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EDo [DSBind "y" _, DSExpr (EVar "y")]) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "nested case" $ do
+      p <- parseOk
+            "let x : Action = case e of { \
+            \  | a -> Allow; \
+            \  | _ -> Drop; \
+            \};"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (ECase (EVar "e") [Arm (PVar "a") Nothing _, Arm PWild Nothing _]) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "lambda" $ do
+      p <- parseOk "let x : Frame -> Action = \\frame -> Allow;"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (ELam "frame" (EVar "Allow")) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "string concat" $ do
+      p <- parseOk "let x : String = \"hello\" ++ \" world\";"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (EInfix OpConcat _ _) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "negation" $ do
+      p <- parseOk "let x : Bool = !flag;"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (ENot (EVar "flag")) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "set literal" $ do
+      p <- parseOk "let x : Set<Int> = { 22, 80, 443 };"
+      d <- singleDecl p
+      case d of
+        DLet _ _ (ESet [ELit (LInt 22), ELit (LInt 80), ELit (LInt 443)]) -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Policy ──────────────────────────────────────────────────────────────────
+
+policyTests :: TestTree
+policyTests = testGroup "policy"
+  [ testCase "minimal policy" $ do
+      p <- parseOk
+            "policy output : Frame \
+            \  on { hook = Output, table = Filter, priority = Filter } \
+            \  = { | _ -> Allow; };"
+      d <- singleDecl p
+      case d of
+        DPolicy "output" _ (PolicyMeta HOutput TFilter (Priority 0)) [_] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "NAT prerouting" $ do
+      p <- parseOk
+            "policy nat_pre : Frame \
+            \  on { hook = Prerouting, table = NAT, priority = DstNat } \
+            \  = { | _ -> Allow; };"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ (PolicyMeta HPrerouting TNAT (Priority (-100))) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "arm with guard" $ do
+      p <- parseOk
+            "policy input : Frame \
+            \  on { hook = Input, table = Filter, priority = Filter } \
+            \  = { \
+            \    | _ if ct.state in { Established, Related } -> Allow; \
+            \    | _ -> Drop; \
+            \  };"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ _ [Arm PWild (Just _) _, Arm PWild Nothing _] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "Frame pattern with path" $ do
+      p <- parseOk
+            "policy forward : Frame \
+            \  on { hook = Forward, table = Filter, priority = Filter } \
+            \  = { \
+            \    | Frame(iif in lan_zone -> wan, _) -> Allow; \
+            \    | _ -> Drop; \
+            \  };"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ _ (Arm (PFrame (Just _) _) Nothing _ : _) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "Frame pattern without Ether (layer stripping)" $ do
+      p <- parseOk
+            "policy input : Frame \
+            \  on { hook = Input, table = Filter, priority = Filter } \
+            \  = { \
+            \    | Frame(_, IPv4(ip, TCP(tcp, _))) if tcp.dport == :22 -> Allow; \
+            \    | _ -> Drop; \
+            \  };"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ _ (Arm (PFrame Nothing (PCtor "IPv4" _)) _ _ : _) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "policy arm calls rule" $ do
+      p <- parseOk
+            "policy forward : Frame \
+            \  on { hook = Forward, table = Filter, priority = Filter } \
+            \  = { \
+            \    | frame -> blockOutboundWG(frame); \
+            \  };"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ _ [Arm (PVar "frame") Nothing (EApp (EVar "blockOutboundWG") _)] ->
+          return ()
+        _ -> assertFailure (show d)
+
+  , testCase "Continue arm is parsed" $ do
+      p <- parseOk
+            "rule r : Frame -> Action = \
+            \  \\frame -> case frame of { \
+            \    | _ -> Continue; \
+            \  };"
+      d <- singleDecl p
+      case d of
+        DRule _ _ _ -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Rule ────────────────────────────────────────────────────────────────────
+
+ruleTests :: TestTree
+ruleTests = testGroup "rule"
+  [ testCase "simple rule" $ do
+      p <- parseOk
+            "rule blockAll : Frame -> Action = \
+            \  \\frame -> case frame of { | _ -> Drop; };"
+      d <- singleDecl p
+      case d of
+        DRule "blockAll" _ (ELam "frame" (ECase _ _)) -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "rule with effects in type" $ do
+      p <- parseOk
+            "rule logged : Frame -> <Log> Action = \
+            \  \\f -> case f of { | _ -> Allow; };"
+      d <- singleDecl p
+      case d of
+        DRule "logged" (TFun _ (TEffect ["Log"] _)) _ -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "nested case in rule" $ do
+      p <- parseOk
+            "rule check : Frame -> <FlowMatch> Action = \
+            \  \\frame -> \
+            \    case frame of { \
+            \      | Frame(_, IPv4(ip, UDP(udp, _))) -> \
+            \          case perform FlowMatch.check(ip, wg) of { \
+            \            | Matched -> Drop; \
+            \            | _ -> Continue; \
+            \          }; \
+            \      | _ -> Continue; \
+            \    };"
+      d <- singleDecl p
+      case d of
+        DRule "check" _ (ELam _ (ECase _ _)) -> return ()
+        _ -> assertFailure (show d)
+  ]
+
+-- ─── Config ──────────────────────────────────────────────────────────────────
+
+configTests :: TestTree
+configTests = testGroup "config"
+  [ testCase "default table name" $ do
+      p <- parseOk "interface wan : WAN {};"
+      configTable (progConfig p) @?= "fwl"
+
+  , testCase "custom table name" $ do
+      p <- parseOk "config { table = \"myrules\"; } interface wan : WAN {};"
+      configTable (progConfig p) @?= "myrules"
+  ]
+
+-- ─── Error cases ─────────────────────────────────────────────────────────────
+
+errorTests :: TestTree
+errorTests = testGroup "parse errors"
+  [ testCase "missing semicolon" $
+      parseFail "interface wan : WAN {}"
+
+  , testCase "unknown hook" $
+      parseFail
+        "policy p : Frame \
+        \  on { hook = Bogus, table = Filter, priority = Filter } \
+        \  = { | _ -> Allow; };"
+
+  , testCase "empty arm block with no arms is ok" $ do
+      p <- parseOk
+            "policy output : Frame \
+            \  on { hook = Output, table = Filter, priority = Filter } \
+            \  = {};"
+      d <- singleDecl p
+      case d of
+        DPolicy _ _ _ [] -> return ()
+        _ -> assertFailure (show d)
+
+  , testCase "CIDR without prefix fails" $
+      parseFail "interface lan : LAN { cidr4 = { 10.0.0.1 }; };"
+  ]

test/Spec.hs

@@ -0,0 +1,15 @@
+module Main where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified ParserTests
+import qualified CheckTests
+import qualified CompileTests
+
+main :: IO ()
+main = defaultMain $ testGroup "FWL"
+  [ ParserTests.tests
+  , CheckTests.tests
+  , CompileTests.tests
+  ]