iptables-helpers (empty) → 0.3
raw patch · 7 files changed
+1118/−0 lines, 7 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, parsec, safe
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- iptables-helpers.cabal +32/−0
- src/Iptables.hs +257/−0
- src/Iptables/Parser.hs +418/−0
- src/Iptables/Print.hs +216/−0
- src/Iptables/Types.hs +163/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Evgeny Tarasov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Evgeny Tarasov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ iptables-helpers.cabal view
@@ -0,0 +1,32 @@+Name: iptables-helpers+Version: 0.3+Synopsis: Static checking of iptables rules+License: BSD3+License-file: LICENSE+Author: Evgeny Tarasov+Maintainer: etarasov.ekb@gmail.com+Category: Text+Build-type: Simple++Cabal-version: >=1.2+++Library+ Exposed-modules:+ Iptables+ Iptables.Parser+ Iptables.Print+ Iptables.Types+ + Build-depends:+ base >=4 && <5,+ parsec >= 2.1,+ mtl >= 1.1,+ safe >= 0.3,+ containers >= 0.3 && < 0.4+ + -- Other-modules: + + Hs-Source-Dirs: src ++ Ghc-options: -Wall -fno-warn-unused-do-bind
+ src/Iptables.hs view
@@ -0,0 +1,257 @@+module Iptables where++import Data.List hiding (insert)+import Data.Maybe+import Data.Set hiding (map, filter, null)+import Iptables.Types+import Control.Monad+import Control.Monad.State++{- | Список необходимых модулей для опций+ - --dport не требует -m tcp+ - -p tcp требует -m tcp+ - проверка на зависимость --dport от -p проверяется в другом месте+ -}+optionDepends :: RuleOption -> [Module]+optionDepends (OProtocol True "tcp") = [ModTcp]+optionDepends (OProtocol True "udp") = [ModUdp]+optionDepends (OState _) = [ModState]+optionDepends (OComment _) = [ModComment]+optionDepends _ = []++{- Пользовательские цепочки могут быть залупленные.+ - Проверка на залупляемость производится только при добавлении ссылки во встраиваемые цепочки+ -+ - Определение типа цепочки:+ - Если в состоянии есть уже это имя, то произошло залупливание, возвращаем NatInvalidChain+ - Если встроенное имя, то тип, соответствующий этому имени+ - Если есть противоречащие правила, то NatInvalidChain+ - Если есть хотя бы одно правило, то тип, относящийся к этому правилу+ - Добавляем своё имя в состояние (множество имён)+ - Ищем ссылку на правило (возвращаемое значение Maybe тип цепочки)+ - Если рез-тат Just a, то a+ - Если Nothing, то NatUnknownChain+ -}++-- Поиск цепочки впереди для предотвращения направленных циклов+findChainForward :: String -> [Chain] -> String -> Bool+findChainForward chainToFind chains currentChain =+ if chainToFind == currentChain+ then True+ else+ let chain = fromJust $ getChainByName currentChain chains+ linkingChains = scanChainForLinks chain+ resL = map (findChainForward chainToFind chains) linkingChains+ in+ or resL++type ChainNames = Set String++-- Один полный проход вперёд c поиском циклов+guessFilterChainType :: String -> [Chain] -> FilterChainType+guessFilterChainType chainName chains =+ let (_, (_, chainType)) = runState (traverseForward chains chainName) (empty, FilterValidChain)+ in chainType++ where+ traverseForward :: [Chain] -> String -> State (ChainNames, FilterChainType) ()+ traverseForward chains' chainName' = do+ (names, chainType) <- get+ let test1 = if chainName' `member` names+ then Just FilterInvalidChain+ else Nothing+ case test1 of+ Just _ -> put (empty, FilterInvalidChain)+ Nothing -> do+ put (insert chainName' names, chainType)+ let linkingChains = scanChainForLinks $ fromJust $ getChainByName chainName' chains'+ mapM_ (traverseForward chains') linkingChains++-- Один полный проход назад, один вперёд+guessNatChainType :: String -> [Chain] -> NatChainType+guessNatChainType chainName chains =+ let (_, (_, types)) = runState ( do+ traverseForward chains chainName+ (_, types') <- get+ put (empty, types')+ traverseBackward chains chainName+ ) (empty, empty)+ in if NatInvalidChain `member` types+ then NatInvalidChain+ else if NatDNatChain `member` types && NatSNatChain `member` types+ then NatInvalidChain+ else if NatDNatChain `member` types+ then NatDNatChain+ else if NatSNatChain `member` types+ then NatSNatChain+ else NatUnknownChain++ where+ traverseForward :: [Chain] -> String -> State (ChainNames, Set NatChainType) ()+ traverseForward chains' chainName' = do+ processChain chains' chainName'+ -- dangerous place - fromJust+ let linkingChains = scanChainForLinks $ fromJust $ getChainByName chainName' chains'+ mapM_ (traverseForward chains') linkingChains++ traverseBackward :: [Chain] -> String -> State (ChainNames, Set NatChainType) ()+ traverseBackward chains' chainName' = do+ processChain chains' chainName'+ let linkingChains = scanTableForLink chainName' chains'+ mapM_ (traverseBackward chains') linkingChains++ processChain :: [Chain] -> String -> State (ChainNames, Set NatChainType) ()+ processChain chains' chainName' = do+ (names, types) <- get+ let test1 = if chainName' `member` names+ then Just NatInvalidChain+ else Nothing+ let test2 = case chainName' of+ "PREROUTING" -> Just NatDNatChain+ "POSTROUTING" -> Just NatSNatChain+ "OUTPUT" -> Just NatDNatChain+ _ -> Nothing+ let chain = fromJust $ getChainByName chainName' chains'+ let snatTarget = hasChainSNatTarget $ cRules chain+ let dnatTarget = hasChainDNatTarget $ cRules chain+ let test3 = if snatTarget && dnatTarget+ then Just NatInvalidChain+ else Nothing+ let test4 = if snatTarget+ then Just NatSNatChain+ else Nothing+ let test5 = if dnatTarget+ then Just NatDNatChain+ else Nothing+ {- actually perform tests+ - msum returns first success or Nothing+ -}+ let resMay = msum [test1, test2, test3, test4, test5]+ case resMay of+ Just chainType -> put (names, insert chainType types)+ Nothing -> return ()++ {- Chain type can't be determined by itself+ - try to analyse its callers if they exists+ -}+ (names', types') <- get+ put (insert chainName' names', types')++-- Возвращает список цепочек, которые ссылаются на заданную именем пользовательскую цепочку+scanTableForLink :: String -> [Chain] -> [String]+scanTableForLink chainName chains =+ let resMayL = map (scanChainForLink chainName) chains+ in catMaybes resMayL++ where+ scanChainForLink :: String -- ^ name of user defined chain+ -> Chain -- ^ chain to scan for a link+ -> Maybe String -- ^ name of chain containing link+ scanChainForLink name (Chain n _ _ rs) =+ if scanChainForLink' name rs then Just n+ else Nothing+ where++ scanChainForLink' :: String -> [Rule] -> Bool+ scanChainForLink' _ [] = False+ scanChainForLink' chainName' (r : rs') =+ if TUChain chainName' == rTarget r+ then True+ else scanChainForLink' chainName' rs'++scanChainForLinks :: Chain -> [String]+scanChainForLinks (Chain _ _ _ rs) =+ scanRulesForLinks rs+ where+ scanRulesForLinks :: [Rule] -> [String]+ scanRulesForLinks [] = []+ scanRulesForLinks (Rule _ (TUChain chainName) : rs') = chainName : scanRulesForLinks rs'+ scanRulesForLinks (_ : rs') = scanRulesForLinks rs'++getChainByName :: String -> [Chain] -> Maybe Chain+getChainByName _ [] = Nothing+getChainByName chainName (Chain n p cs rs : xs) | chainName == n = Just $ Chain n p cs rs+ | otherwise = getChainByName chainName xs++hasChainSNatTarget :: [Rule] -> Bool+hasChainSNatTarget [] = False+hasChainSNatTarget (Rule _ (TMasquerade _ _) : _) = True+hasChainSNatTarget (Rule _ (TSNat _ _ _) : _) = True+hasChainSNatTarget (_ : xs) = hasChainSNatTarget xs++hasChainDNatTarget :: [Rule] -> Bool+hasChainDNatTarget [] = False+hasChainDNatTarget (Rule _ (TDNat _ _ _) : _) = True+hasChainDNatTarget (Rule _ (TRedirect _ _) : _) = True+hasChainDNatTarget (_ : xs) = hasChainDNatTarget xs++isFilterBuiltinChain :: String -> Bool+isFilterBuiltinChain chain =+ case chain of+ "INPUT" -> True+ "FORWARD" -> True+ "OUTPUT" -> True+ _ -> False++isNatBuiltinChain :: String -> Bool+isNatBuiltinChain chain =+ case chain of+ "PREROUTING" -> True+ "POSTROUTING" -> True+ "OUTPUT" -> True+ _ -> False++isMangleBuiltinChain :: String -> Bool+isMangleBuiltinChain chain =+ case chain of+ "INPUT" -> True+ "PREROUTING" -> True+ "FORWARD" -> True+ "POSTROUTING" -> True+ "OUTPUT" -> True+ _ -> False++isFilterType :: FilterChainType -- ^ Type to test+ -> [Chain] -- ^ Filter table+ -> String -- ^ The chain name+ -> Bool+isFilterType chainType table chain =+ let chainType' = guessFilterChainType chain table+ in chainType == chainType'++isNatType :: NatChainType -- ^ Type to test+ -> [Chain] -- ^ Nat table+ -> String -- ^ The chain name+ -> Bool+isNatType chainType table chain =+ let chainType' = guessNatChainType chain table+ in chainType == chainType'++sortFilterTable :: [Chain] -> [Chain]+sortFilterTable table =+ let userChains = filter (not . isFilterBuiltinChain . cName) table+ in+ filter (("INPUT" ==) . cName) table+ ++ filter (("FORWARD" ==) . cName) table+ ++ filter (("OUTPUT" ==) . cName) table+ ++ sortBy (\ c1 c2 -> compare (cName c1) (cName c2)) userChains++sortNatTable :: [Chain] -> [Chain]+sortNatTable table =+ let userChains = filter (not . isNatBuiltinChain . cName) table+ in+ filter (("PREROUTING" ==) . cName) table+ ++ filter (("POSTROUTING" ==) . cName) table+ ++ filter (("OUTPUT" ==) . cName) table+ ++ sortBy (\ c1 c2 -> compare (cName c1) (cName c2)) userChains++sortMangleTable :: [Chain] -> [Chain]+sortMangleTable table =+ let userChains = filter (not . isMangleBuiltinChain . cName) table+ in+ filter (("INPUT" ==) . cName) table+ ++ filter (("PREROUTING" ==) . cName) table+ ++ filter (("FORWARD" ==) . cName) table+ ++ filter (("POSTROUTING" ==) . cName) table+ ++ filter (("OUTPUT" ==) . cName) table+ ++ sortBy (\ c1 c2 -> compare (cName c1) (cName c2)) userChains
+ src/Iptables/Parser.hs view
@@ -0,0 +1,418 @@++module Iptables.Parser where++import Iptables.Types+import Control.Applicative ((<$>))+import Control.Monad.Error+import Data.Bits+import Data.Set (fromList)+import Data.Word+import Safe+import Text.ParserCombinators.Parsec++removeComments :: String -> String+removeComments input = unlines $ map removeComment $ lines input+ where+ removeComment :: String -> String+ removeComment ('#' : _) = ""+ removeComment a = a++parseIptables :: String -> Either ParseError Iptables+parseIptables = runParser iptables [] "input" . removeComments+ where+ iptables :: GenParser Char [Chain] Iptables+ iptables = do+ spaces+ tables <- many table+ let filterL = filter (isTable "filter") tables+ let filter' = headDef [] $ map snd filterL+ let natL = filter (isTable "nat") tables+ let nat = headDef [] $ map snd natL+ let mangleL = filter (isTable "mangle") tables+ let mangle = headDef [] $ map snd mangleL+ let rawL = filter (isTable "raw") tables+ let raw = headDef [] $ map snd rawL+ return $ Iptables filter' nat mangle raw++ where+ isTable :: String -> (String, a) -> Bool+ isTable n1 (n2, _) | n1 == n2 = True+ | otherwise = False++ table :: GenParser Char [Chain] (String, [Chain])+ table = do+ many comment+ spaces+ char '*'+ tableName <- many1 letter+ when (tableName /= "filter" && tableName /= "nat" && tableName /= "mangle" && tableName /= "raw") $+ unexpected $ "table " ++ tableName ++ " is invalid"+ spaces+ chains_ <- chains+ spaces+ string "COMMIT"+ spaces+ return (tableName, chains_)++ comment :: GenParser Char [Chain] ()+ comment = char '#' >> manyTill anyChar (try (oneOf "\n\r")) >> spaces >> return ()++ chains :: GenParser Char [Chain] [Chain]+ chains = do+ -- chainDescrp and rule parsers put their output into state+ many chainDescr >> many rule+ res <- getState+ setState []+ return res++ chainDescr :: GenParser Char [Chain] ()+ chainDescr = do+ char ':'+ chainName <- many1 (alphaNum <|> char '-')+ spaces+ chainPolicyRaw <- many1 (letter <|> char '-')+ chainPolicy <- case chainPolicyRaw of+ "ACCEPT" -> return ACCEPT+ "DROP" -> return DROP+ "-" -> return PUNDEFINED+ a -> unexpected $ "unknown policy " ++ a+ spaces+ char '['+ c1 <- many1 digit+ char ':'+ c2 <- many1 digit+ char ']'+ spaces+ st <- getState+ -- TODO: parse counters properly+ setState $ Chain chainName chainPolicy (Counters (read c1) (read c2)) [] : st++ rule :: GenParser Char [Chain] ()+ rule = do+ string "-A"+ spaces+ chainName <- many1 (alphaNum <|> char '-')+ spaces+ matches <- many ruleOption+ string "-j"+ spaces+ target <- ruleTarget+ {- Skip unknown parameters+ - TODO: process all kinds of parameters+ -}+ many (noneOf "\n")+ spaces+ st <- getState+ let rule_ = Rule matches target+ let newState = addRuleToChain st chainName rule_+ setState newState++ -- Add rule into its chain+ where+ addRuleToChain :: [Chain] -> String -> Rule -> [Chain]+ addRuleToChain [] _ _ = []+ addRuleToChain (Chain n p c rs : xs) chName rule_ =+ if n == chName then+ Chain n p c (rs ++ [rule_]) : xs+ else+ Chain n p c rs : addRuleToChain xs chName rule_++ ruleOption :: GenParser Char [Chain] RuleOption+ ruleOption =+ choice [ oProtocol, oSource, oDest, oInput, oOutput, oModule, oSrcPort, oDstPort, oState+ , oPhysDevIsBridged, oUnknown]+ where+ oProtocol = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "-p") <|> string "--protocol"+ char ' '+ protocol <- many1 (letter <|> char '-')+ char ' '+ return $ OProtocol bool_ protocol++ oSource = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "-s") <|> try (string "--src") <|> string "--source"+ char ' '+ address <- ipAddressParser+ char ' '+ return $ OSource bool_ address++ oDest = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "-d") <|> try (string "--dst") <|> string "--destination"+ char ' '+ address <- ipAddressParser+ char ' '+ return $ ODest bool_ address++ oInput = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "-i") <|> string "--in-interface"+ char ' '+ interf <- interfaceParser+ char ' '+ return $ OInInt bool_ $ Interface interf++ oOutput = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "-o") <|> string "--out-interface"+ char ' '+ interf <- interfaceParser+ char ' '+ return $ OOutInt bool_ $ Interface interf++ oModule = try $ do+ try (string "-m") <|> string "--match"+ char ' '+ mod_ <- many1 alphaNum+ char ' '+ case mod_ of+ "tcp" -> return $ OModule ModTcp+ "udp" -> return $ OModule ModUdp+ "state" -> return $ OModule ModState+ "physdev" -> return $ OModule ModPhysDev+ a -> fail $ "unknown module: " ++ a++ oSrcPort = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "--sport") <|> string "--source-port"+ char ' '+ port <- ipPortParser+ char ' '+ return $ OSourcePort bool_ port++ oDstPort = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ try (string "--dport") <|> string "--destination-port"+ char ' '+ port <- ipPortParser+ char ' '+ return $ ODestPort bool_ port++ oState = try $ do+ -- bool_ <- option True (char '!' >> char ' ' >> return False)+ string "--state"+ char ' '+ statesS <- sepBy (many1 alphaNum) $ char ','+ let parseState "INVALID" = return CStInvalid+ parseState "ESTABLISHED" = return CStEstablished+ parseState "RELATED" = return CStRelated+ parseState "NEW" = return CStNew+ parseState "UNTRACKED" = return CStUntracked+ parseState a = fail $ "There is no state " ++ a+ states <- mapM parseState statesS+ char ' '+ return $ OState $ fromList states++ oPhysDevIsBridged = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ string "--physdev-is-bridged"+ char ' '+ return $ OPhysDevIsBridged bool_++ oUnknown = try $ do+ bool_ <- option True (char '!' >> char ' ' >> return False)+ oN <- char '-'+ ame <- many1 (alphaNum <|> char '-')+ when (oN:ame == "-j") $+ fail "Option list is over"+ -- Option parameters - all words before next option+ oParams <- fmap words $ manyTill anyChar (try $ lookAhead $ string " -")+ char ' '+ return $ OUnknown (oN:ame) bool_ oParams++ ruleTarget :: GenParser Char [Chain] RuleTarget+ ruleTarget =+ choice [rAccept, rDrop, rMasquerade, rRedirect, rReject, rSNat, rDNat, rUChain, rUnknown]+ where+ rAccept = do+ try $ string "ACCEPT"+ return TAccept++ rDrop = do+ try $ string "DROP"+ return TDrop++ rMasquerade = do+ try $ string "MASQUERADE"+ ports <- option NatPortDefault (try (string " --to-ports ") >> natPortParser)+ rand <- option False (try (char ' ' >> string "--random") >> return True)+ return $ TMasquerade ports rand++ rRedirect = do+ try $ string "REDIRECT"+ ports <- option NatPortDefault (try (string " --to-ports ") >> natPortParser)+ rand <- option False (try (char ' ' >> string "--random") >> return True)+ return $ TRedirect ports rand++ rReject = do+ try $ string "REJECT"+ rejectWith <- option RTPortUnreachable (try (string " --reject-with ") >> rejectTypeParser)+ return $ TReject rejectWith++ rSNat = try $ do+ string "SNAT"+ char ' '+ string "--to-source"+ char ' '+ addr <- natAddrParser+ rand <- option False (try (char ' ' >> string "--random") >> return True)+ persist <- option False (try (char ' ' >> string "--persistent") >> return True)+ return $ TSNat addr rand persist++ rDNat = try $ do+ string "DNAT"+ char ' '+ string "--to-destination"+ char ' '+ addr <- natAddrParser+ rand <- option False (try (char ' ' >> string "--random") >> return True)+ persist <- option False (try (char ' ' >> string "--persistent") >> return True)+ return $ TDNat addr rand persist++ rUChain = try $ do+ chainName <- many1 (alphaNum <|> char '-')+ chains_ <- getState+ when (not $ chainName `elem` map cName chains_) $+ fail $ chainName ++ " is not name of real chain"+ return $ TUChain chainName++ rUnknown = do+ targetName <- many1 (alphaNum <|> char '-')+ opts <- option [] (char ' ' >> fmap words (many $ noneOf "\n"))+ return $ TUnknown targetName opts++-- TODO: move checks to ipAddrTyple function+ipMask :: GenParser Char st Addr+ipMask = do+ ip <- ipAddr+ char '/'+ mask <- ipAddr+ return $ AddrMask ip mask++ipPref :: GenParser Char st Addr+ipPref = do+ ip <- ipAddr+ char '/'+ prefS <- many1 (digit <?> "")+ let pref = read prefS+ when (pref > 32 || pref < 0) $+ fail "ip prefix >=0 && <= 32"+ return $ AddrPref ip pref++ipAddr :: GenParser Char st Word32+ipAddr = do+ as <- many1 (digit <?> "")+ let a = read as+ when (a > 255) $ fail "ip addr octet >= 0 && < 256"+ char '.'+ bs <- many1 (digit <?> "")+ let b = read bs+ when (b > 255) $ fail "ip addr octet >= 0 && < 256"+ char '.'+ cs <- many1 (digit <?> "")+ let c = read cs+ when (c > 255) $ fail "ip addr octet >= 0 && < 256"+ char '.'+ ds <- many1 (digit <?> "")+ let d = read ds+ when (d > 255) $ fail "ip addr octet >= 0 && < 256"+ return $ shiftL a 24 + shiftL b 16 + shiftL c 8 + d++ipAddressParser :: GenParser Char st Addr+ipAddressParser = try (ipMask <?> "ip address with mask")+ <|> try (ipPref <?> "ip address with prefix")+ <|> ((AddrIP <$> ipAddr) <?> "ip address")++checkPort :: Int -> GenParser Char st ()+checkPort a =+ when ( a < 0 || a > 65535) $+ fail "port >= 0 && <= 65535"++checkPortRange :: Int -> Int -> GenParser Char st ()+checkPortRange p1 p2 =+ when ( p2 < p1 ) $+ fail "invalid port range"+{- 22:80+ - :80+ - 80:+ -}+ipPortRange :: GenParser Char st Port+ipPortRange = do+ start <- option 0 (fmap read $ many1 digit)+ checkPort start+ char ':'+ end <- option 65535 (fmap read $ many1 digit)+ checkPort end+ checkPortRange start end+ return $ PortRange start end++ipPort :: GenParser Char st Port+ipPort = do+ portsS <- sepBy1 (many1 digit) $ char ','+ let ports = map read portsS+ mapM_ checkPort ports+ return $ Port ports++ipPortParser :: GenParser Char st Port+ipPortParser = try ipPortRange <|> ipPort++interfaceParser :: GenParser Char st String+interfaceParser = do+ -- Можно написать -i + или -o +, но такое правило сохранится вообще без параметра -i или -o+ name <- many1 alphaNum+ plus <- option [] (fmap (: []) $ char '+')+ return $ name ++ plus++natAddrParser :: GenParser Char st NatAddress+natAddrParser = (natIpPort <?> "nat ip(s) and port(s)") <|>+ natIp++natIp :: GenParser Char st NatAddress+natIp = do+ ip1 <- ipAddr+ ip2 <- option ip1 (char '-' >> ipAddr)+ return $ NAIp ip1 ip2++natIpPort :: GenParser Char st NatAddress+natIpPort = do+ (ip1, ip2) <- try ( do+ ip1 <- ipAddr+ ip2 <- option ip1 (char '-' >> ipAddr)+ char ':'+ return (ip1, ip2)+ )+ port1S <- many1 digit+ let port1 = read port1S+ checkPort port1+ port2S <- option port1S (char '-' >> many1 digit)+ let port2 = read port2S+ checkPort port2+ checkPortRange port1 port2+ return $ NAIpPort ip1 ip2 port1 port2++natPortParser :: GenParser Char st NatPort+natPortParser = do+ port1S <- many1 digit+ let port1 = read port1S+ checkPort port1+ port2S <- option port1S (char '-' >> many1 digit)+ let port2 = read port2S+ checkPort port2+ checkPortRange port1 port2+ return $ NatPort port1 port2++rejectTypeParser :: GenParser Char st RejectType+rejectTypeParser = do+ rw <- many1 (letter <|> char '-')+ case rw of+ "icmp-net-unreachable" -> return RTNetUnreachable+ "icmp-host-unreachable" -> return RTHostUnreachable+ "icmp-port-unreachable" -> return RTPortUnreachable+ "icmp-proto-unreachable" -> return RTProtoUnreachable+ "icmp-net-prohibited" -> return RTNetProhibited+ "icmp-host-prohibited" -> return RTHostProhibited+ "icmp-admin-prohibited" -> return RTAdminProhibited+ "tcp-reset" -> return RTTcpReset+ a -> fail $ "Unknown reject type: " ++ a
+ src/Iptables/Print.hs view
@@ -0,0 +1,216 @@++module Iptables.Print where++import Data.Bits+import Data.List+import Data.Set (toList)+import Data.Word+import Iptables.Types++printIptables :: Iptables -> String+printIptables (Iptables f n m r) =+ printTable "Filter" f+ ++ printTable "Nat" n+ ++ printTable "Mangle" m+ ++ printTable "Raw" r+ where+ printTable :: String -> [Chain] -> String+ printTable tableName chains =+ "Table " ++ tableName ++ "\n" ++ unlines (map printChain chains)++{-+printIptables (t:ts) =+ let (tableName, chains) = case t of+ TableFilter chs -> ("Filter",chs)+ TableNat chs -> ("Nat", chs)+ TableMangle chs -> ("Mangle", chs)+ in "Table " ++ tableName ++ "\n" ++ (unlines $ map printChain chains)+ ++ printIptables ts+ -}++printChain :: Chain -> String+printChain (Chain name policy counters rules) =+ "Chain: " ++ name+ ++ " ; Policy: "+ ++ printPolicy policy+ ++ " counters: " ++ printCounters counters ++ "\n"+ ++ unlines (map printRule $ zip rules [1 ..])++printPolicy :: Policy -> String+printPolicy ACCEPT = "ACCEPT"+printPolicy DROP = "DROP"+printPolicy PUNDEFINED = "UNDEFINED"++printCounters :: Counters -> String+printCounters (Counters a b) = "[" ++ show a ++ ":" ++ show b ++ "]"++printRuleCanonical :: Rule -> String+printRuleCanonical (Rule ruleOpts target) =+ unwords (map printOption ruleOpts) ++ " "+ ++ printTarget target++printRule :: (Rule, Int) -> String+printRule (Rule ruleOpts target, lineNum) =+ show lineNum ++ ". "+ ++ unwords (map printOption ruleOpts) ++ " "+ ++ printTarget target++printOption :: RuleOption -> String+printOption opt = case opt of+ (OProtocol b p) -> unwords $ printInv b ++ ["-p"] ++ [p]+ (OSource b addr) -> unwords $ printInv b ++ ["-s"] ++ [printAddress addr]+ (ODest b addr) -> unwords $ printInv b ++ ["-d"] ++ [printAddress addr]+ (OInInt b int) -> unwords $ printInv b ++ ["-i"] ++ [printInterface int]+ (OOutInt b int) -> unwords $ printInv b ++ ["-o"] ++ [printInterface int]+ (OFragment b) -> undefined b+ (OSourcePort b p) -> unwords $ printInv b ++ ["--sport"] ++ [printPort p]+ (ODestPort b p) -> unwords $ printInv b ++ ["--dport"] ++ [printPort p]+ (OTcpFlags b fs) -> undefined b fs+ (OSyn b) -> undefined b+ (OTcpOption b o) -> undefined b o+ (OIcmpType b t) -> undefined b t+ (OModule m) -> unwords $ "-m" : [printModule m]+ (OLimit b l) -> undefined b l+ (OLimitBurst b) -> undefined b+ (OMacSource b m) -> undefined b m+ (OMark a b) -> undefined a b+ (OPort b p) -> undefined b p+ (OUidOwner b u) -> undefined b u+ (OGidOwner b g) -> undefined b g+ (OSidOwner b s) -> undefined b s+ (OState s) -> unwords $ "--state" : [printStates $ toList s]+ (OTos t) -> undefined t+ (OTtl t) -> undefined t+ (OPhysDevIn b int) -> undefined b int+ (OPhysDevOut b int) -> undefined b int+ (OPhysDevIsIn b) -> undefined b+ (OPhysDevIsOut b) -> undefined b+ (OPhysDevIsBridged b) -> unwords $ printInv b ++ ["--physdev-is-bridged"]+ (OComment c) -> undefined c+ (OUnknown oName b opts) -> unwords $ printInv b ++ [oName] ++ opts++printInv :: Bool -> [String]+printInv True = []+printInv False = ["!"]++printTarget :: RuleTarget -> String+printTarget rt = (++) "-j " $ case rt of+ TAccept -> "ACCEPT"+ TDrop -> "DROP"+ TReject rw -> "REJECT" ++ " --reject-with " ++ printRejectWith rw+ TReturn -> "RETURN"+ TUChain chain -> chain+ TSNat natAddr rand persist ->+ let randS = if rand then " --random"+ else ""+ persistS = if persist then " --persistent"+ else ""+ in+ "SNAT " ++ "--to-source " ++ printNatAddr natAddr ++ randS ++ persistS+ TDNat natAddr rand persist ->+ let randS = if rand then " --random"+ else ""+ persistS = if persist then " --persistent"+ else ""+ in+ "DNAT " ++ "--to-destination " ++ printNatAddr natAddr ++ randS ++ persistS+ TMasquerade natPort rand ->+ let randS = if rand then " --random"+ else ""+ natPortS = case natPort of+ NatPortDefault -> ""+ _ -> " --to-ports " ++ printNatPort natPort+ in+ "MASQUERADE" ++ natPortS ++ randS+ TRedirect natPort rand ->+ let randS = if rand then " --random"+ else ""+ natPortS = case natPort of+ NatPortDefault -> ""+ _ -> " --to-ports " ++ printNatPort natPort+ in+ "REDIRECT" ++ natPortS ++ randS+ TUnknown tName opts ->+ tName ++ " " ++ unwords opts++printAddress :: Addr -> String+printAddress (AddrIP ip) = printIp ip+printAddress (AddrMask ip mask) = printIp ip ++ "/" ++ printIp mask+printAddress (AddrPref ip pref) = printIp ip ++ "/" ++ show pref++printIp :: Word32 -> String+printIp ip =+ let oct1 = show $ shiftR ip 24+ oct2 = show $ shiftR (shiftL ip 8) 24+ oct3 = show $ shiftR (shiftL ip 16) 24+ oct4 = show $ shiftR (shiftL ip 24) 24+ in oct1 ++ "." ++ oct2 ++ "." ++ oct3 ++ "." ++ oct4++printInterface :: Interface -> String+printInterface (Interface str) = str++printPort :: Port -> String+printPort (Port ps) = intercalate "," $ map show ps+printPort (PortRange ps pe) = show ps ++ ":" ++ show pe++printStates :: [CState] -> String+printStates ss = intercalate "," $ map printState ss+ where+ printState st = case st of+ CStInvalid -> "INVALID"+ CStEstablished -> "ESTABLISHED"+ CStNew -> "NEW"+ CStRelated -> "RELATED"+ CStUntracked -> "UNTRACKED"++printModule :: Module -> String+printModule m = case m of+ ModTcp -> "tcp"+ ModUdp -> "udp"+ ModLimit -> "limit"+ ModMac -> "mac"+ ModMark -> "mark"+ ModMultiport -> "multiport"+ ModOwner -> "owner"+ ModState -> "state"+ ModTos -> "tos"+ ModTtl -> "ttl"+ ModPhysDev -> "physdev"+ ModComment -> "comment"+ ModOther s -> s++printNatAddr :: NatAddress -> String+printNatAddr (NAIp ip1 ip2) = printNatIp ip1 ip2+printNatAddr (NAIpPort ip1 ip2 port1 port2) = printNatIpPort ip1 ip2 port1 port2++printNatIp :: Word32 -> Word32 -> String+printNatIp ip1 ip2 =+ if ip1 == ip2 then printIp ip1+ else printIp ip1 ++ "-" ++ printIp ip2++printNatIpPort :: Word32 -> Word32 -> Int -> Int -> String+printNatIpPort ip1 ip2 port1 port2 =+ let ipString = if ip1 == ip2 then printIp ip1+ else printIp ip1 ++ "-" ++ printIp ip2+ portString = if port1 == port2 then show port1+ else show port1 ++ "-" ++ show port2+ in+ ipString ++ ":" ++ portString++printNatPort :: NatPort -> String+printNatPort NatPortDefault = ""+printNatPort (NatPort port1 port2) =+ if port1 == port2+ then show port1+ else show port1 ++ "-" ++ show port2++printRejectWith :: RejectType -> String+printRejectWith rw = case rw of+ RTNetUnreachable -> "icmp-net-unreachable"+ RTHostUnreachable -> "icmp-host-unreachable"+ RTPortUnreachable -> "icmp-port-unreachable"+ RTProtoUnreachable -> "icmp-proto-unreachable"+ RTNetProhibited -> "icmp-net-prohibited"+ RTHostProhibited -> "icmp-host-prohibited"+ RTAdminProhibited -> "icmp-admin-prohibited"+ RTTcpReset -> "tcp-reset"
+ src/Iptables/Types.hs view
@@ -0,0 +1,163 @@++module Iptables.Types where++import Data.Set+import Data.Word++-- Типы данных составлены по мануалу iptables++data Iptables = Iptables { tFilter :: [Chain]+ , tNat :: [Chain]+ , tMangle :: [Chain]+ , tRaw :: [Chain]+ }+ deriving (Show, Eq)++data Chain = Chain { cName :: String+ , cPolicy :: Policy+ , cCounters :: Counters+ , cRules :: [Rule]+ }+ deriving (Show, Eq)++data Policy = ACCEPT+ | DROP+ | PUNDEFINED+ deriving (Show, Eq)++data Counters = Counters Int Int+ deriving (Show, Eq)++data Rule = Rule { rOptions :: [RuleOption]+ , rTarget :: RuleTarget+ }+ deriving (Show, Eq)++data RuleTarget = TAccept+ | TDrop+ | TReject RejectType+ | TReturn+ | TSNat NatAddress Bool Bool -- --to-source --random --persistent+ | TDNat NatAddress Bool Bool+ | TMasquerade NatPort Bool -- --to-ports --random+ | TRedirect NatPort Bool -- --to-ports --random+ | TUChain String+ | TUnknown String [String]+ deriving (Show, Eq)++data RejectType = RTNetUnreachable+ | RTHostUnreachable+ | RTPortUnreachable -- Default if not specified+ | RTProtoUnreachable+ | RTNetProhibited+ | RTHostProhibited+ | RTAdminProhibited+ | RTTcpReset+ deriving (Show, Eq)++data NatAddress = NAIp Word32 Word32+ | NAIpPort Word32 Word32 Int Int+ deriving (Show, Eq)++data NatPort = NatPort Int Int+ | NatPortDefault+ deriving (Show, Eq)++data RuleOption = OProtocol Bool Protocol+ | OSource Bool Addr+ | ODest Bool Addr+ | OInInt Bool Interface+ | OOutInt Bool Interface+ | OState (Set CState)+ | OFragment Bool+ | OSourcePort Bool Port+ | ODestPort Bool Port+ | OTcpFlags Bool TcpFlags+ | OSyn Bool+ | OTcpOption Bool Int+ | OIcmpType Bool Int+ | OModule Module+ | OLimit Bool Limit+ | OLimitBurst Int+ | OMacSource Bool String+ | OMark Int Int+ | OPort Bool Port+ | OUidOwner Bool Int+ | OGidOwner Bool Int+ | OSidOwner Bool Int+ | OTos Int+ | OTtl Int+ | OPhysDevIn Bool Interface+ | OPhysDevOut Bool Interface+ | OPhysDevIsIn Bool+ | OPhysDevIsOut Bool+ | OPhysDevIsBridged Bool+ | OComment String+ | OUnknown String Bool [String] -- option can have more than one parameters+ deriving (Show, Eq)++{- We can work only with strings. In iptables, a protocol can be specified by integer number,+ - but we don't use this feature.+ -}+type Protocol = String++data Addr = AddrIP Word32+ | AddrMask Word32 Word32+ | AddrPref Word32 Int+ deriving (Show, Eq)++data Interface = Interface String+ deriving (Show, Eq)++data Port = Port [Int]+ | PortRange Int Int+ deriving (Show, Eq)++-- Парсить осторожно - в тексте это 2 слова, разделённых пробелами+data TcpFlags = TcpFlags [Flag] [Flag]+ deriving (Show, Eq)++data Flag = FSyn+ | FAck+ | FFin+ | FRst+ | FUrg+ | FPsh+ | FAll+ | FNone+ deriving (Show, Eq)++data Limit = Limit String+ deriving (Show, Eq)++data CState = CStInvalid+ | CStEstablished+ | CStNew+ | CStRelated+ | CStUntracked+ deriving (Show, Eq, Ord)++data Module = ModTcp+ | ModUdp+ | ModLimit+ | ModMac+ | ModMark+ | ModMultiport+ | ModOwner+ | ModState+ | ModTos+ | ModTtl+ | ModPhysDev+ | ModComment+ | ModOther String+ deriving (Show, Eq)++data FilterChainType = FilterInvalidChain+ | FilterValidChain+ deriving (Show, Eq)++data NatChainType = NatUnknownChain+ | NatInvalidChain+ | NatDNatChain+ | NatSNatChain+ deriving (Show, Eq, Ord)