diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,16 @@ +Iptadmin 1.0.0 05.07.2011: + + * First public release. + * Program core. + * Minimum iptables-helpers library. + * Minimum pam bindings library. Pam authorisation. + * Prototype for edit pages. + * Add support of several iptables rules parameters. + * Add support of user defined chains. + * Handle user defined chains in nat table. + * Main show page prototype. + * Protect user from denying access to iptadmin interface. + * Rule verification. + * Project web site. + * Binary distribution and few rpm packages. + * The simplest init script. diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,28 @@ +INSTALL +======= + +1. make (or cabal install) +2. sudo make install +3. sudo /etc/init.d/iptadmin start + +In future all stuff will be installed with cabal install + +UNINSTALL +========= + +sudo make uninstall + +Notes for debian-based distributions +---------------------------------- +In some linux distributions, for example, debian and ubuntu, +there is no "/etc/init.d/iptables save" script by default. +And there is no mechanism for saving netfilter configuration. +That's why user should manually setup a saving procedure. +The article http://www.debian-administration.org/articles/445 can help to do this. +After setting up saving procedure the file /etc/iptadmin/iptadmin.conf +should be configured. The parameter "save command" should be set up to something like +"iptables-save > /etc/firewall.conf". It's the command for +saving filrewall rules to a file which is read by iptables on startup. + +You can set 'save command' to 'echo' for testing purposes. +But rules won't be saved after reboot in this case. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +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 the author nor the + names of 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 COPYRIGHT HOLDER 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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,36 @@ +all: dist/build/iptadmin/iptadmin + +dist/build/iptadmin/iptadmin: src/Template.hs src/IptAdmin/AddPage.hs src/IptAdmin/EditForm/Utils.hs src/IptAdmin/EditForm/Render.hs src/IptAdmin/EditForm/Class.hs src/IptAdmin/EditForm/Types.hs src/IptAdmin/Utils.hs src/IptAdmin/Render.hs src/IptAdmin/EditPage.hs src/IptAdmin/InsertPage.hs src/IptAdmin/EditChainForm/Render.hs src/IptAdmin/EditChainForm/Parse.hs src/IptAdmin/DelPage.hs src/IptAdmin/EditForm.hs src/IptAdmin/DelPage/Render.hs src/IptAdmin/ShowPage/Render.hs src/IptAdmin/EditPolicyPage.hs src/IptAdmin/EditPolicyForm/Render.hs src/IptAdmin/EditChainPage.hs src/IptAdmin/AccessControl.hs src/IptAdmin/DelChainPage.hs src/IptAdmin/LoginPage.hs src/IptAdmin/Types.hs src/IptAdmin/System.hs src/IptAdmin/DelChainPage/Render.hs src/IptAdmin/Config.hs src/IptAdmin/AddChainPage.hs src/IptAdmin/ShowPage.hs src/Main.hs + cabal install + +src/Template.hs: html/htmlwrapper.html + ptmpl src/Template.hs html/htmlwrapper.html + +install: /usr/bin/iptadmin /etc/iptadmin/iptadmin.conf /etc/pam.d/iptadmin /etc/init.d/iptadmin + groupadd iptadmin || true + /etc/init.d/iptadmin start || true + echo "installed" + echo "connect to http://localhost:8000 (the port depends on configuration)" + +/usr/bin/iptadmin: dist/build/iptadmin/iptadmin + cp dist/build/iptadmin/iptadmin /usr/bin/ + +/etc/iptadmin/iptadmin.conf: doc/examples/config/iptadmin.conf + mkdir /etc/iptadmin || true + cp doc/examples/config/iptadmin.conf /etc/iptadmin/ || true + +/etc/pam.d/iptadmin: doc/examples/pam/iptadmin + cp doc/examples/pam/iptadmin /etc/pam.d/ + +/etc/init.d/iptadmin: doc/examples/init/iptadmin + cp doc/examples/init/iptadmin /etc/init.d/ || true + chmod +x /etc/init.d/iptadmin || true + +uninstall: + /etc/init.d/iptadmin stop || true + rm /usr/bin/iptadmin || true + rm /etc/iptadmin/iptadmin.conf || true + rmdir /etc/iptadmin || true + rm /etc/pam.d/iptadmin || true + rm /etc/init.d/iptadmin + echo "uninstalled" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/examples/config/iptadmin.conf b/doc/examples/config/iptadmin.conf new file mode 100644 --- /dev/null +++ b/doc/examples/config/iptadmin.conf @@ -0,0 +1,3 @@ +save command = /etc/init.d/iptables save +port = 8000 +pam name = iptadmin diff --git a/doc/examples/init/iptadmin b/doc/examples/init/iptadmin new file mode 100644 --- /dev/null +++ b/doc/examples/init/iptadmin @@ -0,0 +1,24 @@ +#! /bin/sh +# Basic support for IRIX style chkconfig +### +# chkconfig: 235 98 55 +# description: Manages the services you are controlling with the chkconfig command +### + +case "$1" in + start) + echo -n "Starting iptables-admin" + /usr/bin/iptadmin & + echo "." + ;; + stop) + echo -n "Stopping iptables-admin" + /usr/bin/killall iptadmin + echo "." + ;; + *) + echo "Usage: /sbin/service iptadmin {start|stop}" + exit 1 +esac + +exit 0 diff --git a/doc/examples/pam/iptadmin b/doc/examples/pam/iptadmin new file mode 100644 --- /dev/null +++ b/doc/examples/pam/iptadmin @@ -0,0 +1,4 @@ +#%PAM-1.0 +auth required pam_unix.so nullok +account required pam_unix.so +session required pam_unix.so diff --git a/html/htmlwrapper.html b/html/htmlwrapper.html new file mode 100644 --- /dev/null +++ b/html/htmlwrapper.html @@ -0,0 +1,258 @@ + + + + + + Iptables Manager + + + + + + + +!@#content + + + diff --git a/iptadmin.cabal b/iptadmin.cabal new file mode 100644 --- /dev/null +++ b/iptadmin.cabal @@ -0,0 +1,78 @@ +Name: iptadmin +Version: 1.0.0 +Cabal-Version: >= 1.4 +Author: Evgeny Tarasov +Build-type: Simple +Copyright: 2011 Evgeny Tarasov +License: BSD3 +License-file: LICENSE +Maintainer: etarasov.ekb@gmail.com +HomePage: http://iptadmin.confmgr.org +Stability: Stable +Synopsis: web-interface for iptables +Description: web-interface for iptables based on happstack with PAM authorisation +Category: System, Tools, Web +Extra-source-files: html/htmlwrapper.html, + util/ptmpl/Setup.hs, + util/ptmpl/ptmpl.cabal, + util/ptmpl/src/Main.hs + src/Template.hs, + doc/examples/config/iptadmin.conf + doc/examples/init/iptadmin + doc/examples/pam/iptadmin + INSTALL + Makefile + Changelog + +Executable iptadmin + Build-Depends: base >= 4 && < 5, + haskell98, + utf8-string >= 0.3, + bytestring >= 0.9, + happstack-server >= 0.5 && < 0.5.1, + happstack-state >= 0.5 && < 0.5.1, + happstack-util >= 0.5 && < 0.5.1, + mtl >= 1.1, + safe >= 0.3, + iptables-helpers >= 0.3 && < 0.4, + process >= 1.0 && < 2, + blaze-html >= 0.4, + parsec >= 2.1, + containers >= 0.3, + time >= 1.1 && < 2, + random >= 1.0 && < 2, + pam >= 0.1, + unix >= 2.4 && < 3, + ConfigFile >= 1.0 && < 2, + filepath >= 1.1 && < 2, + network >= 2.2 && < 3 + Main-Is: Main.hs + Other-modules: IptAdmin.AccessControl + IptAdmin.AddChainPage + IptAdmin.AddPage + IptAdmin.Config + IptAdmin.DelChainPage + IptAdmin.DelChainPage.Render + IptAdmin.DelPage + IptAdmin.DelPage.Render + IptAdmin.EditChainForm.Parse + IptAdmin.EditChainForm.Render + IptAdmin.EditChainPage + IptAdmin.EditForm + IptAdmin.EditForm.Class + IptAdmin.EditForm.Render + IptAdmin.EditForm.Types + IptAdmin.EditForm.Utils + IptAdmin.EditPage + IptAdmin.EditPolicyForm.Render + IptAdmin.EditPolicyPage + IptAdmin.InsertPage + IptAdmin.LoginPage + IptAdmin.Render + IptAdmin.ShowPage + IptAdmin.ShowPage.Render + IptAdmin.System + IptAdmin.Types + IptAdmin.Utils + Hs-Source-Dirs: src + Ghc-Options: -threaded -Wall -fno-warn-unused-do-bind diff --git a/src/IptAdmin/AccessControl.hs b/src/IptAdmin/AccessControl.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/AccessControl.hs @@ -0,0 +1,82 @@ + +module IptAdmin.AccessControl where + +import Control.Exception (catch, SomeException) +import Control.Monad.Error +import Control.Monad.State +import Data.IORef +import Data.Map +import Data.Maybe +import Happstack.Server.SimpleHTTP +import IptAdmin.LoginPage as LoginPage (pageHandlers) +import IptAdmin.Types +import IptAdmin.Utils +import Prelude hiding (catch) +import System.Posix.PAM as PAM +import System.Posix.User + +-- verify that client is allowed to access server +authorize :: IORef Sessions -> IptAdminConfig -> IptAdmin Response -> IptAdminAuth Response +authorize sessionsIORef config requestHandler = do + clientIdMay <- getDataFn $ lookCookieValue "sessionId" + isAuthorised <- case clientIdMay of + Nothing -> return False + Just a -> do + sessions <- liftIO $ readIORef sessionsIORef + let session = Data.Map.lookup a sessions + case session of + Nothing -> return False + Just _ -> return True + if isAuthorised + then + -- Run IptAdmin monad with state + mapServerPartT (addStateToTheStack (fromJust clientIdMay, sessionsIORef, config)) requestHandler + else + msum [ dir "login" $ LoginPage.pageHandlers (IptAdmin.AccessControl.authenticate $ cPamName config) + sessionsIORef + , redir "/login" + ] + where + addStateToTheStack :: (Monad m) => MainState + -> UnWebT (ErrorT String (StateT MainState m)) a + -> UnWebT (ErrorT String m) a + addStateToTheStack mainState statefulAction = + mapErrorT (addStateToStack' mainState) statefulAction + + addStateToStack' :: (Monad m) => MainState + -> StateT MainState m (Either String a) + -> m (Either String a) + addStateToStack' mainState statefulAction = + evalStateT statefulAction mainState + +logout :: IptAdmin Response +logout = do + (sessionId, sessionsIORef, _) <- lift get + _ <- liftIO $ atomicModifyIORef sessionsIORef + (\ m -> (delete sessionId m, ())) + expireCookie "sessionId" + redir "/" + +{- Nothing - authentication is successful +-- or Just error message +-} +authenticate :: String -> String -> String -> IO (Maybe String) +authenticate pamName login password = do + authRes <- PAM.authenticate pamName login password + case authRes of + Left a -> return $ Just $ "Pam message: " ++ pamCodeToMessage a + Right () -> + {- The user exists in system and password is correct + - Next authentication stage: check if it's permitted to work with firewall for the user + -} + if login == "root" + then return Nothing + else do + groupEntryMay <- catch (Just `fmap` getGroupEntryForName "iptadmin") + ((\ _ -> return Nothing) :: (SomeException -> IO (Maybe GroupEntry))) + case groupEntryMay of + Nothing -> return $ Just "The user is not allowed to access iptables" + Just groupEntry -> + if login `elem` groupMembers groupEntry + then return Nothing + else return $ Just "The user is not allowed to access iptables" diff --git a/src/IptAdmin/AddChainPage.hs b/src/IptAdmin/AddChainPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/AddChainPage.hs @@ -0,0 +1,61 @@ + +module IptAdmin.AddChainPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditChainForm.Parse +import IptAdmin.EditChainForm.Render +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Types +import Text.ParserCombinators.Parsec.Prim hiding (State (..)) +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add user defined chain in '" ++ tableName ++ "' table" + editChainForm (tableName, "") "" Nothing + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + newChainName <- getInputString "newChainName" + let newChainNameE = parse parseChainName "chain name" newChainName + case newChainNameE of + Left e -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add user defined chain in '" ++ tableName ++ "' table" + editChainForm (tableName, "") newChainName $ Just $ "Parameter error: " ++ show e + Right newChainName' -> do + iptables <- getIptables + table <- case tableName of + "filter" -> return $ tFilter iptables + "nat" -> return $ tNat iptables + "mangle" -> return $ tMangle iptables + "raw" -> return $ tRaw iptables + a -> throwError $ "Invalid table parameter: " ++ a + let checkChainMay = getChainByName newChainName' table + case checkChainMay of + Just _ -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add user defined chain in '" ++ tableName ++ "' table" + editChainForm (tableName, "") newChainName' $ Just "A chain with the same name already exists" + Nothing -> do + submit <- getInputString "submit" + case submit of + "Check" -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add user defined chain in '" ++ tableName ++ "' table" + editChainForm (tableName, "") newChainName' $ Just "The name is valid" + "Submit" -> do + tryChange $ addChain tableName newChainName' + redir $ "/show?table=" ++ tableName + a -> throwError $ "Invalid value for 'submit' parameter: " ++ a diff --git a/src/IptAdmin/AddPage.hs b/src/IptAdmin/AddPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/AddPage.hs @@ -0,0 +1,81 @@ + +module IptAdmin.AddPage where + +import Control.Monad.Error +import Control.Monad.State +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditForm +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Render +import IptAdmin.EditForm.Utils +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Print +import Iptables.Types +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + + table <- getTable tableName + + checkParams table chainName + + (PackedEditForm form) <- nullSelForm tableName chainName + let userChainNames = getUserChains form chainName table + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add rule at the end of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editFormHtml (tableName, chainName, 0, userChainNames) form Nothing + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + + table <- getTable tableName + + checkParams table chainName + + (PackedEditForm addFormParams) <- httpInputToSelForm tableName chainName + let userChainNames = getUserChains addFormParams chainName table + + let checkResE = editPageProcessParams addFormParams + case checkResE of + Left formMes -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Add rule at the end of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editFormHtml (tableName, chainName, 0, userChainNames) addFormParams $ Just formMes + Right (options, target, formMes) -> do + let (_, options') = runState (mapM_ completeModules options) options + let rule = Rule options' target + + submit <- getInputString "submit" + case submit of + "Check" -> return $ buildResponse $ Template.htmlWrapper $ renderHtml (do + header tableName $ "Add rule at the end of '" + ++ chainName ++ "' chain in '" + ++ tableName ++ "' table" + editFormHtml (tableName, chainName, 0, userChainNames) addFormParams $ Just formMes + ) ++ printRuleCanonical rule + "Submit" -> do + tryChange (appendRule tableName chainName rule) + redir $ "/show?table=" ++ tableName + a -> throwError $ "Wrong value for 'submit' parameter: " ++ a + +checkParams :: [Chain] -> String -> IptAdmin () +checkParams table chainName = do + let chainMay = getChainByName chainName table + _ <- maybe (throwError $ "Invalid chain name: " ++ chainName) + return + chainMay + return () diff --git a/src/IptAdmin/Config.hs b/src/IptAdmin/Config.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/Config.hs @@ -0,0 +1,27 @@ + +module IptAdmin.Config where + +import Control.Monad.Error +import Data.ConfigFile +import IptAdmin.Types +import System.FilePath.Posix + +cONFpATHd :: String +cONFpATHd = "/etc/iptadmin" + +cONFIGURATIONf :: String +cONFIGURATIONf = "iptadmin.conf" + +getConfig :: ErrorT String IO IptAdminConfig +getConfig = do + configE <- liftIO $ runErrorT $ do + cp <- join $ liftIO $ readfile emptyCP (cONFpATHd cONFIGURATIONf) + saveCommand <- get cp "DEFAULT" "save command" + port <- get cp "DEFAULT" "port" + pamName <- get cp "DEFAULT" "pam name" + return $ IptAdminConfig saveCommand + port + pamName + case configE of + Left (_, err) -> throwError ("Error on reading " ++ cONFpATHd cONFIGURATIONf ++ "\n" ++ err) + Right config -> return config diff --git a/src/IptAdmin/DelChainPage.hs b/src/IptAdmin/DelChainPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/DelChainPage.hs @@ -0,0 +1,73 @@ + +module IptAdmin.DelChainPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.DelChainPage.Render +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Types +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + table <- getTable tableName + let chainMay = getChainByName chainName table + + case chainMay of + Nothing -> throwError $ "Invalid chain name: " ++ chainName + Just chain -> + if not $ null $ cRules chain + then + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ + header tableName $ "'" ++ chainName + ++ "' chain is not empty. Please, remove all rules before deleting a chain" + else + let linkedChains = scanTableForLink (cName chain) table + in + if not $ null linkedChains + then return $ buildResponse $ Template.htmlWrapper $ renderHtml $ + header tableName $ "There are links to the '" ++ chainName + ++ "' chain from chains : " ++ show linkedChains + ++ ". Please, remove all links before deleting a chain" + else + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Delete '" ++ chainName + ++ "' user defined chain from '" + ++ tableName ++ "' table" + delChainForm tableName chainName + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + table <- getTable tableName + let chainMay = getChainByName chainName table + + case chainMay of + Nothing -> throwError $ "Ivalid chain name: " ++ chainName + Just chain -> + if not $ null $ cRules chain + then throwError $ "Chain " ++ chainName + ++ " is not empty. Please, remove all rules before deleting a chain" + else + let linkedChains = scanTableForLink (cName chain) table + in + if not $ null linkedChains + then throwError $ "There are links to the '" + ++ chainName ++ "' chain from chains : " + ++ show linkedChains + else do + tryChange $ deleteChain tableName chainName + redir $ "/show?table=" ++ tableName diff --git a/src/IptAdmin/DelChainPage/Render.hs b/src/IptAdmin/DelChainPage/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/DelChainPage/Render.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.DelChainPage.Render where + +import Data.String +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +delChainForm :: String -> String -> Html +delChainForm tableName chainName = + H.div ! A.class_ "editForm" $ + H.form ! A.id "delChainform" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "table" ! A.value (fromString tableName) + H.input ! A.type_ "hidden" ! A.name "chain" ! A.value (fromString chainName) + "Delete chain " + fromString chainName + " ?" + H.br + H.input ! A.id "submit" ! A.type_ "submit" ! A.value "Delete" diff --git a/src/IptAdmin/DelPage.hs b/src/IptAdmin/DelPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/DelPage.hs @@ -0,0 +1,62 @@ + +module IptAdmin.DelPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.DelPage.Render +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Print +import Iptables.Types +import Safe +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + rulePosition <- getInputRead "pos" + + (_, rule) <- checkParams tableName chainName rulePosition + + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Delete rule from '" ++ chainName + ++ "' chain in '" ++ tableName + ++ "' table in position " ++ show rulePosition + delPageForm (tableName, chainName, rulePosition) $ printRule (rule, rulePosition) + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + + rulePosition <- getInputRead "rulePos" + + _ <- checkParams tableName chainName rulePosition + + tryChange (deleteRule tableName chainName rulePosition) + redir $ "/show?table=" ++ tableName + +checkParams :: String -> String -> Int -> IptAdmin (Chain, Rule) +checkParams tableName chainName rulePosition = do + table <- getTable tableName + + let chainMay = getChainByName chainName table + chain <- maybe (throwError $ "Invalid chain name: " ++ chainName) + return + chainMay + + let ruleMay = cRules chain `atMay` (rulePosition - 1) + rule <- maybe (throwError $ "Rule index out of range: " ++ show rulePosition) + return + ruleMay + return (chain, rule) diff --git a/src/IptAdmin/DelPage/Render.hs b/src/IptAdmin/DelPage/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/DelPage/Render.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.DelPage.Render where + +import Data.String +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +delPageForm :: (String, String, Int) -> String -> Html +delPageForm (tableName, chainName, rulePos) rule = + H.div ! A.class_ "editForm" $ + H.form ! A.id "delform" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "table" ! A.value (fromString tableName) + H.input ! A.type_ "hidden" ! A.name "chain" ! A.value (fromString chainName) + H.input ! A.type_ "hidden" ! A.name "rulePos" ! A.value (fromString $ show rulePos) + fromString rule + H.br + H.input ! A.id "submit" ! A.type_ "submit" ! A.value "Delete" diff --git a/src/IptAdmin/EditChainForm/Parse.hs b/src/IptAdmin/EditChainForm/Parse.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditChainForm/Parse.hs @@ -0,0 +1,20 @@ + +module IptAdmin.EditChainForm.Parse where + +import Control.Monad +import Data.Char +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator +import Text.ParserCombinators.Parsec.Prim hiding (State(..)) + +-- let's assume that chain names can contain only letters and digits +-- it's not mentioned in iptables man page +parseChainName :: GenParser Char () String +parseChainName = do + spaces "" + name <- many1 $ oneOf (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']) `label` "latin letter of digit" + when (all isUpper name) $ + fail "Uppercase letters only is prohibited for chain name" + spaces + eof + return name diff --git a/src/IptAdmin/EditChainForm/Render.hs b/src/IptAdmin/EditChainForm/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditChainForm/Render.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.EditChainForm.Render where + +import Data.Monoid +import Data.String +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +editChainForm :: (String, String) -> String -> Maybe String -> Html +editChainForm (tableName, chainName) newChainName mesMay = + H.div ! A.class_ "editForm" $ + H.form ! A.id "addChainForm" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "table" ! A.value (fromString tableName) + H.input ! A.type_ "hidden" ! A.name "chain" ! A.value (fromString chainName) + H.table $ + H.tr $ do + H.td $ + H.input ! A.type_ "text" ! A.name "newChainName" ! A.value (fromString newChainName) ! A.maxlength "20" + case mesMay of + Nothing -> mempty :: Html + Just mes -> + H.td $ fromString mes + H.input ! A.id "check" ! A.name "submit" ! A.type_ "submit" ! A.value "Check" + H.input ! A.id "submit" ! A.name "submit" ! A.type_ "submit" ! A.value "Submit" diff --git a/src/IptAdmin/EditChainPage.hs b/src/IptAdmin/EditChainPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditChainPage.hs @@ -0,0 +1,72 @@ + +module IptAdmin.EditChainPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditChainForm.Parse +import IptAdmin.EditChainForm.Render +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Text.Blaze.Renderer.Pretty (renderHtml) +import Text.ParserCombinators.Parsec.Prim hiding (State (..)) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + + table <- getTable tableName + + let chainMay = getChainByName chainName table + case chainMay of + Nothing -> throwError $ "Invalid chain name: " ++ chainName + Just _ -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit name of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editChainForm (tableName, chainName) chainName Nothing + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + + newChainName <- getInputString "newChainName" + + let newChainNameE = parse parseChainName "chain name" newChainName + case newChainNameE of + Left e -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit name of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editChainForm (tableName, chainName) newChainName $ Just $ "Parameter error: " ++ show e + Right newChainName' -> + if chainName == newChainName' + then return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit name of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editChainForm (tableName, chainName) newChainName' $ Just "The name was not changed" + else do + table <- getTable tableName + let checkChainMay = getChainByName newChainName' table + case checkChainMay of + Just _ -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit name of '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editChainForm (tableName, chainName) newChainName' $ + Just "A chain with the same name already exists" + Nothing -> do + submit <- getInputString "submit" + case submit of + "Check" -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit name of '" ++ chainName + ++ "' chain in '" ++ tableName + ++ "' table" + editChainForm (tableName, chainName) newChainName' $ Just "The name is valid" + "Submit" -> do + tryChange $ renameChain tableName chainName newChainName' + redir $ "/show?table=" ++ tableName + a -> throwError $ "Invalid value for 'submit' parameter: " ++ a diff --git a/src/IptAdmin/EditForm.hs b/src/IptAdmin/EditForm.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditForm.hs @@ -0,0 +1,264 @@ + +module IptAdmin.EditForm where + +import Control.Monad.State +import Data.Either +import Data.Maybe +import Data.Set (size) +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Types +import IptAdmin.Utils +import Iptables +import Iptables.Parser +import Iptables.Types +import Text.ParserCombinators.Parsec.Prim hiding (State (..)) + +{- | По набору параметров формы получаем набор сообщений об ошибках, + - либо набор сообщений и правило. + - Функция возвращает набор сообщений, которые будут показаны в вебинтерфейсе, либо + - если ошибок нет, то правило + набор сообщений, которые будут показаны в интерфейсе. + - Сделано так потому, что в интерфейсе нужно отобразить статус проверки в любом случае, + - даже если введённые данные полностью корректны + - + - Кроме этого необходимо отобразить статус проверки для каждого параметра, для этого тип FormError + - проходит по всем проверкам и остаётся на выходе + - + - Сначала выполняем парсинг всех полей ввода, + - затем для каждой опции выполняем логическую проверку правила + -} +editPageProcessParams :: EditForm a => a -> Either [ResMessage] ([RuleOption], RuleTarget, [ResMessage]) +editPageProcessParams form = + let entryList = toEntryList form + -- Парсим список пунктов формы + parseResList = map parseFormEntry entryList + {- Для каждого элемента результата парсинга проверяем наличие необходимого модуля iptables, + - для этого передаём список RuleMatch + -} + parseResList' = map (checkMatch $ lefts $ mapMaybe fst parseResList) parseResList + {- TODO: проверка зависимости действий от параметров. Например, в -xNAT можно указывать порты + - только в том случае, если есть опция -p udp или -p tcp + -} + + isThereError :: [(a, ResMessage)] -> Bool + isThereError resList = + let errors = filter isError resList + + isError :: (a, ResMessage) -> Bool + isError (_, RMError _) = True + isError _ = False + in not $ null errors + in + if isThereError parseResList' then + Left $ map snd parseResList' + else + Right $ (,,) (lefts $ mapMaybe fst parseResList') + (head $ rights $ mapMaybe fst parseResList') + (map snd parseResList') + +{- | Обработка параметров формы. + - На входе параметр формы, + - на выходе (опция или действие) или ничего и сообщение о результатах обработки параметра формы + -} +parseFormEntry :: FormEntry -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseFormEntry entry = + case entry of + (FESrc en inv str) -> + if en + then + let addrE = parse (pWrapper ipAddressParser) "src" str + in + case addrE of + Left _ -> (Nothing, RMError "parsing error") + Right addr -> (Just $ Left $ OSource (not inv) addr, RMSucc "") + else + (Nothing, RMIgnore) + (FEDst en inv str) -> + if en + then + let addrE = parse (pWrapper ipAddressParser) "dst" str + in + case addrE of + Left _ -> (Nothing, RMError "parsing error") + Right addr -> (Just $ Left $ ODest (not inv) addr, RMSucc "") + else + (Nothing, RMIgnore) + (FEProt en inv prot) -> + if en + then + case prot of + FTCP -> (Just $ Left $ OProtocol (not inv) "tcp", RMSucc "") + FUDP -> (Just $ Left $ OProtocol (not inv) "udp", RMSucc "") + FICMP -> (Just $ Left $ OProtocol (not inv) "icmp", RMSucc "") + else + (Nothing, RMIgnore) + (FESPort en inv str) -> + if en + then + let portE = parse (pWrapper ipPortParser) "source port" str + in + case portE of + Left _ -> (Nothing, RMError "parsing error") + Right port -> (Just $ Left $ OSourcePort (not inv) port, RMSucc "") + else + (Nothing, RMIgnore) + (FEDPort en inv str) -> + if en + then + let portE = parse (pWrapper ipPortParser) "dest port" str + in + case portE of + Left _ -> (Nothing, RMError "parsing error") + Right port -> (Just $ Left $ ODestPort (not inv) port, RMSucc "") + else + (Nothing, RMIgnore) + (FEInput en inv str) -> + if en + then + let interfaceE = parse (pWrapper interfaceParser) "input interface" str + in + case interfaceE of + Left _ -> (Nothing, RMError "parsing error") + Right interface -> (Just $ Left $ OInInt (not inv) $ Interface interface, RMSucc "") + else + (Nothing, RMIgnore) + (FEOutput en inv str) -> + if en + then + let interfaceE = parse (pWrapper interfaceParser) "output interface" str + in + case interfaceE of + Left _ -> (Nothing, RMError "parsing error") + Right interface -> (Just $ Left $ OOutInt (not inv) $ Interface interface, RMSucc "") + else + (Nothing, RMIgnore) + (FEState en stateSet) -> + if en + then + if size stateSet == 0 + then (Nothing, RMError "select states, please") + else (Just $ Left $ OState stateSet, RMSucc "") + else + (Nothing, RMIgnore) + (FEFiltTar ft rejectType userChain) -> + case ft of + FAccept -> (Just $ Right TAccept, RMSucc "") + FDrop -> (Just $ Right TDrop, RMSucc "") + FReject -> (Just $ Right $ TReject rejectType, RMSucc "") + FFUserChain -> parseUserChainEntry userChain + (FENatPrerOutTar ft dnataddr dnatrand dnatpersist redirport redirrand userChain) -> + case ft of + FDNat -> parseDNatEntry dnataddr dnatrand dnatpersist + FRedirect -> parseRedirectEntry redirport redirrand + FNPrerUserChain -> parseUserChainEntry userChain + (FENatPostrTar ft snataddr snatrand snatpersist masqport masqrand userChain) -> + case ft of + FMasq -> parseMasqEntry masqport masqrand + FSNat -> parseSNatEntry snataddr snatrand snatpersist + FNPostrUserChain -> parseUserChainEntry userChain + (FENatUserTar ft dnatAddr dnatRand dnatPersist redirPort redirRand + snatAddr snatRand snatPersist masqPort masqRand userChain) -> + case ft of + FUDNat -> parseDNatEntry dnatAddr dnatRand dnatPersist + FURedirect -> parseRedirectEntry redirPort redirRand + FUSNat -> parseSNatEntry snatAddr snatRand snatPersist + FUMasq -> parseMasqEntry masqPort masqRand + FNUserUserChain -> parseUserChainEntry userChain + a -> (Nothing, RMError $ "Unknown form entry: " ++ show a) + +parseDNatEntry :: String -> Bool -> Bool -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseDNatEntry dnatAddr dnatRand dnatPersist = + let dnatAddrE = parse (pWrapper natAddrParser) "dnat address" dnatAddr + in case dnatAddrE of + Left _ -> (Nothing, RMError "parsing error") + Right dnatAddr' -> (Just $ Right $ TDNat dnatAddr' dnatRand dnatPersist, RMSucc "") + +parseRedirectEntry :: String -> Bool -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseRedirectEntry redirPort redirRand = + let redirPortE = parse (pWrapper natPortParser) "redirect port" redirPort + in case redirPortE of + Left _ -> (Nothing, RMError "parsing error") + Right redirPort' -> (Just $ Right $ TRedirect redirPort' redirRand, RMSucc "") + +parseSNatEntry :: String -> Bool -> Bool -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseSNatEntry snatAddr snatRand snatPersist = + let snatAddrE = parse (pWrapper natAddrParser) "snat address" snatAddr + in case snatAddrE of + Left _ -> (Nothing, RMError "parsing error") + Right snatAddr' -> (Just $ Right $ TSNat snatAddr' snatRand snatPersist, RMSucc "") + +parseMasqEntry :: String -> Bool -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseMasqEntry masqPort masqRand = + let masqPortE = + if masqPort == "" then Right NatPortDefault + else parse (pWrapper natPortParser) "masquerade port" masqPort + in + case masqPortE of + Left _ -> (Nothing, RMError "parsing error") + Right masqPort' -> (Just $ Right $ TMasquerade masqPort' masqRand, RMSucc "") + +parseUserChainEntry :: String -> (Maybe (Either RuleOption RuleTarget), ResMessage) +parseUserChainEntry userChain = (Just $ Right $ TUChain userChain, RMSucc "") + +{- | Проверка зависимостей опции и таргета от других опций + - на входе список всех распарсенных опций и результат обработки пункта формы + -} +checkMatch :: [RuleOption] + -> (Maybe (Either RuleOption RuleTarget), ResMessage) + -> (Maybe (Either RuleOption RuleTarget), ResMessage) +checkMatch opts (entry, mes) = + let isItTcp = not $ null $ filter (OProtocol True "tcp" ==) opts + isItUdp = not $ null $ filter (OProtocol True "udp" ==) opts + in + case entry of + Just (Left (OSourcePort _ _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + Just (Left (ODestPort _ _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + Just (Right (TReject RTTcpReset)) -> + if isItTcp + then (entry, mes) + else (Nothing, RMError "the parameter works only with tcp protocol") + Just (Right (TSNat (NAIpPort _ _ _ _) _ _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + Just (Right (TDNat (NAIpPort _ _ _ _) _ _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + Just (Right (TMasquerade (NatPort _ _) _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + Just (Right (TRedirect (NatPort _ _) _)) -> + if isItTcp || isItUdp + then (entry, mes) + else (Nothing, RMError "please select tcp or udp protocol") + a -> (a, mes) + +{- | Для каждой опции получает список модулей, от которых она зависит + - затем для каждого модуля проверяет, есть ли он уже в правиле + - и если его там нет, то добавляет + - В состоянии передаётся список опций правила + - вызывать так: options' <- runState (mapM_ completeModules options) options + -} +completeModules :: RuleOption -> State [RuleOption] () +completeModules opt = do + let depends = optionDepends opt + mapM_ addModule depends + + where + addModule :: Module -> State [RuleOption] () + addModule m = do + matches <- get + let mod' = filter (isModule m) matches + when (null mod') $ + put $ OModule m : matches + + isModule :: Module -> RuleOption -> Bool + isModule m ro | OModule m == ro = True + | otherwise = False diff --git a/src/IptAdmin/EditForm/Class.hs b/src/IptAdmin/EditForm/Class.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditForm/Class.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module IptAdmin.EditForm.Class where + +import Control.Applicative hiding (empty) +import Control.Monad.Error +import Data.List (sort) +import Data.Set (empty, singleton, union) +import IptAdmin.EditForm.Types +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Parser +import Iptables.Print +import Iptables.Types +import Text.ParserCombinators.Parsec.Prim hiding (State(..)) + +data PackedEditForm = forall a . (EditForm a) => PackedEditForm a + +class EditForm a where + toEntryList :: a -> [FormEntry] + nullForm :: a + httpInputToForm :: IptAdmin a + ruleToFormParams :: Rule -> IptAdmin a + -- Get valid user chains for using as targets + getUserChains :: a + -> String -- ^ chain name + -> [Chain] -- ^ table + -> [String] -- ^ valid chain names list + + +instance EditForm FiltInpForm where + toEntryList ef = + commParamsToList True False (fifCommonPars ef) + ++ [FEFiltTar (fifTarget ef) + (fifRejectType ef) + (fifUserChain ef) + ] + + nullForm = FiltInpForm nullComPars FAccept RTPortUnreachable "" + + httpInputToForm = + FiltInpForm <$> httpInputToComParams True False + <*> httpInputToFiltTar + <*> httpInputToRejectType + <*> httpInputToUserChain (nullForm :: FiltInpForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, rejectType, userChain) <- filtTarToParam $ rTarget rule + return $ FiltInpForm comPars tarParam rejectType userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isFilterBuiltinChain) $ map cName chains + res = filter (isFilterType FilterValidChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm FiltForwForm where + toEntryList ef = + commParamsToList True True (fffCommonPars ef) + ++ [FEFiltTar (fffTarget ef) + (fffRejectType ef) + (fffUserChain ef) + ] + + nullForm = FiltForwForm nullComPars FAccept RTPortUnreachable "" + + httpInputToForm = + FiltForwForm <$> httpInputToComParams True True + <*> httpInputToFiltTar + <*> httpInputToRejectType + <*> httpInputToUserChain (nullForm :: FiltForwForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, rejectType, userChain) <- filtTarToParam $ rTarget rule + return $ FiltForwForm comPars tarParam rejectType userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isFilterBuiltinChain) $ map cName chains + res = filter (isFilterType FilterValidChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm FiltOutForm where + toEntryList ef = + commParamsToList False True (fofCommonPars ef) + ++ [FEFiltTar (fofTarget ef) + (fofRejectType ef) + (fofUserChain ef) + ] + + nullForm = FiltOutForm nullComPars FAccept RTPortUnreachable "" + + httpInputToForm = + FiltOutForm <$> httpInputToComParams False True + <*> httpInputToFiltTar + <*> httpInputToRejectType + <*> httpInputToUserChain (nullForm :: FiltOutForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, rejectType, userChain) <- filtTarToParam $ rTarget rule + return $ FiltOutForm comPars tarParam rejectType userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isFilterBuiltinChain) $ map cName chains + res = filter (isFilterType FilterValidChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm NatPrerForm where + toEntryList ef = + commParamsToList True False (nrfCommonPars ef) + ++ [ FENatPrerOutTar (nrfTarget ef) + (nrfDNatAddr ef) + (nrfDNatRand ef) + (nrfDNatPersist ef) + (nrfRedirPort ef) + (nrfRedirRand ef) + (nrfUserChain ef) + ] + + nullForm = NatPrerForm nullComPars FDNat "" False False "" False "" + + httpInputToForm = + NatPrerForm <$> httpInputToComParams True False + <*> httpInputToNatPrerOutTar + <*> getInputString "dnataddress" + <*> isThereInput "dnatrandom" + <*> isThereInput "dnatpersistent" + <*> getInputString "redirport" + <*> isThereInput "redirrandom" + <*> httpInputToUserChain (nullForm :: NatPrerForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, dnataddr, dnatrand, dnatpersist, redirport, redirrand, userChain) <- natPrerOutTarToParam $ rTarget rule + return $ NatPrerForm comPars tarParam dnataddr dnatrand dnatpersist redirport redirrand userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isNatBuiltinChain) $ map cName chains + res = filter (isNatType NatDNatChain chains) userChains + ++ filter (isNatType NatUnknownChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm NatPostrForm where + toEntryList ef = + commParamsToList False True (npfCommonPars ef) + ++ [ FENatPostrTar (npfTarget ef) + (npfSNatAddr ef) + (npfSNatRand ef) + (npfSNatPersist ef) + (npfMasqPort ef) + (npfMasqRand ef) + (npfUserChain ef) + ] + + nullForm = NatPostrForm nullComPars FMasq "" False False "" False "" + + httpInputToForm = + NatPostrForm <$> httpInputToComParams False True + <*> httpInputToNatPostrTar + <*> getInputString "snataddress" + <*> isThereInput "snatrandom" + <*> isThereInput "snatpersistent" + <*> getInputString "masqport" + <*> isThereInput "masqrandom" + <*> httpInputToUserChain (nullForm :: NatPostrForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, snataddr, snatrand, snatpersist, masqport, masqrand, userChain) <- natPostrTarToParam $ rTarget rule + return $ NatPostrForm comPars tarParam snataddr snatrand snatpersist masqport masqrand userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isNatBuiltinChain) $ map cName chains + res = filter (isNatType NatSNatChain chains) userChains + ++ filter (isNatType NatUnknownChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm NatOutForm where + toEntryList ef = + commParamsToList False True (nofCommonPars ef) + ++ [ FENatPrerOutTar (nofTarget ef) + (nofDNatAddr ef) + (nofDNatRand ef) + (nofDNatPersist ef) + (nofRedirPort ef) + (nofRedirRand ef) + (nofUserChain ef) + ] + + nullForm = NatOutForm nullComPars FDNat "" False False "" False "" + + httpInputToForm = + NatOutForm <$> httpInputToComParams False True + <*> httpInputToNatPrerOutTar + <*> getInputString "dnataddress" + <*> isThereInput "dnatrandom" + <*> isThereInput "dnatpersistent" + <*> getInputString "redirport" + <*> isThereInput "redirrandom" + <*> httpInputToUserChain (nullForm :: NatOutForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, dnataddr, dnatrand, dnatpersist, redirport, redirrand, userChain) <- natPrerOutTarToParam $ rTarget rule + return $ NatOutForm comPars tarParam dnataddr dnatrand dnatpersist redirport redirrand userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isNatBuiltinChain) $ map cName chains + res = filter (isNatType NatDNatChain chains) userChains + ++ filter (isNatType NatUnknownChain chains) userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +instance EditForm NatUserForm where + toEntryList ef = + commParamsToList True True (nufCommonPars ef) + ++ [ FENatUserTar (nufTarget ef) + (nufDNatAddr ef) + (nufDNatRand ef) + (nufDNatPersist ef) + (nufRedirPort ef) + (nufRedirRand ef) + (nufSNatAddr ef) + (nufSNatRand ef) + (nufSNatPersist ef) + (nufMasqPort ef) + (nufMasqRand ef) + (nufUserChain ef) + ] + + nullForm = NatUserForm nullComPars FUMasq "" False False "" False "" False False "" False "" + + httpInputToForm = + NatUserForm <$> httpInputToComParams True True + <*> httpInputToNatUserTar + <*> getInputString "dnataddress" + <*> isThereInput "dnatrandom" + <*> isThereInput "dnatpersistent" + <*> getInputString "redirport" + <*> isThereInput "redirrandom" + <*> getInputString "snataddress" + <*> isThereInput "snatrandom" + <*> isThereInput "snatpersistent" + <*> getInputString "masqport" + <*> isThereInput "masqrandom" + <*> httpInputToUserChain (nullForm :: NatUserForm) + + ruleToFormParams rule = do + comPars <- foldM optToFormParam nullComPars (rOptions rule) + (tarParam, dNatAddr, dNatRand, dNatPersist, redirPort, redirRand, + sNatAddr, sNatRand, sNatPersist, masqPort, masqRand, userChain) <- natUserTarToParam $ rTarget rule + return $ NatUserForm comPars tarParam dNatAddr dNatRand dNatPersist redirPort redirRand + sNatAddr sNatRand sNatPersist masqPort masqRand userChain + + getUserChains _ chainName chains = + let userChains = filter (not . isNatBuiltinChain) $ map cName chains + res = userChains + res' = filter (not . findChainForward chainName chains) res + in sort res' + +filtTarToParam :: RuleTarget -> IptAdmin (FFiltTar, RejectType, String) +filtTarToParam tar = case tar of + TAccept -> return (FAccept, RTPortUnreachable, "") + TDrop -> return (FDrop, RTPortUnreachable, "") + TReject rt -> return (FReject, rt, "") + TUChain uc -> return (FFUserChain, RTPortUnreachable, uc) + a -> throwError $ "Invalid target for filter table: " ++ show a + +natPrerOutTarToParam :: RuleTarget -> IptAdmin (FNatPrerOutTar, String, Bool, Bool, String, Bool, String) +natPrerOutTarToParam tar = + case tar of + TDNat nataddr rand pers -> + return (FDNat, printNatAddr nataddr, rand, pers, "", False, "") + TRedirect natport rand -> + return (FRedirect, "", False, False, printNatPort natport, rand, "") + TUChain userChain -> + return (FNPrerUserChain, "", False, False, "", False, userChain) + a -> throwError $ "Invalid target for nat PREROUTING chain: " ++ show a + +natPostrTarToParam :: RuleTarget -> IptAdmin (FNatPostrTar, String, Bool, Bool, String, Bool, String) +natPostrTarToParam tar = + case tar of + TSNat nataddr rand pers -> + return (FSNat, printNatAddr nataddr, rand, pers, "", False, "") + TMasquerade natport rand -> + return (FMasq, "", False, False, printNatPort natport, rand, "") + TUChain userChain -> + return (FNPostrUserChain, "", False, False, "", False, userChain) + a -> throwError $ "Invalid target for nat POSTROUTING chain: " ++ show a + +natUserTarToParam :: RuleTarget -> IptAdmin (FNatUserTar, String, Bool, Bool, String, Bool, String, Bool, Bool, String, Bool, String) +natUserTarToParam tar = + case tar of + TDNat natAddr rand pers -> + return (FUDNat, printNatAddr natAddr, rand, pers, "", False, "", False, False, "" , False, "") + TRedirect natPort rand -> + return (FURedirect, "", False, False, printNatPort natPort, rand, "", False, False, "", False, "") + TSNat natAddr rand pers -> + return (FUSNat, "", False, False, "", False, printNatAddr natAddr, rand, pers, "", False, "") + TMasquerade natPort rand -> + return (FUMasq, "", False, False, "", False, "", False, False, printNatPort natPort, rand, "") + TUChain userChain -> + return (FNUserUserChain, "", False, False, "", False, "", False, False, "", False, userChain) + a -> throwError $ "Invalid target for nat user defined chain: " ++ show a + +optToFormParam :: CommonFormPars -> RuleOption -> IptAdmin CommonFormPars +optToFormParam cfp opt = + case opt of + OProtocol b p -> case p of + "tcp" -> return cfp { cfpProt = FTCP, cfpProtEn = True, cfpProtInv = not b} + "udp" -> return cfp { cfpProt = FUDP, cfpProtEn = True, cfpProtInv = not b} + "icmp" -> return cfp { cfpProt = FICMP, cfpProtEn = True, cfpProtInv = not b} + a -> throwError $ "unsupported protocol: " ++ show a + OSource b addr -> return cfp { cfpSrc = printAddress addr, cfpSrcEn = True, cfpSrcInv = not b} + ODest b addr -> return cfp { cfpDest = printAddress addr + , cfpDestEn = True + , cfpDestInv = not b + } + OSourcePort b port -> return cfp { cfpSPort = printPort port + , cfpSPortEn = True + , cfpSPortInv = not b + } + ODestPort b port -> return cfp { cfpDPort = printPort port + , cfpDPortEn = True + , cfpDPortInv = not b + } + OInInt b int -> return cfp { cfpInput = printInterface int + , cfpInputEn = True + , cfpInputInv = not b + } + OOutInt b int -> return cfp { cfpOutput = printInterface int + , cfpOutputEn = True + , cfpOutputInv = not b + } + OState stateSet -> return cfp { cfpStateEn = True + , cfpState = stateSet + } + OModule _ -> return cfp + a -> throwError $ "option is not supported yet: " ++ show a + +isFiltTarget :: FormEntry -> Bool +isFiltTarget (FEFiltTar _ _ _) = True +isFiltTarget _ = False + +isNatPrerOutTarget :: FormEntry -> Bool +isNatPrerOutTarget (FENatPrerOutTar _ _ _ _ _ _ _) = True +isNatPrerOutTarget _ = False + +isNatPostrTarget :: FormEntry -> Bool +isNatPostrTarget (FENatPostrTar _ _ _ _ _ _ _) = True +isNatPostrTarget _ = False + +isNatUserTarget :: FormEntry -> Bool +isNatUserTarget (FENatUserTar _ _ _ _ _ _ _ _ _ _ _ _) = True +isNatUserTarget _ = False + +httpInputToFiltTar :: IptAdmin FFiltTar +httpInputToFiltTar = do + targetS <- getInputString "target" + case targetS of + "accept" -> return FAccept + "drop" -> return FDrop + "reject" -> return FReject + "userChain" -> return FFUserChain + a -> throwError $ "unsupported 'target' parameter: " ++ show a + +httpInputToRejectType :: IptAdmin RejectType +httpInputToRejectType = do + rtS <- getInputString "rejectType" + let rtE = parse (pWrapper rejectTypeParser) "rejectType" rtS + case rtE of + Left e -> throwError $ "Error while parsing parameter: " ++ show e + Right rt -> return rt + +httpInputToUserChain :: EditForm a => a -> IptAdmin String +httpInputToUserChain form = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + iptables <- getIptables + table <- case tableName of + "filter" -> return $ tFilter iptables + "nat" -> return $ tNat iptables + "mangle" -> return $ tMangle iptables + a -> throwError $ "invalid table: " ++ a + let userChains = getUserChains form chainName table + if null userChains + then return "" + else do + userChain <- getInputString "userChain" + if userChain `elem` userChains + then return userChain + else throwError $ "invalid user chain: " ++ userChain + +httpInputToNatPrerOutTar :: IptAdmin FNatPrerOutTar +httpInputToNatPrerOutTar = do + targetS <- getInputString "target" + case targetS of + "dnat" -> return FDNat + "redirect" -> return FRedirect + "userChain" -> return FNPrerUserChain + a -> throwError $ "Invalid 'target' parameter: " ++ show a + +httpInputToNatPostrTar :: IptAdmin FNatPostrTar +httpInputToNatPostrTar = do + targetS <- getInputString "target" + case targetS of + "masquerade" -> return FMasq + "snat" -> return FSNat + "userChain" -> return FNPostrUserChain + a -> throwError $ "Invalid 'target' parameter: " ++ show a + +httpInputToNatUserTar :: IptAdmin FNatUserTar +httpInputToNatUserTar = do + targetS <- getInputString "target" + case targetS of + "dnat" -> return FUDNat + "redirect" -> return FURedirect + "snat" -> return FUSNat + "masquerade" -> return FUMasq + "userChain" -> return FNUserUserChain + a -> throwError $ "Invalid 'target' parameter: " ++ show a + +httpInputToComParams :: Bool -> Bool -> IptAdmin CommonFormPars +httpInputToComParams inDev outDev = + CommonFormPars <$> isThereInput "sourceEnable" + <*> isThereInput "sourceInv" + <*> getInputString "source" + <*> isThereInput "destinationEnable" + <*> isThereInput "destinationInv" + <*> getInputString "destination" + <*> isThereInput "protocolEnable" + <*> isThereInput "protocolInv" + <*> ( do + protS <- getInputString "protocol" + case protS of + "tcp" -> return FTCP + "udp" -> return FUDP + "icmp" -> return FICMP + a -> throwError $ "unsupported 'protocol' parameter: " ++ show a + ) + <*> isThereInput "sportEnable" + <*> isThereInput "sportInv" + <*> getInputString "sport" + <*> isThereInput "dportEnable" + <*> isThereInput "dportInv" + <*> getInputString "dport" + <*> isThereInput "inputEnable" + <*> isThereInput "inputInv" + <*> ( if inDev then getInputString "input" + else return "" + ) + <*> isThereInput "outputEnable" + <*> isThereInput "outputInv" + <*> ( if outDev then getInputString "output" + else return "" + ) + <*> isThereInput "stateEnable" + <*> ( do + invalid <- isThereInput "stateInvalid" + let invalidSet = if invalid then singleton CStInvalid + else empty + established <- isThereInput "stateEstablished" + let establishedSet = if established then singleton CStEstablished + else empty + new <- isThereInput "stateNew" + let newSet = if new then singleton CStNew + else empty + related <- isThereInput "stateRelated" + let relatedSet = if related then singleton CStRelated + else empty + untracked <- isThereInput "stateUntracked" + let untrackedSet = if untracked then singleton CStUntracked + else empty + let stateSet = invalidSet + `union` establishedSet + `union` newSet + `union` relatedSet + `union` untrackedSet + return stateSet + ) diff --git a/src/IptAdmin/EditForm/Render.hs b/src/IptAdmin/EditForm/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditForm/Render.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.EditForm.Render where + +import Data.Monoid +import Data.Set (member) +import Data.String +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Types +import Iptables.Types +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +checkBox :: String -> Bool -> Html +checkBox name on = do + let chBox = H.input ! A.type_ "checkbox" ! A.name (fromString name) ! A.value "on" + if on then chBox ! A.checked "checked" + else chBox + +printMesTd :: ResMessage -> Html +printMesTd rm = H.td $ fromString $ case rm of + RMError mes -> mes + RMSucc mes -> "ok " ++ mes + RMIgnore -> "ignored" + +maybeListToListMaybe :: Maybe [a] -> [Maybe a] +maybeListToListMaybe (Just list) = map Just list +maybeListToListMaybe Nothing = repeat Nothing + +editFormHtml :: EditForm a => (String,String,Int,[String]) -> a -> Maybe [ResMessage] -> Html +editFormHtml (tableName, chainName, rulePos, userChainNames) form errorListMay = + let entryList = toEntryList form + mesListMay = maybeListToListMaybe errorListMay + in + H.div ! A.class_ "editForm" $ + H.form ! A.id "editform" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "table" ! A.value (fromString tableName) + H.input ! A.type_ "hidden" ! A.name "chain" ! A.value (fromString chainName) + H.input ! A.type_ "hidden" ! A.name "rulePos" ! A.value (fromString $ show rulePos) + H.table ! A.class_ "editForm" $ do + H.tr $ do + H.th "Option" + H.th "Not" + H.th "Parameter" + maybe mempty (\_-> H.th "Message") errorListMay + mapM_ (renderFormEntry userChainNames) $ zip entryList mesListMay + H.input ! A.id "check" ! A.name "submit" ! A.type_ "submit" ! A.value "Check" + H.input ! A.id "submit" ! A.name "submit" ! A.type_ "submit" ! A.value "Submit" + +renderFormEntry :: [String] -> (FormEntry, Maybe ResMessage) -> Html +renderFormEntry _ (FESrc en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Source" >> H.br + checkBox "sourceEnable" en + H.td $ do + "!" + checkBox "sourceInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "source" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEDst en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Destination" >> H.br + checkBox "destinationEnable" en + H.td $ do + "!" + checkBox "destinationInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "destination" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEProt en inv prot, resMesMay) = + H.tr $ do + H.td $ do + "Protocol" >> H.br + checkBox "protocolEnable" en + H.td $ do + "!" + checkBox "protocolInv" inv + H.td $ + H.select ! A.id "protocol" ! A.name "protocol" $ do + let tcpOpt = H.option ! A.value "tcp" $ "TCP" + let udpOpt = H.option ! A.value "udp" $ "UDP" + let icmpOpt = H.option ! A.value "icmp" $ "ICMP" + case prot of + FTCP -> do + tcpOpt ! A.selected "selected" + udpOpt >> icmpOpt + FUDP -> do + tcpOpt + udpOpt ! A.selected "selected" + icmpOpt + FICMP -> do + tcpOpt >> udpOpt + icmpOpt ! A.selected "selected" + maybe mempty printMesTd resMesMay +renderFormEntry _ (FESPort en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Source port" >> H.br + checkBox "sportEnable" en + H.td $ do + "!" + checkBox "sportInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "sport" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEDPort en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Destination port" >> H.br + checkBox "dportEnable" en + H.td $ do + "!" + checkBox "dportInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "dport" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEInput en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Input interface" >> H.br + checkBox "inputEnable" en + H.td $ do + "!" + checkBox "inputInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "input" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEOutput en inv str, resMesMay) = + H.tr $ do + H.td $ do + "Output interface" >> H.br + checkBox "outputEnable" en + H.td $ do + "!" + checkBox "outputInv" inv + H.td $ + H.input ! A.type_ "text" ! A.name "output" ! A.value (fromString str) + maybe mempty printMesTd resMesMay +renderFormEntry _ (FEState en stateSet, resMesMay) = + H.tr $ do + H.td $ do + "State" >> H.br + checkBox "stateEnable" en + H.td "" + H.td $ do + checkBox "stateNew" $ CStNew `member` stateSet + "New" >> H.br + checkBox "stateEstablished" $ CStEstablished `member` stateSet + "Established" >> H.br + checkBox "stateRelated" $ CStRelated `member` stateSet + "Related" >> H.br + checkBox "stateInvalid" $ CStInvalid `member` stateSet + "Invalid" >> H.br + checkBox "stateUntracked" $ CStUntracked `member` stateSet + "Untracked" >> H.br + maybe mempty printMesTd resMesMay + +renderFormEntry userChainNames (FEFiltTar filtTar rejectType userChain, resMesMay) = + H.tr $ do + H.td ! A.colspan "3" ! A.class_ "inline" $ + H.table ! A.class_ "inline" $ do + H.tr $ do + H.th ! A.class_ "target" $ "Target" + H.th ! A.class_ "targetParam" $ "Parameters" + H.tr $ do + H.td ! A.class_ "target" $ do + let acceptRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "accept" + case filtTar of + FAccept -> acceptRadio ! A.checked "checked" + _ -> acceptRadio + "Acccept" + H.td ! A.class_ "targetParam" $ "" + H.tr $ do + H.td ! A.class_ "target" $ do + let dropRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "drop" + case filtTar of + FDrop -> dropRadio ! A.checked "checked" + _ -> dropRadio + "Drop" + H.td ! A.class_ "targetParam" $ "" + H.tr $ do + H.td ! A.class_ "target" $ do + let rejectRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "reject" + case filtTar of + FReject -> rejectRadio ! A.checked "checked" + _ -> rejectRadio + "Reject" >> H.br + H.td ! A.class_ "targetParam" $ + H.select ! A.id "rejectType" ! A.name "rejectType" $ + let + netUnrOpt = H.option ! A.value "icmp-net-unreachable" $ "Icmp-net-unreachable" + netUnrOptSel = if rejectType == RTNetUnreachable then netUnrOpt ! A.selected "selected" + else netUnrOpt + hostUnrOpt = H.option ! A.value "icmp-host-unreachable" $ "Icmp-host-unreachable" + hostUnrOptSel = if rejectType == RTHostUnreachable then hostUnrOpt ! A.selected "selected" + else hostUnrOpt + portUnrOpt = H.option ! A.value "icmp-port-unreachable" $ "Icmp-port-unreachable" + portUnrOptSel = if rejectType == RTPortUnreachable then portUnrOpt ! A.selected "selected" + else portUnrOpt + protoUnrOpt = H.option ! A.value "icmp-proto-unreachable" $ "Icmp-proto-unreachable" + protoUnrOptSel = if rejectType == RTProtoUnreachable then protoUnrOpt ! A.selected "selected" + else protoUnrOpt + netProhOpt = H.option ! A.value "icmp-net-prohibited" $ "Icmp-net-prohibited" + netProhOptSel = if rejectType == RTNetProhibited then netProhOpt ! A.selected "selected" + else netProhOpt + hostProhOpt = H.option ! A.value "icmp-host-prohibited" $ "Icmp-host-prohibited" + hostProhOptSel = if rejectType == RTHostProhibited then hostProhOpt ! A.selected "selected" + else hostProhOpt + admProhOpt = H.option ! A.value "icmp-admin-prohibited" $ "Icmp-admin-prohibited" + admProhOptSel = if rejectType == RTAdminProhibited then admProhOpt ! A.selected "selected" + else admProhOpt + tcpResetOpt = H.option ! A.value "tcp-reset" $ "Tcp-reset" + tcpResetOptSel = if rejectType == RTTcpReset then tcpResetOpt ! A.selected "selected" + else tcpResetOpt + in + netUnrOptSel + >> hostUnrOptSel + >> portUnrOptSel + >> protoUnrOptSel + >> netProhOptSel + >> hostProhOptSel + >> admProhOptSel + >> tcpResetOptSel + if not $ null userChainNames + then + let checked = case filtTar of + FFUserChain -> True + _ -> False + in renderUserChain checked userChainNames userChain + else mempty + maybe mempty printMesTd resMesMay +renderFormEntry userChainNames (FENatPrerOutTar natPrerTar dnataddr dnatrand dnatpersist redirport redirrand userChain, resMesMay) = + H.tr $ do + H.td ! A.colspan "3" ! A.class_ "inline" $ + H.table ! A.class_ "inline" $ do + H.tr $ do + H.th ! A.class_ "target" $ "Target" + H.th ! A.class_ "targetParam" $ "Parameters" + let checked = case natPrerTar of + FDNat -> True + _ -> False + renderDNat checked dnataddr dnatrand dnatpersist + let checked' = case natPrerTar of + FRedirect -> True + _ -> False + renderRedirect checked' redirport redirrand + if not $ null userChainNames + then + let checked'' = case natPrerTar of + FNPrerUserChain -> True + _ -> False + in renderUserChain checked'' userChainNames userChain + else mempty + maybe mempty printMesTd resMesMay +renderFormEntry userChainNames (FENatPostrTar natPostrTar snataddr snatrand snatpersist masqport masqrand userChain, resMesMay) = + H.tr $ do + H.td ! A.colspan "3" ! A.class_ "inline" $ + H.table ! A.class_ "inline" $ do + H.tr $ do + H.th ! A.class_ "target" $ "Target" + H.th ! A.class_ "targetParam" $ "Parameters" + let checked = case natPostrTar of + FMasq -> True + _ -> False + renderMasq checked masqport masqrand + let checked' = case natPostrTar of + FSNat -> True + _ -> False + renderSNat checked' snataddr snatrand snatpersist + if not $ null userChainNames + then + let checked'' = case natPostrTar of + FNPostrUserChain -> True + _ -> False + in renderUserChain checked'' userChainNames userChain + else + mempty + maybe mempty printMesTd resMesMay +renderFormEntry userChainNames (FENatUserTar natUserTar dnatAddr dnatRand dnatPersist redirPort redirRand snatAddr snatRand snatPersist masqPort masqRand userChain, resMesMay) = + H.tr $ do + H.td ! A.colspan "3" ! A.class_ "inline" $ + H.table ! A.class_ "inline" $ do + H.tr $ do + H.th ! A.class_ "target" $ "Target" + H.th ! A.class_ "targetParam" $ "Parameters" + let checked = case natUserTar of + FUDNat -> True + _ -> False + renderDNat checked dnatAddr dnatRand dnatPersist + let checked' = case natUserTar of + FURedirect -> True + _ -> False + renderRedirect checked' redirPort redirRand + let checked'' = case natUserTar of + FUSNat -> True + _ -> False + renderSNat checked'' snatAddr snatRand snatPersist + let checked''' = case natUserTar of + FUMasq -> True + _ -> False + renderMasq checked''' masqPort masqRand + if not $ null userChainNames + then + let checked'''' = case natUserTar of + FNUserUserChain -> True + _ -> False + in renderUserChain checked'''' userChainNames userChain + else + mempty + maybe mempty printMesTd resMesMay +renderFormEntry _ a = H.tr $ fromString $ "Unknown form entry: " ++ show a + +renderDNat :: Bool -> String -> Bool -> Bool -> Html +renderDNat checked dnatAddr dnatRand dnatPersist = + H.tr $ do + H.td ! A.class_ "target" $ do + let dnatRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "dnat" + if checked then dnatRadio ! A.checked "checked" + else dnatRadio + "Destination Nat" + H.td ! A.class_ "targetParam" $ do + "dnat address:" + H.input ! A.type_ "text" ! A.name "dnataddress" ! A.value (fromString dnatAddr) >> H.br + "random:" + checkBox "dnatrandom" dnatRand >> H.br + "persistent:" + checkBox "dnatpersistent" dnatPersist >> H.br + +renderRedirect :: Bool -> String -> Bool -> Html +renderRedirect checked redirPort redirRand = + H.tr $ do + H.td ! A.class_ "target" $ do + let redirRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "redirect" + if checked then redirRadio ! A.checked "checked" + else redirRadio + "Redirect" + H.td ! A.class_ "targetParam" $ do + "port:" + H.input ! A.type_ "text" ! A.name "redirport" ! A.value (fromString redirPort) >> H.br + "random:" + checkBox "redirrandom" redirRand + +renderSNat :: Bool -> String -> Bool -> Bool -> Html +renderSNat checked snatAddr snatRand snatPersist = + H.tr $ do + H.td ! A.class_ "target" $ do + let snatRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "snat" + if checked then snatRadio ! A.checked "checked" + else snatRadio + "Source Nat" + H.td ! A.class_ "targetParam" $ do + "snat address:" + H.input ! A.type_ "text" ! A.name "snataddress" ! A.value (fromString snatAddr) >> H.br + "random:" + checkBox "snatrandom" snatRand >> H.br + "persistent:" + checkBox "snatpersistent" snatPersist >> H.br +renderMasq :: Bool -> String -> Bool -> Html +renderMasq checked masqPort masqRand = + H.tr $ do + H.td ! A.class_ "target" $ do + let masqRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "masquerade" + if checked then masqRadio ! A.checked "checked" + else masqRadio + "Masquerade" + H.td ! A.class_ "targetParam" $ do + "port:" + H.input ! A.type_ "text" ! A.name "masqport" ! A.value (fromString masqPort) >> H.br + "random:" + checkBox "masqrandom" masqRand + +renderUserChain :: Bool -> [String] -> String -> Html +renderUserChain checked allChains chain = + H.tr $ do + H.td ! A.class_ "target" $ do + let userChainRadio = H.input ! A.type_ "radio" ! A.name "target" ! A.value "userChain" + if checked then userChainRadio ! A.checked "checked" + else userChainRadio + "User chain" + H.td ! A.class_ "targetParam" $ + H.select ! A.id "userChain" ! A.name "userChain" $ + mapM_ (renderOption chain) allChains + where + renderOption :: String -> String -> Html + renderOption selName optName = do + let opt = H.option ! A.value (fromString optName) $ fromString optName + let optSel = if optName == selName then opt ! A.selected "selected" + else opt + optSel diff --git a/src/IptAdmin/EditForm/Types.hs b/src/IptAdmin/EditForm/Types.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditForm/Types.hs @@ -0,0 +1,261 @@ + +module IptAdmin.EditForm.Types where + +import Data.Set (Set, empty) +import Iptables.Types + +data FormEntry = FESrc { feEn :: Bool + , feInv :: Bool + , feSrc :: String + } + | FEDst { feEn :: Bool + , feInv :: Bool + , feDst :: String + } + | FEProt { feEn :: Bool + , feInv :: Bool + , feProt :: FProtocol + } + | FESPort { feEn :: Bool + , feInv :: Bool + , feSPort :: String + } + | FEDPort { feEn :: Bool + , feInv :: Bool + , feDPort :: String + } + | FEInput { feEn :: Bool + , feInv :: Bool + , feInput :: String + } + | FEOutput { feEn :: Bool + , feInv :: Bool + , feOutput :: String + } + | FEState { feEn :: Bool + , feState :: Set CState + } + | FEFiltTar { feFiltTar :: FFiltTar + , feRejectType :: RejectType + , feUserChain :: String + } + | FENatPrerOutTar { feNatPrerTar :: FNatPrerOutTar + , feDNatAddr :: String + , feDNatRand :: Bool + , feDNatPersist :: Bool + , feRedirPort :: String + , feRedirRand :: Bool + , feUserChain :: String + } + | FENatPostrTar { feNatPostrTar :: FNatPostrTar + , feSNatAddr :: String + , feSNatRand :: Bool + , feSNatPersist :: Bool + , feMasqPort :: String + , feMasqRand :: Bool + , feUserChain :: String + } + | FENatUserTar { feNatUserTar :: FNatUserTar + , feDNatAddr :: String + , feDNatRand :: Bool + , feDNatPersist :: Bool + , feRedirPort :: String + , feRedirRand :: Bool + , feSNatAddr :: String + , feSNatRand :: Bool + , feSNatPersist :: Bool + , feMasqPort :: String + , feMasqRand :: Bool + , feUserChain :: String + } + | FEMangTar { feMangTar :: FMangTar + , feUserChain :: String + } + deriving (Show, Eq) + +data CommonFormPars = CommonFormPars { cfpSrcEn :: Bool + , cfpSrcInv :: Bool -- Парметры *Inv означают "установлена ли галочка !" + , cfpSrc :: String + , cfpDestEn :: Bool + , cfpDestInv :: Bool + , cfpDest :: String + , cfpProtEn :: Bool + , cfpProtInv :: Bool + , cfpProt :: FProtocol + , cfpSPortEn :: Bool + , cfpSPortInv :: Bool + , cfpSPort :: String + , cfpDPortEn :: Bool + , cfpDPortInv :: Bool + , cfpDPort :: String + , cfpInputEn :: Bool + , cfpInputInv :: Bool + , cfpInput :: String + , cfpOutputEn :: Bool + , cfpOutputInv :: Bool + , cfpOutput :: String + -- у state можно не использовать . iptables внутри заменяет отрицание на задание всех остальных состояний. + , cfpStateEn :: Bool + , cfpState :: Set CState + } + +nullComPars :: CommonFormPars +nullComPars = CommonFormPars False + False + "" + False + False + "" + False + False + FTCP + False + False + "" + False + False + "" + False + False + "" + False + False + "" + False + empty + +commParamsToList :: Bool -> Bool -> CommonFormPars -> [FormEntry] +commParamsToList inDev outDev comPar = + [ FESrc (cfpSrcEn comPar) + (cfpSrcInv comPar) + (cfpSrc comPar) + ] + ++ [ FEDst (cfpDestEn comPar) + (cfpDestInv comPar) + (cfpDest comPar) + ] + ++ [ FEProt (cfpProtEn comPar) + (cfpProtInv comPar) + (cfpProt comPar) + ] + ++ [ FESPort (cfpSPortEn comPar) + (cfpSPortInv comPar) + (cfpSPort comPar) + ] + ++ [ FEDPort (cfpDPortEn comPar) + (cfpDPortInv comPar) + (cfpDPort comPar) + ] + ++ [ FEInput (cfpInputEn comPar) + (cfpInputInv comPar) + (cfpInput comPar) + | inDev ] + ++ [ FEOutput (cfpOutputEn comPar) + (cfpOutputInv comPar) + (cfpOutput comPar) + | outDev ] + ++ [ FEState (cfpStateEn comPar) + (cfpState comPar) + ] + +data FiltInpForm = FiltInpForm { fifCommonPars :: CommonFormPars + , fifTarget :: FFiltTar + , fifRejectType :: RejectType + , fifUserChain :: String + } + +data FiltForwForm = FiltForwForm { fffCommonPars :: CommonFormPars + , fffTarget :: FFiltTar + , fffRejectType :: RejectType + , fffUserChain :: String + } + +data FiltOutForm = FiltOutForm { fofCommonPars :: CommonFormPars + , fofTarget :: FFiltTar + , fofRejectType :: RejectType + , fofUserChain :: String + } + +data NatPrerForm = NatPrerForm { nrfCommonPars :: CommonFormPars + , nrfTarget :: FNatPrerOutTar + , nrfDNatAddr :: String + , nrfDNatRand :: Bool + , nrfDNatPersist :: Bool + , nrfRedirPort :: String + , nrfRedirRand :: Bool + , nrfUserChain :: String + } + +data NatPostrForm = NatPostrForm { npfCommonPars :: CommonFormPars + , npfTarget :: FNatPostrTar -- | Radio value + , npfSNatAddr :: String + , npfSNatRand :: Bool + , npfSNatPersist :: Bool + , npfMasqPort :: String + , npfMasqRand :: Bool + , npfUserChain :: String + } + +data NatOutForm = NatOutForm { nofCommonPars :: CommonFormPars + , nofTarget :: FNatPrerOutTar + , nofDNatAddr :: String + , nofDNatRand :: Bool + , nofDNatPersist :: Bool + , nofRedirPort :: String + , nofRedirRand :: Bool + , nofUserChain :: String + } + +data NatUserForm = NatUserForm { nufCommonPars :: CommonFormPars + , nufTarget :: FNatUserTar + , nufDNatAddr :: String + , nufDNatRand :: Bool + , nufDNatPersist :: Bool + , nufRedirPort :: String + , nufRedirRand :: Bool + , nufSNatAddr :: String + , nufSNatRand :: Bool + , nufSNatPersist :: Bool + , nufMasqPort :: String + , nufMasqRand :: Bool + , nufUserChain :: String + } + +data FProtocol = FTCP + | FUDP + | FICMP + deriving (Show, Eq) + +data FFiltTar = FAccept + | FDrop + | FReject + | FFUserChain + deriving (Show, Eq) + +data FNatPrerOutTar = FDNat + | FRedirect + | FNPrerUserChain + deriving (Show, Eq) + +data FNatPostrTar = FSNat + | FMasq + | FNPostrUserChain + deriving (Show, Eq) + +data FNatUserTar = FUDNat + | FURedirect + | FUSNat + | FUMasq + | FNUserUserChain + deriving (Show, Eq) + +data FMangTar = FTTL + | FTOS + | FMark + | FMUserChain + deriving (Show, Eq) + +data ResMessage = RMError String + | RMSucc String + | RMIgnore + deriving (Show, Eq) diff --git a/src/IptAdmin/EditForm/Utils.hs b/src/IptAdmin/EditForm/Utils.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditForm/Utils.hs @@ -0,0 +1,95 @@ + +module IptAdmin.EditForm.Utils where + +import Control.Monad.Error +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Types +import IptAdmin.System +import IptAdmin.Types +import Iptables.Types +import Iptables + +nullSelForm :: String -- ^ Table name + -> String -- ^ Chain name + -> IptAdmin PackedEditForm +nullSelForm tableName chainName = + case (tableName, chainName) of + ("filter", "INPUT") -> return $ PackedEditForm (nullForm :: FiltInpForm) + ("filter", "FORWARD") -> return $ PackedEditForm (nullForm :: FiltForwForm) + ("filter", "OUTPUT") -> return $ PackedEditForm (nullForm :: FiltOutForm) + ("nat", "PREROUTING") -> return $ PackedEditForm (nullForm :: NatPrerForm) + ("nat", "POSTROUTING") -> return $ PackedEditForm (nullForm :: NatPostrForm) + ("nat", "OUTPUT") -> return $ PackedEditForm (nullForm :: NatOutForm) + ("mangle", "PREROUTING") -> undefined + ("mangle", "INPUT") -> undefined + ("mangle", "FORWARD") -> undefined + ("mangle", "OUTPUT") -> undefined + ("mangle", "POSTROUTING") -> undefined + ("filter", _) -> return $ PackedEditForm (nullForm :: FiltForwForm) + ("nat", a) -> do + iptables <- getIptables + let chainType = guessNatChainType a $ tNat iptables + case chainType of + NatUnknownChain -> return $ PackedEditForm (nullForm :: NatUserForm) + NatInvalidChain -> return $ PackedEditForm (nullForm :: NatUserForm) + NatDNatChain -> return $ PackedEditForm (nullForm :: NatPrerForm) + NatSNatChain -> return $ PackedEditForm (nullForm :: NatPostrForm) + ("mangle", a) -> undefined a + (a,_) -> throwError $ "unknown table " ++ a + +httpInputToSelForm :: String -- ^ Table name + -> String -- ^ Chain name + -> IptAdmin PackedEditForm +httpInputToSelForm tableName chainName = + case (tableName, chainName) of + ("filter", "INPUT") -> fmap PackedEditForm (httpInputToForm :: IptAdmin FiltInpForm) + ("filter", "FORWARD") -> fmap PackedEditForm (httpInputToForm :: IptAdmin FiltForwForm) + ("filter", "OUTPUT") -> fmap PackedEditForm (httpInputToForm :: IptAdmin FiltOutForm) + ("nat", "PREROUTING") -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatPrerForm) + ("nat", "POSTROUTING") -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatPostrForm) + ("nat", "OUTPUT") -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatOutForm) + ("mangle", "PREROUTING") -> undefined + ("mangle", "INPUT") -> undefined + ("mangle", "FORWARD") -> undefined + ("mangle", "OUTPUT") -> undefined + ("mangle", "POSTROUTING") -> undefined + ("filter", _) -> fmap PackedEditForm (httpInputToForm :: IptAdmin FiltForwForm) + ("nat", a) -> do + iptables <- getIptables + let chainType = guessNatChainType a $ tNat iptables + case chainType of + NatUnknownChain -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatUserForm) + NatInvalidChain -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatUserForm) + NatDNatChain -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatPrerForm) + NatSNatChain -> fmap PackedEditForm (httpInputToForm :: IptAdmin NatPostrForm) + ("mangle", a) -> undefined a + (a,_) -> throwError $ "unknown table " ++ a + +ruleToSelForm :: Rule -- ^ Rule to convert + -> String -- ^ Table name + -> String -- ^ Chain name + -> IptAdmin PackedEditForm +ruleToSelForm rule tableName chainName = + case (tableName, chainName) of + ("filter", "INPUT") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin FiltInpForm) + ("filter", "FORWARD") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin FiltForwForm) + ("filter", "OUTPUT") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin FiltOutForm) + ("nat", "PREROUTING") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatPrerForm) + ("nat", "POSTROUTING") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatPostrForm) + ("nat", "OUTPUT") -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatOutForm) + ("mangle", "PREROUTING") -> undefined + ("mangle", "INPUT") -> undefined + ("mangle", "FORWARD") -> undefined + ("mangle", "OUTPUT") -> undefined + ("mangle", "POSTROUTING") -> undefined + ("filter", _) -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin FiltForwForm) + ("nat", a) -> do + iptables <- getIptables + let chainType = guessNatChainType a $ tNat iptables + case chainType of + NatUnknownChain -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatUserForm) + NatInvalidChain -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatUserForm) + NatDNatChain -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatPrerForm) + NatSNatChain -> fmap PackedEditForm (ruleToFormParams rule :: IptAdmin NatPostrForm) + ("mangle", a) -> undefined a + (a,_) -> throwError $ "unknown table " ++ a diff --git a/src/IptAdmin/EditPage.hs b/src/IptAdmin/EditPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditPage.hs @@ -0,0 +1,92 @@ +module IptAdmin.EditPage where + +import Control.Monad.Error +import Control.Monad.State +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditForm +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Render +import IptAdmin.EditForm.Utils +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Print +import Iptables.Types +import Safe +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + rulePosition <- getInputRead "pos" + + (table, _, rule) <- checkParams tableName chainName rulePosition + + (PackedEditForm formParams) <- ruleToSelForm rule tableName chainName + + let userChainNames = getUserChains formParams chainName table + + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit rule in '" ++ tableName + ++ "' table in '" ++ chainName + ++ "' chain in position " ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) formParams Nothing + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + rulePosition <- getInputRead "rulePos" + + (table, _, _) <- checkParams tableName chainName rulePosition + + (PackedEditForm addFormParams) <- httpInputToSelForm tableName chainName + let userChainNames = getUserChains addFormParams chainName table + + let checkResE = editPageProcessParams addFormParams + case checkResE of + Left formResp -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Edit rule in '" ++ tableName + ++ "' table in '" ++ chainName + ++ "' chain in position " ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) addFormParams $ Just formResp + Right (opts, tar, formResp) -> do + let (_, opts') = runState (mapM_ completeModules opts) opts + let rule = Rule opts' tar + + submit <- getInputString "submit" + case submit of + "Check" -> return $ buildResponse $ Template.htmlWrapper $ renderHtml (do + header tableName $ "Edit rule in '" ++ tableName + ++ "' table in '" ++ chainName + ++ "' chain in position " ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) addFormParams $ Just formResp + ) ++ printRuleCanonical rule + "Submit" -> do + tryChange (replaceRule tableName chainName rulePosition rule) + redir $ "/show?table=" ++ tableName + a -> throwError $ "Invalid value for 'submit' parameter: " ++ a + +checkParams :: String -> String -> Int -> IptAdmin ([Chain], Chain, Rule) +checkParams tableName chainName rulePosition = do + table <- getTable tableName + + let chainMay = getChainByName chainName table + chain <- maybe (throwError $ "Invalid chain name: " ++ chainName) + return + chainMay + + let ruleMay = cRules chain `atMay` (rulePosition - 1) + rule <- maybe (throwError $ "Rule index out of range: " ++ show rulePosition) + return + ruleMay + return (table, chain, rule) diff --git a/src/IptAdmin/EditPolicyForm/Render.hs b/src/IptAdmin/EditPolicyForm/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditPolicyForm/Render.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.EditPolicyForm.Render where + +import Data.Monoid +import Data.String +import Iptables.Types +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +editPolicyForm :: (String, String) -> Policy -> Html +editPolicyForm (tableName, chainName) policy = do + case policy of + ACCEPT -> mempty :: Html + DROP -> mempty :: Html + a -> fromString ("Unsupported policy type: " ++ show a) + H.div ! A.class_ "editForm" $ + H.form ! A.id "editPolicyForm" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "table" ! A.value (fromString tableName) + H.input ! A.type_ "hidden" ! A.name "chain" ! A.value (fromString chainName) + H.table $ do + H.tr $ + H.td $ do + let acceptRadio = H.input ! A.type_ "radio" ! A.name "policy" ! A.value "accept" + case policy of + ACCEPT -> acceptRadio ! A.checked "checked" + _ -> acceptRadio + "Accept" + H.tr $ + H.td $ do + let dropRadio = H.input ! A.type_ "radio" ! A.name "policy" ! A.value "drop" + case policy of + DROP -> dropRadio ! A.checked "checked" + _ -> dropRadio + "Drop" + H.input ! A.id "submit" ! A.name "submit" ! A.type_ "submit" ! A.value "Submit" diff --git a/src/IptAdmin/EditPolicyPage.hs b/src/IptAdmin/EditPolicyPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/EditPolicyPage.hs @@ -0,0 +1,64 @@ + +module IptAdmin.EditPolicyPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditPolicyForm.Render +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Types +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + table <- getTable tableName + let chainMay = getChainByName chainName table + chain <- maybe (throwError $ "Invalid chain name: " ++ chainName) return chainMay + + -- 1. Проверка того, что это встроенная цепочка (политика не PUNDEFINED) + policy <- case cPolicy chain of + PUNDEFINED -> throwError $ "Not builtin chain: " ++ show chain + a -> return a + -- 2. Отрисовка формы + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Change policy for '" ++ chainName ++ "' chain in '" ++ tableName ++ "' table" + editPolicyForm (tableName, chainName) policy + + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + table <- getTable tableName + let chainMay = getChainByName chainName table + chain <- maybe (throwError $ "Invalid chain name: " ++ chainName) return chainMay + + -- 1. Проверка того, что это встроенная цепочка (политика не PUNDEFINED) + policy <- case cPolicy chain of + PUNDEFINED -> throwError $ "Not builtin chain: " ++ show chain + a -> return a + + -- 2. Проверка параметра формы. + newPolicyS <- getInputNonEmptyString "policy" + newPolicy <- case newPolicyS of + "accept" -> return ACCEPT + "drop" -> return DROP + a -> throwError $ "Ivalid parameter 'policy': " ++ a + + -- 3. Если изменилось, применить изменения + if newPolicy == policy + then redir $ "/show?table=" ++ tableName + else do + tryChange (setPolicy tableName chainName newPolicy) + redir $ "/show?table=" ++ tableName diff --git a/src/IptAdmin/InsertPage.hs b/src/IptAdmin/InsertPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/InsertPage.hs @@ -0,0 +1,88 @@ + +module IptAdmin.InsertPage where + +import Control.Monad.Error +import Control.Monad.State +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.EditForm +import IptAdmin.EditForm.Render +import IptAdmin.EditForm.Class +import IptAdmin.EditForm.Utils +import IptAdmin.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Print +import Iptables.Types +import Text.Blaze.Renderer.Pretty (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + rulePosition <- getInputRead "pos" + table <- getTable tableName + checkParams table chainName rulePosition + + (PackedEditForm form) <- nullSelForm tableName chainName + let userChainNames = getUserChains form chainName table + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Insert rule in '" + ++ tableName ++ "' table in '" + ++ chainName ++ "' chain in position " + ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) form Nothing + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = do + tableName <- getInputNonEmptyString "table" + chainName <- getInputNonEmptyString "chain" + rulePosition <- getInputRead "pos" + table <- getTable tableName + checkParams table chainName rulePosition + + (PackedEditForm editFormParams) <- httpInputToSelForm tableName chainName + let userChainNames = getUserChains editFormParams chainName table + + let checkResE = editPageProcessParams editFormParams + case checkResE of + Left formResp -> return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header tableName $ "Insert rule in '" + ++ tableName ++ "' table in '" + ++ chainName ++ "' chain in position " + ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) editFormParams $ Just formResp + Right (opts, tar, formResp) -> do + let (_, opts') = runState (mapM_ completeModules opts) opts + let rule = Rule opts' tar + + submit <- getInputString "submit" + case submit of + "Check" -> return $ buildResponse $ Template.htmlWrapper $ renderHtml (do + header tableName $ "Insert rule in '" + ++ tableName ++ "' table in '" + ++ chainName ++ "' chain in position " + ++ show rulePosition + editFormHtml (tableName, chainName, rulePosition, userChainNames) editFormParams $ Just formResp + ) ++ printRuleCanonical rule + "Submit" -> do + tryChange (insertRule tableName chainName rulePosition rule) + redir $ "/show?table=" ++ tableName + a -> throwError $ "Invalid value for 'submit' parameter: " ++ a + +checkParams :: [Chain] -> String -> Int -> IptAdmin () +checkParams table chainName rulePosition = do + let chainMay = getChainByName chainName table + chain <- maybe (throwError $ "Invalid chain name: " ++ chainName) + return + chainMay + + when (rulePosition > 1 + length (cRules chain)) $ + throwError $ "Index of insertion too big: " ++ show rulePosition diff --git a/src/IptAdmin/LoginPage.hs b/src/IptAdmin/LoginPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/LoginPage.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.LoginPage where + +import Control.Monad.Error +import Data.IORef +import Data.Map (insert) +import Data.Monoid +import Data.String +import Data.Time +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.Render +import IptAdmin.Types +import IptAdmin.Utils +import System.Random +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Renderer.String (renderHtml) + +pageHandlers :: (String -> String -> IO (Maybe String)) -> IORef Sessions -> IptAdminAuth Response +pageHandlers authenticate sessionsIORef = + msum [ methodSP GET pageHandlerGet + , methodSP POST (pageHandlerPost authenticate sessionsIORef) + ] + +pageHandlerGet :: IptAdminAuth Response +pageHandlerGet = + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + title + loginForm "" Nothing + +pageHandlerPost :: (String -> String -> IO (Maybe String)) -> IORef Sessions -> IptAdminAuth Response +pageHandlerPost authenticate sessionsIORef = do + login <- getInputString "login" + password <- getInputString "password" + when (length login > 30) $ + throwError "Login is too long" + when (length password > 50) $ + throwError "Password is too long" + -- Первый этап проверки - проверка пользователя unix + authRes <- liftIO $ authenticate login password + case authRes of + Just errorMsg -> + return $ buildResponse $ htmlWrapper $ renderHtml $ do + title + loginForm login $ Just errorMsg + Nothing -> do + -- 1. Генерируем рандомный id + sessionId <- liftIO $ replicateM 50 $ randomRIO ('A', 'z') + -- 2. Добавляем установку кукиса в заголовок + -- 2.1. Собариаем cookie + let sessionIdCookie = mkCookie "sessionId" sessionId + addCookie (60 * 60 * 24 * 365 * 10) sessionIdCookie + -- 3. Обновляем состояние + curTime <- liftIO getCurrentTime + _ <- liftIO $ atomicModifyIORef sessionsIORef + (\ m -> (insert sessionId (Session curTime Nothing) m, ())) + -- 4. Редиректим на /show + redir "/show" + +loginForm :: String -> Maybe String -> Html +loginForm login mesMay = + H.div ! A.class_ "loginForm" $ do + H.div ! A.class_ "loginForm2" $ + H.form ! A.id "loginForm" ! A.method "post" $ do + H.table ! A.class_ "loginForm" $ do + H.tr $ do + H.td ! A.class_ "loginForm" $ + H.span ! A.class_ "loginForm" $ "login" + H.td ! A.class_ "loginForm" $ + H.input ! A.type_ "text" ! A.name "login" ! A.value (fromString login) ! A.maxlength "30" + H.tr $ do + H.td ! A.class_ "loginForm" $ + H.span ! A.class_ "loginForm" $ "password" + H.td ! A.class_ "loginForm" $ + H.input ! A.type_ "password" ! A.name "password" ! A.value "" ! A.maxlength "50" + H.input ! A.id "submit" ! A.name "submit" ! A.type_ "submit" ! A.value "Sign in" + maybe mempty fromString mesMay diff --git a/src/IptAdmin/Render.hs b/src/IptAdmin/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/Render.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.Render where + +import Data.List +import Data.Monoid (mempty) +import Data.String (fromString) +import Data.Version +import Iptables.Print +import Iptables.Types +import Paths_iptadmin (version) +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +header :: String -> String -> Html +header tableName pageHeader = do + let filterB = tableName == "filter" + let mangleB = tableName == "mangle" + let natB = tableName == "nat" + title + logout + links filterB natB mangleB + H.div ! A.class_ "pageHeader" $ + fromString pageHeader + +title :: Html +title = + H.div ! A.id "title" $ do + H.a ! A.class_ "title" ! A.href "/" $ "IptAdmin" + H.span ! A.class_ "version" $ + fromString $ intercalate "." $ map show $ versionBranch version + +-- Booleans says which link should be distinguished +links :: Bool -> Bool -> Bool -> Html +links filt nat mangle = + let + filtA = H.a ! A.href "/show?table=filter" $ "Filter" + natA = H.a ! A.href "/show?table=nat" $ "Nat" + mangleA = H.a ! A.href "/show?table=mangle" $ "Mangle" + in + H.div ! A.id "links" $ do + H.span $ + if filt then filtA ! A.class_ "activeTableLink" + else filtA ! A.class_ "tableLink" + " " + H.span $ + if nat then natA ! A.class_ "activeTableLink" + else natA ! A.class_ "tableLink" + " " + H.span $ + if mangle then mangleA ! A.class_ "activeTableLink" + else mangleA ! A.class_ "tableLink" + +logout :: Html +logout = + H.div ! A.class_ "logout" $ + H.a ! A.href "/logout" $ "Logout" + +renderTarget :: RuleTarget -> (Html, Html) +renderTarget target = case target of + TAccept -> (H.span ! A.class_ "acceptTarget" $ "ACCEPT", mempty) + TDrop -> (H.span ! A.class_ "dropTarget" $ "DROP", mempty) + TReject rejectType -> + let target' = H.span ! A.class_ "rejectTarget" $ "REJECT" + param = case rejectType 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" + in + (target', param) + TReturn -> (H.span ! A.class_ "returnTarget" $ "RETURN", mempty) + TSNat natAddr rand persist -> + let target' = H.span ! A.class_ "snatTarget" $ "SNAT" + param = do + fromString (printNatAddr natAddr) + " " + if rand then "random" + else mempty :: Html + " " + if persist then "persist" + else mempty :: Html + in + (target', param) + TDNat natAddr rand persist -> + let target' = H.span ! A.class_ "dnatTarget" $ "DNAT" + param = do + fromString (printNatAddr natAddr) + " " + if rand then "random" + else mempty :: Html + " " + if persist then "persist" + else mempty :: Html + in + (target', param) + TMasquerade natPort rand -> + let target' = H.span ! A.class_ "masqueradeTarget" $ "MASQUERADE" + param = do + case natPort of + NatPortDefault -> mempty :: Html + _ -> fromString (printNatPort natPort) + if rand then do + " " + "random" + else mempty :: Html + in + (target', param) + TRedirect natPort rand -> + let target' = H.span ! A.class_ "redirectTarget" $ "REDIRECT" + param = do + case natPort of + NatPortDefault -> mempty :: Html + _ -> fromString (printNatPort natPort) + if rand then do + " " + "random" + else mempty :: Html + in + (target', param) + TUChain chainName -> + let target' = H.span ! A.class_ "chainTarget" $ "CHAIN" + param = fromString chainName + in + (target', param) + TUnknown tName params -> + let target' = H.span ! A.class_ "unknownTarget" $ fromString tName + param = fromString $ unwords params + in (target', param) diff --git a/src/IptAdmin/ShowPage.hs b/src/IptAdmin/ShowPage.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/ShowPage.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.ShowPage where + +import Control.Monad.Error +import Happstack.Server.SimpleHTTP +import Template +import IptAdmin.Render +import IptAdmin.ShowPage.Render +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Iptables +import Iptables.Types +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Renderer.String (renderHtml) + +pageHandlers :: IptAdmin Response +pageHandlers = msum [ methodSP GET pageHandlerGet + , methodSP POST pageHandlerPost + ] + +pageHandlerGet :: IptAdmin Response +pageHandlerGet = do + table <- getInputOrEmptyString "table" + + iptables <- getIptables + + case table of + "" -> showFilter iptables + "filter" -> showFilter iptables + "nat" -> showNat iptables + "mangle" -> showMangle iptables + "raw" -> throwError "We're sorry, the Raw table is not supported yet" + a -> throwError $ "Invalid table parameter: " ++ a + +showFilter :: Iptables -> IptAdmin Response +showFilter iptables = do + let filter' = renderTable ("filter", "Filter") $ sortFilterTable $ tFilter iptables + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header "filter" "Iptables Filter table" + showPageHtml filter' + +showNat :: Iptables -> IptAdmin Response +showNat iptables = do + let nat = renderTable ("nat", "Nat") $ sortNatTable $ tNat iptables + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header "nat" "Iptables Nat table" + showPageHtml nat + +showMangle :: Iptables -> IptAdmin Response +showMangle iptables = do + let mangle = renderTable ("mangle", "Mangle") $ sortMangleTable $ tMangle iptables + return $ buildResponse $ Template.htmlWrapper $ renderHtml $ do + header "mangle" "Iptables Mangle table. Unfortunately rule editing is not supported for Mangle yet." + showPageHtml mangle + +pageHandlerPost :: IptAdmin Response +pageHandlerPost = undefined + +showPageHtml :: Html -> Html +showPageHtml table = + H.div ! A.id "rules" $ + table diff --git a/src/IptAdmin/ShowPage/Render.hs b/src/IptAdmin/ShowPage/Render.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/ShowPage/Render.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IptAdmin.ShowPage.Render where + +import Data.Monoid +import Data.String +import IptAdmin.Render +import Iptables.Print +import Iptables.Types +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +isModule :: RuleOption -> Bool +isModule (OModule _) = True +isModule _ = False + +isOption :: RuleOption -> Bool +isOption = not. isModule + +renderIptables :: Iptables -> Html +renderIptables (Iptables f n m r) = + renderTable ("filter", "Filter") f + >> renderTable ("nat", "Nat") n + >> renderTable ("mangle", "Mangle") m + >> renderTable ("raw", "Raw") r + +renderTable :: (String, String) -- ^ (table name, table name for rendering) + -> [Chain] -- ^ table's chains + -> Html +renderTable (tableName, _) chains = do + mapM_ (renderChain tableName) chains + H.a ! A.href (fromString $ "/addchain?table="++tableName) $ "Add chain" + +-- | Table name -> Chain -> Html +renderChain :: String -> Chain -> Html +renderChain tableName (Chain n p _ rs) = + H.table ! A.class_ "rules" $ do + H.tr $ do + H.td ! A.colspan "3" $ + H.div ! A.id "chainName" $ fromString n + H.td ! A.class_ "rightAlign" ! A.colspan "3" $ + case p of + PUNDEFINED -> do + H.a ! A.class_ "button" + ! A.title "Delete chain" + ! A.href (fromString $ "/delchain?table="++tableName++"&chain="++n) + $ "X" + H.a ! A.class_ "button" + ! A.title "Edit chain name" + ! A.href (fromString $ "/editchain?table="++tableName++"&chain="++n) + $ "e" + a -> do + "Policy: " + H.a ! A.href (fromString $ "/editpolicy?table="++tableName++"&chain="++n) $ + fromString $ show a + H.tr $ do + H.th ! A.class_ "col1" $ "#" + H.th ! A.class_ "col2" $ "Modules" + H.th ! A.class_ "col3" $ "Options" + H.th ! A.class_ "col4" $ "Target" + H.th ! A.class_ "col5" $ "Target params" + H.th ! A.class_ "col6" $ "" + mapM_ (renderRule (tableName, n)) $ zip rs [1..] + H.tr $ + H.td ! A.colspan "6" $ + H.a ! A.href (fromString $ "/add?table="++tableName++"&chain="++n) $ "Add rule" + +-- | (Table name, Chain name) -> Rule -> Html +renderRule :: (String, String) -> (Rule, Int) -> Html +renderRule (tableName, chainName) (Rule opts tar , ruleNum) = + let mainTr = if even ruleNum then H.tr ! A.class_ "even" + else H.tr + mods' = filter isModule opts + opts' = filter isOption opts + mods'' = unwords $ map printOption mods' + opts'' = unwords $ map printOption opts' + (target', targetParam) = renderTarget tar + ruleEditable = tarEditable && optsEditable + tarEditable = case tar of + TUnknown _ _ -> False + _ -> True + optsEditable = all optEditable opts + optEditable opt = case opt of + OProtocol _ _ -> True + OSource _ _ -> True + ODest _ _ -> True + OInInt _ _ -> True + OOutInt _ _ -> True + OState _ -> True + OSourcePort _ _ -> True + ODestPort _ _ -> True + OModule _ -> True + _ -> False + in + mainTr $ do + H.td (fromString $ show ruleNum) + H.td $ fromString mods'' + H.td $ fromString opts'' + H.td target' + H.td targetParam + H.td $ do + H.a ! A.class_ "button" + ! A.title "Delete Rule" + ! A.href (fromString $ "/del?table="++tableName++"&chain="++chainName++"&pos=" ++ show ruleNum) + $ "X" + if ruleEditable then + H.a ! A.class_ "button" + ! A.title "Edit Rule" + ! A.href (fromString $ "/edit?table="++tableName++"&chain="++chainName++"&pos=" ++ show ruleNum) + $ "e" + else + mempty + H.a ! A.class_ "button" + ! A.title "Insert Rule" + ! A.href (fromString $ "/insert?table="++tableName++"&chain="++chainName++"&pos=" ++ show ruleNum) + $ "+" diff --git a/src/IptAdmin/System.hs b/src/IptAdmin/System.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/System.hs @@ -0,0 +1,187 @@ + +module IptAdmin.System where + +import Control.Concurrent +import Control.Monad.Error +import Control.Monad.State +import IptAdmin.Types +import Iptables.Parser +import Iptables.Print +import Iptables.Types +import System.Exit +import System.IO +import System.Process + +-- TODO: change waitForProcess to nonblocking version with timeout + +getIptablesSave :: IptAdmin String +getIptablesSave = do + (_, o, _, h) <- liftIO $ runInteractiveCommand "iptables-save" + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> liftIO $ hGetContents o + ExitFailure a -> throwError $ show a + +iptablesRestore :: String -> IO () +iptablesRestore iptablesStr = do + (i, _, _, h) <- runInteractiveCommand "iptables-restore" + forkIO $ hPutStr i iptablesStr + _ <- waitForProcess h + return () + +getIptables :: IptAdmin Iptables +getIptables = do + iprules <- getIptablesSave + let rE = parseIptables iprules + either (throwError . show) return rE + +getTable :: String -> IptAdmin [Chain] +getTable tableName = do + iptables <- getIptables + case tableName of + "filter" -> return $ tFilter iptables + "nat" -> return $ tNat iptables + "mangle" -> return $ tMangle iptables + "raw" -> return $ tRaw iptables + a -> throwError $ "Invalid table parameter: " ++ a + +-- | iptables -A +appendRule :: String -- ^ Table name + -> String -- ^ Chain name + -> Rule -- ^ Rule + -> IptAdmin () +appendRule table chain rule = do + let rule' = printRuleCanonical rule + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table ++ " -A " ++ chain ++ " " ++ rule' + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +-- | iptables -D +deleteRule :: String -- ^ Table name + -> String -- ^ Chain name + -> Int -- ^ Rule position + -> IptAdmin () +deleteRule table chain rulePos = do + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table + ++ " -D " ++ chain + ++ " " ++ show rulePos + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +-- | iptables -I +insertRule :: String -- ^ Table name + -> String -- ^ Chain name + -> Int -- ^ Rule position + -> Rule -- ^ Rule + -> IptAdmin () +insertRule table chain rulePos rule = do + let rule' = printRuleCanonical rule + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table + ++ " -I " ++ chain + ++ " " ++ show rulePos + ++ " " ++ rule' + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +replaceRule :: String -- ^ Table name + -> String -- ^ Chain name + -> Int -- ^ Rule position + -> Rule -- ^ Rule + -> IptAdmin () +replaceRule table chain rulePos rule = do + let rule' = printRuleCanonical rule + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table + ++ " -R " ++ chain + ++ " " ++ show rulePos + ++ " " ++ rule' + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +addChain :: String -- ^ Table name + -> String -- ^ Chain name + -> IptAdmin () +addChain table chainName = do + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table + ++ " -N " ++ chainName + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +renameChain :: String -- ^ Table name + -> String -- ^ Chain name + -> String -- ^ New chain name + -> IptAdmin () +renameChain table chainName newChainName = do + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ table + ++ " -E " ++ chainName -- --rename-chain + ++ " " ++ newChainName + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +-- | Delete user defined chain +deleteChain :: String -- ^ Table name + -> String -- ^ Chain name + -> IptAdmin () +deleteChain tableName chainName = do + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ tableName + ++ " -X " ++ chainName -- --delete-chain + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a + +-- | Set policy for builtin chain +setPolicy :: String -- ^ Table name + -> String -- ^ Chain name + -> Policy -- ^ New policy + -> IptAdmin () +setPolicy tableName chainName policy = do + policyStr <- case policy of + ACCEPT -> return "ACCEPT" + DROP -> return "DROP" + a -> throwError $ "Invalid policy: " ++ show a + (_, _, e, h) <- liftIO $ runInteractiveCommand $ "iptables -t " ++ tableName + ++ " -P " ++ chainName + ++ " " ++ policyStr + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a ++ "iptables -t " ++ tableName ++ " -P " ++ policyStr + +saveIptables :: IptAdmin () +saveIptables = do + (_, _, config) <- lift get + (_, _, e, h) <- liftIO $ runInteractiveCommand $ cSaveCommand config + ec <- liftIO $ waitForProcess h + case ec of + ExitSuccess -> return () + ExitFailure a -> do + err <- liftIO $ hGetContents e + throwError $ err ++ "\n" ++ show a diff --git a/src/IptAdmin/Types.hs b/src/IptAdmin/Types.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/Types.hs @@ -0,0 +1,30 @@ + +module IptAdmin.Types where + +import Control.Monad.Error +import Control.Monad.State +import Data.IORef +import Data.Map +import Data.Time +import Happstack.Server.SimpleHTTP + +-- | Authorization monad +type IptAdminAuth = ServerPartT (ErrorT String IO) + +-- | Main request handler monad +type IptAdmin = ServerPartT (ErrorT String (StateT MainState IO)) + +type SessionId = String + +type Sessions = Map SessionId Session + +data Session = Session { lastVisit :: UTCTime + , backup :: Maybe String + } + +type MainState = (SessionId, IORef Sessions, IptAdminConfig) + +data IptAdminConfig = IptAdminConfig { cSaveCommand :: String + , cPort :: Int + , cPamName :: String + } diff --git a/src/IptAdmin/Utils.hs b/src/IptAdmin/Utils.hs new file mode 100644 --- /dev/null +++ b/src/IptAdmin/Utils.hs @@ -0,0 +1,104 @@ +module IptAdmin.Utils where + +import Control.Concurrent +import Control.Monad.Error +import Control.Monad.State +import Data.IORef +import Data.Map +import Happstack.Server +import IptAdmin.System +import IptAdmin.Types +import Safe +import Text.ParserCombinators.Parsec.Prim hiding (State (..)) +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator + +buildResponse :: String -> Response +buildResponse input = let respPlain = toResponse input + in respPlain {rsHeaders = mkHeaders [("Content-type", "text/html; charset=utf8")]} + +redir :: Monad m => String -> ServerPartT m Response +redir url = seeOther url (toResponse "") + +getInputString :: Monad m => String -> ServerPartT (ErrorT String m) String +getInputString input = do + resM <- getDataFn $ look input + case resM of + Nothing -> throwError $ "Parameter not found: " ++ input + Just res -> return res + +getInputNonEmptyString :: String -> IptAdmin String +getInputNonEmptyString input = do + res <- getInputString input + if res == "" + then throwError $ "Parameter should not be empty: " ++ input + else return res + +getInputOrEmptyString :: String -> IptAdmin String +getInputOrEmptyString input = do + b <- isThereInput input + if not b + then + return "" + else + getInputString input + +getInputRead :: (Read a) => String -> IptAdmin a +getInputRead input = do + resS <- getInputString input + let resM = readMay resS + case resM of + Just res -> return res + Nothing -> throwError $ "Error while parsing parameter: " ++ input + +isThereInput :: String -> IptAdmin Bool +isThereInput input = do + resM <- getDataFn $ look input + return $ case resM of + Nothing -> False + Just _ -> True + +-- | Parser wrapper that checks eof +pWrapper :: GenParser Char st a -> GenParser Char st a +pWrapper p = spaces >> p >>= \ res -> spaces >> eof >> return res + +-- | Wrapper on firewall alteration, +-- it saves current iptables state +-- for emergency rollback +tryChange :: IptAdmin () -> IptAdmin () +tryChange action = do + -- Получаем id сессии + (sessionId, _, _) <- lift get + -- Добавляем в сессию iptablesStr + iptablesStr <- getIptablesSave + (_, sessionsIORef, _) <- lift get + liftIO $ atomicModifyIORef sessionsIORef $ \ m -> + let session = m ! sessionId + session' = session { backup = Just iptablesStr} + in + (insert sessionId session' m, ()) + -- Выполняем изменение файрволла + action + -- Форкаем ждущий поток и даём ему IORef + liftIO $ forkIO $ waitAndRollBack sessionsIORef sessionId + return () + +waitAndRollBack :: IORef Sessions -> String -> IO () +waitAndRollBack mainState sessionId = do + threadDelay $ 30 * 1000000 + -- Проверка состояния + iptablesStrMay <- atomicModifyIORef mainState $ \ m -> + let session = m ! sessionId + in + case backup session of + Nothing -> (m, Nothing) + Just iptablesStr -> + let session' = session {backup = Nothing} + m' = insert sessionId session' m + in + (m', Just iptablesStr) + -- Iptables restore + case iptablesStrMay of + Nothing -> return () + Just iptablesStr -> + iptablesRestore iptablesStr diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,100 @@ + +module Main where + +import Control.Concurrent (forkIO, killThread) +import Control.Exception +import Control.Monad.Error +import Control.Monad.State +import Data.IORef +import Data.Map +import Data.Monoid +import Happstack.Server.SimpleHTTP +import Happstack.State +import IptAdmin.AccessControl +import IptAdmin.AddChainPage as AddChainPage +import IptAdmin.AddPage as AddPage +import IptAdmin.Config +import IptAdmin.DelChainPage as DelChainPage +import IptAdmin.DelPage as DelPage +import IptAdmin.EditChainPage as EditChainPage +import IptAdmin.EditPage as EditPage +import IptAdmin.EditPolicyPage as EditPolicyPage +import IptAdmin.InsertPage as InsertPage +import IptAdmin.ShowPage as ShowPage +import IptAdmin.System +import IptAdmin.Types +import IptAdmin.Utils +import Network.Socket +import Prelude hiding (catch) +import System.Exit + +main :: IO () +main = do + configE <- catch (runErrorT getConfig) $ + \ e -> return $ Left $ show (e :: SomeException) + case configE of + Left e -> do + putStrLn e + exitFailure + Right config -> do + sessions <- newIORef empty + let httpConf = Conf (cPort config) Nothing + + -- create socket manually because we must listen only on 127.0.0.1 + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + loopbackIp <- inet_addr "127.0.0.1" + bindSocket sock $ + SockAddrInet (fromInteger $ toInteger $ cPort config) loopbackIp + listen sock (max 1024 maxListenQueue) + + httpTid <- forkIO $ simpleHTTPWithSocket' unpackErrorT + sock + httpConf + $ authorize sessions config control + + waitForTermination + putStrLn "Shutting down..." + killThread httpTid + putStrLn "Shutdown complete" + +unpackErrorT :: (Monad m) => UnWebT (ErrorT String m) a -> UnWebT m a +unpackErrorT handler = do + resE <- runErrorT handler + case resE of + Left err -> return $ Just (Left $ toResponse err, Set mempty) + Right x -> return x + +control :: IptAdmin Response +control = msum [ commitChange + , nullDir >> redir "/show" + , dir "logout" logout + , dir "show" ShowPage.pageHandlers + , dir "add" AddPage.pageHandlers + , dir "insert" InsertPage.pageHandlers + , dir "edit" EditPage.pageHandlers + , dir "del" DelPage.pageHandlers + , dir "addchain" AddChainPage.pageHandlers + , dir "editchain" EditChainPage.pageHandlers + , dir "delchain" DelChainPage.pageHandlers + , dir "editpolicy" EditPolicyPage.pageHandlers + ] + +{- | Save changes if user have changed something + He can access the program, so let's assume we haven't broken anything +-} +commitChange :: IptAdmin Response +commitChange = do + (sessionId, sessionsIORef, _) <- lift get + change <- liftIO $ atomicModifyIORef sessionsIORef $ \ m -> + let session = m ! sessionId + in + case backup session of + Nothing -> (m, False) + Just _ -> + let session' = session {backup = Nothing} + m' = insert sessionId session' m + in + (m', True) + when change saveIptables + mzero diff --git a/src/Template.hs b/src/Template.hs new file mode 100644 --- /dev/null +++ b/src/Template.hs @@ -0,0 +1,260 @@ +module Template where + +htmlWrapper content = unlines ["", + ""++"", + ""++"", + ""++"", + ""++" ", + ""++" Iptables Manager", + ""++" ", + ""++" ", + ""++" ", + ""++" ", + ""++" ", + ""++" ", + ""++" ", + ""++content, + ""++" ", + ""++"", + ""] diff --git a/util/ptmpl/Setup.hs b/util/ptmpl/Setup.hs new file mode 100644 --- /dev/null +++ b/util/ptmpl/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/util/ptmpl/ptmpl.cabal b/util/ptmpl/ptmpl.cabal new file mode 100644 --- /dev/null +++ b/util/ptmpl/ptmpl.cabal @@ -0,0 +1,20 @@ +Name: ptmpl +Version: 1.0.0 +Cabal-Version: >= 1.2 +Author: Evgeny Tarasov +Build-type: Simple +License: BSD3 +Copyright: (c) 2009 Evgeny Tarasov +Maintainer: etarasov.ekb@gmail.com +Stability: Stable +Synopsis: Source generator with embedding text(html) templates +Description: The simplest string template generator +Tested-with: GHC==6.10.3 + +Executable ptmpl + Build-Depends: base >= 3 && < 5, + haskell98, + parsec >= 2.1 + Main-Is: Main.hs + Hs-Source-Dirs: src + Ghc-options: -Wall -O2 -fno-warn-unused-do-bind diff --git a/util/ptmpl/src/Main.hs b/util/ptmpl/src/Main.hs new file mode 100644 --- /dev/null +++ b/util/ptmpl/src/Main.hs @@ -0,0 +1,75 @@ + +module Main where + +import System +import Text.ParserCombinators.Parsec + +main :: IO () +main = do + putStrLn "Starting plain templater" + args <- getArgs + let outFile = head args + input <- mapM readFile $ tail args + -- TODO: parse files separately + let outputE = parse ptemplParser "plain templater" $ unlines input + case outputE of + Left e -> print e + Right output -> do + putStrLn "Translation is completed successfully" + writeFile outFile output + +ptemplParser :: GenParser Char () String +ptemplParser = do + res <- concat `fmap` many tmplFunc + let header = "module Template where\n\n" + return $ header ++ res + +tmplFunc :: GenParser Char () String +tmplFunc = do + try $ manyTill anyChar $ + try $ string "\n" + lines' <- manyTill line $ + try $ string "" >> spaces + return $ unwords (funcName : funcParams) ++ " = unlines [\"\",\n" + ++ unlines lines' + ++ " \"\"]\n" + +param :: GenParser Char () String +param = do + res <- many1 alphaNum + spaces + return res + +line :: GenParser Char () String +line = do + elements <- manyTill lineElement $ char '\n' + return $ " \"\"" + ++ unwords elements + ++ "," + +lineElement :: GenParser Char () String +lineElement = inlineParam <|> plainString + +inlineParam :: GenParser Char () String +inlineParam = do + try $ string "!@#" + res <- many1 alphaNum + return $ "++" ++ res + +plainString :: GenParser Char () String +plainString = do + res <- manyTill anyChar + ( lookAhead (try $ string "!@#") + <|> lookAhead ((: []) `fmap` char '\n') + ) + return $ "++\"" ++ screenString res ++ "\"" + +screenString :: String -> String +screenString [] = [] +screenString (x : xs) | x == '"' = '\\' : '"' : screenString xs + | otherwise = x : screenString xs