v2 perplexed
This commit is contained in:
384
test/CompileTests.hs
Normal file
384
test/CompileTests.hs
Normal file
@@ -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)
|
||||
]
|
||||
Reference in New Issue
Block a user