iptadmin (empty) → 1.0.0
raw patch · 42 files changed
+3973/−0 lines, 42 filesdep +ConfigFiledep +basedep +blaze-htmlsetup-changed
Dependencies added: ConfigFile, base, blaze-html, bytestring, containers, filepath, happstack-server, happstack-state, happstack-util, haskell98, iptables-helpers, mtl, network, pam, parsec, process, random, safe, time, unix, utf8-string
Files
- Changelog +16/−0
- INSTALL +28/−0
- LICENSE +24/−0
- Makefile +36/−0
- Setup.hs +2/−0
- doc/examples/config/iptadmin.conf +3/−0
- doc/examples/init/iptadmin +24/−0
- doc/examples/pam/iptadmin +4/−0
- html/htmlwrapper.html +258/−0
- iptadmin.cabal +78/−0
- src/IptAdmin/AccessControl.hs +82/−0
- src/IptAdmin/AddChainPage.hs +61/−0
- src/IptAdmin/AddPage.hs +81/−0
- src/IptAdmin/Config.hs +27/−0
- src/IptAdmin/DelChainPage.hs +73/−0
- src/IptAdmin/DelChainPage/Render.hs +20/−0
- src/IptAdmin/DelPage.hs +62/−0
- src/IptAdmin/DelPage/Render.hs +19/−0
- src/IptAdmin/EditChainForm/Parse.hs +20/−0
- src/IptAdmin/EditChainForm/Render.hs +26/−0
- src/IptAdmin/EditChainPage.hs +72/−0
- src/IptAdmin/EditForm.hs +264/−0
- src/IptAdmin/EditForm/Class.hs +488/−0
- src/IptAdmin/EditForm/Render.hs +393/−0
- src/IptAdmin/EditForm/Types.hs +261/−0
- src/IptAdmin/EditForm/Utils.hs +95/−0
- src/IptAdmin/EditPage.hs +92/−0
- src/IptAdmin/EditPolicyForm/Render.hs +37/−0
- src/IptAdmin/EditPolicyPage.hs +64/−0
- src/IptAdmin/InsertPage.hs +88/−0
- src/IptAdmin/LoginPage.hs +80/−0
- src/IptAdmin/Render.hs +134/−0
- src/IptAdmin/ShowPage.hs +66/−0
- src/IptAdmin/ShowPage/Render.hs +117/−0
- src/IptAdmin/System.hs +187/−0
- src/IptAdmin/Types.hs +30/−0
- src/IptAdmin/Utils.hs +104/−0
- src/Main.hs +100/−0
- src/Template.hs +260/−0
- util/ptmpl/Setup.hs +2/−0
- util/ptmpl/ptmpl.cabal +20/−0
- util/ptmpl/src/Main.hs +75/−0
+ Changelog view
@@ -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.
+ INSTALL view
@@ -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.
+ LICENSE view
@@ -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.
+ Makefile view
@@ -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"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ doc/examples/config/iptadmin.conf view
@@ -0,0 +1,3 @@+save command = /etc/init.d/iptables save+port = 8000+pam name = iptadmin
+ doc/examples/init/iptadmin view
@@ -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
+ doc/examples/pam/iptadmin view
@@ -0,0 +1,4 @@+#%PAM-1.0+auth required pam_unix.so nullok+account required pam_unix.so+session required pam_unix.so
+ html/htmlwrapper.html view
@@ -0,0 +1,258 @@+<!--h htmlWrapper content h-->+<?xml version="1.0" encoding="utf-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+ <head>+ <title>Iptables Manager</title>+ <meta name="AUTHOR" content="Evgeny Tarasov" />+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+ <meta name="DESCRIPTION" content="description"/>+ <meta name="KEYWORDS" content="iptables, haskell" />+ <style type="text/css">+ body {+ font-family:Arial,Helvetica,sans-serif;+ background-color: #f7f7f7;+ color: #5b5b5b;+ }+ tr.even {+ background-color:#f0f0f0;+ }+ table {+ border-collapse : collapse;+ background-color: #ffffff;+ }+ th {+ background-color: #b7b7b7;+ color: #f7f7f7;+ }+ table, th, td {+ border: 1px dotted black;+ padding: 5px;+ }+ td.rightAlign {+ text-align:right;+ }+ a:link, a:visited {+ color: #856767;+ }+ a:hover {+ color: #bb1010;+ }+ a:active {+ color: #666666;+ }+ a.title:link, a.title:visited {+ color: #856767;+ text-decoration: none;+ }+ a.title:active, a.title:hover {+ text-decoration: underline;+ }+ a.button:link, a.button:visited {+ display: block;+ float: right;+ font-weigth: bold;+ color: #f7f7f7;+ background-color: #b5aaaa;+ width: 10px;+ padding: 0px 4px 0px 4px;+ margin: 0px 3px 0px 0px;+ text-decoration: none;+ text-align: center;+ }+ a.button:hover, a.button:active {+ background-color: #bb1010;+ }+ div.logout {+ float:right;+ padding: 20px;+ }+ #title {+ float: left;+ padding: 15px;+ color: #bbbbbb;+ font-size: 26px;+ }+ span.version {+ margin-left: 0.5em;+ font-size: 0.5em;+ }+ #links {+ margin-left: auto;+ margin-right: auto;+ width: 9.5em;+ padding: 20px;+ /*padding-left: 65px;+ */+ text-align: center;+ /*+ margin-left: 200px;+ */+ }+ a.activeTableLink:link, a.activeTableLink:visited {+ display: block;+ float:left;+ color: #f7f7f7;+ background-color: #b5aaaa;+ padding: 4px;+ margin: 0px 3px 0px 0px;+ text-decoration: none;+ }+ a.activeTableLink:hover, a.activeTableLink:active {+ background-color: #bb1010;+ }+ a.tableLink:link, a.tableLink:visited {+ display: block;+ float:left;+ color: #856767;+ background-color: #f7f7f7;+ padding: 4px;+ margin: 0px 3px 0px 0px;+ text-decoration: none;+ }+ a.tableLink:hover, a.tableLink:active {+ color: #bb1010;+ }+ #localLinks {+ float: left;+ background: #deeeee;+ margin-left: 100px;+ padding: 10px;+ }+ div.pageHeader {+ width: 50%;+ margin-top: 10px;+ margin-left: auto;+ margin-right: auto;+ text-align: center;+ }+ #rules {+ margin-left: auto;+ margin-right: auto;+ width: 100%;+ max-width: 1000px;+ padding-top: 10px;+ }+ div.loginForm {+ /*float: left;+ margin-left: auto;+ margin-right: auto;+ */+ position: absolute;+ top: 50%;+ left: 50%;+ margin-top: -40px;+ margin-left: -130px;+ }+ div.loginForm2 {+ height: 80px;+ width: 280px;+ background: #ffffff;+ border: 1px solid #666666;+ border-radius: 15px;+ -moz-border-radius: 15px;+ padding: 15px;+ text-align: center;+ }+ span.loginForm {+ color: #ababab;+ }+ table.loginForm, td.loginForm {+ border: none;+ padding: 0px;+ }+ td.loginForm {+ padding: 2px;+ }+ div.editForm {+ padding-top: 20px;+ margin-left: auto;+ margin-right: auto;+ max-width: 700px+ }+ table.rules {+ margin-top: 10px;+ border: 1px solid #666666;+ width: 100%;+ }+ table.editForm {+ border: 1px solid #666666;+ }+ th.col1 {+ width : 15px;+ }+ th.col4 {+ width : 60px;+ }+ th.col6 {+ width : 64px;+ }+ /*+ Цвета для различных targets+ */+ span.acceptTarget {+ color: #4e994f;+ }+ span.dropTarget {+ color: #dd2222;+ }+ span.rejectTarget {+ color: #a54638;+ }+ span.snatTarget {+ color: #7a997b;+ }+ span.masqueradeTarget {+ color: #4e994f;+ }+ span.dnatTarget {+ color: #77aac5;+ }+ span.redirectTarget {+ color: #7783c5;+ }+ span.chainTarget {+ color: #000000;+ }+ span.unknownTarget {+ color: #ababab;+ }+ /*+ Стили для вложенной таблицы и элемента таблицы,+ в которой вкладывается таблица+ */+ td.inline {+ margin: 0;+ padding: 0;+ }+ table.inline {+ border-style: none;+ width: 100%+ }+ /*+ Стили элементов таблиц для скрытия рамки вокруг таблицы,+ это приводило к утолщению сетки в местах сопряжения+ */+ th.target {+ border-left: none;+ border-top: none;+ }+ th.targetParam {+ border-right: none;+ border-top: none;+ }+ td.target {+ border-bottom: none;+ border-left: none;+ }+ td.targetParam {+ border-bottom: none;+ border-right: none;+ }+ </style>+ </head>+ <body>+!@#content+ </body>+</html>+<!--^^^-->
+ iptadmin.cabal view
@@ -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
+ src/IptAdmin/AccessControl.hs view
@@ -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"
+ src/IptAdmin/AddChainPage.hs view
@@ -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
+ src/IptAdmin/AddPage.hs view
@@ -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 ()
+ src/IptAdmin/Config.hs view
@@ -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
+ src/IptAdmin/DelChainPage.hs view
@@ -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
+ src/IptAdmin/DelChainPage/Render.hs view
@@ -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"
+ src/IptAdmin/DelPage.hs view
@@ -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)
+ src/IptAdmin/DelPage/Render.hs view
@@ -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"
+ src/IptAdmin/EditChainForm/Parse.hs view
@@ -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
+ src/IptAdmin/EditChainForm/Render.hs view
@@ -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"
+ src/IptAdmin/EditChainPage.hs view
@@ -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
+ src/IptAdmin/EditForm.hs view
@@ -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
+ src/IptAdmin/EditForm/Class.hs view
@@ -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+ )
+ src/IptAdmin/EditForm/Render.hs view
@@ -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
+ src/IptAdmin/EditForm/Types.hs view
@@ -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)
+ src/IptAdmin/EditForm/Utils.hs view
@@ -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
+ src/IptAdmin/EditPage.hs view
@@ -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)
+ src/IptAdmin/EditPolicyForm/Render.hs view
@@ -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"
+ src/IptAdmin/EditPolicyPage.hs view
@@ -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
+ src/IptAdmin/InsertPage.hs view
@@ -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
+ src/IptAdmin/LoginPage.hs view
@@ -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
+ src/IptAdmin/Render.hs view
@@ -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)
+ src/IptAdmin/ShowPage.hs view
@@ -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
+ src/IptAdmin/ShowPage/Render.hs view
@@ -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)+ $ "+"
+ src/IptAdmin/System.hs view
@@ -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
+ src/IptAdmin/Types.hs view
@@ -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+ }
+ src/IptAdmin/Utils.hs view
@@ -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
+ src/Main.hs view
@@ -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
+ src/Template.hs view
@@ -0,0 +1,260 @@+module Template where++htmlWrapper content = unlines ["",+ ""++"<?xml version=\"1.0\" encoding=\"utf-8\"?>",+ ""++"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">",+ ""++"<html xmlns=\"http://www.w3.org/1999/xhtml\">",+ ""++" <head>",+ ""++" <title>Iptables Manager</title>",+ ""++" <meta name=\"AUTHOR\" content=\"Evgeny Tarasov\" />",+ ""++" <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\" />",+ ""++" <meta name=\"DESCRIPTION\" content=\"description\"/>",+ ""++" <meta name=\"KEYWORDS\" content=\"iptables, haskell\" />",+ ""++" <style type=\"text/css\">",+ ""++" body {",+ ""++" font-family:Arial,Helvetica,sans-serif;",+ ""++" background-color: #f7f7f7;",+ ""++" color: #5b5b5b;",+ ""++" }",+ ""++" tr.even {",+ ""++" background-color:#f0f0f0;",+ ""++" }",+ ""++" table {",+ ""++" border-collapse : collapse;",+ ""++" background-color: #ffffff;",+ ""++" }",+ ""++" th {",+ ""++" background-color: #b7b7b7;",+ ""++" color: #f7f7f7;",+ ""++" }",+ ""++" table, th, td {",+ ""++" border: 1px dotted black;",+ ""++" padding: 5px;",+ ""++" }",+ ""++" td.rightAlign {",+ ""++" text-align:right;",+ ""++" }",+ ""++" a:link, a:visited {",+ ""++" color: #856767;",+ ""++" }",+ ""++" a:hover {",+ ""++" color: #bb1010;",+ ""++" }",+ ""++" a:active {",+ ""++" color: #666666;",+ ""++" }",+ ""++" a.title:link, a.title:visited {",+ ""++" color: #856767;",+ ""++" text-decoration: none;",+ ""++" }",+ ""++" a.title:active, a.title:hover {",+ ""++" text-decoration: underline;",+ ""++" }",+ ""++" a.button:link, a.button:visited {",+ ""++" display: block;",+ ""++" float: right;",+ ""++" font-weigth: bold;",+ ""++" color: #f7f7f7;",+ ""++" background-color: #b5aaaa;",+ ""++" width: 10px;",+ ""++" padding: 0px 4px 0px 4px;",+ ""++" margin: 0px 3px 0px 0px;",+ ""++" text-decoration: none;",+ ""++" text-align: center;",+ ""++" }",+ ""++" a.button:hover, a.button:active {",+ ""++" background-color: #bb1010;",+ ""++" }",+ ""++" div.logout {",+ ""++" float:right;",+ ""++" padding: 20px;",+ ""++" }",+ ""++" #title {",+ ""++" float: left;",+ ""++" padding: 15px;",+ ""++" color: #bbbbbb;",+ ""++" font-size: 26px;",+ ""++" }",+ ""++" span.version {",+ ""++" margin-left: 0.5em;",+ ""++" font-size: 0.5em;",+ ""++" }",+ ""++" #links {",+ ""++" margin-left: auto;",+ ""++" margin-right: auto;",+ ""++" width: 9.5em;",+ ""++" padding: 20px;",+ ""++" /*padding-left: 65px;",+ ""++" */",+ ""++" text-align: center;",+ ""++" /*",+ ""++" margin-left: 200px;",+ ""++" */",+ ""++" }",+ ""++" a.activeTableLink:link, a.activeTableLink:visited {",+ ""++" display: block;",+ ""++" float:left;",+ ""++" color: #f7f7f7;",+ ""++" background-color: #b5aaaa;",+ ""++" padding: 4px;",+ ""++" margin: 0px 3px 0px 0px;",+ ""++" text-decoration: none;",+ ""++" }",+ ""++" a.activeTableLink:hover, a.activeTableLink:active {",+ ""++" background-color: #bb1010;",+ ""++" }",+ ""++" a.tableLink:link, a.tableLink:visited {",+ ""++" display: block;",+ ""++" float:left;",+ ""++" color: #856767;",+ ""++" background-color: #f7f7f7;",+ ""++" padding: 4px;",+ ""++" margin: 0px 3px 0px 0px;",+ ""++" text-decoration: none;",+ ""++" }",+ ""++" a.tableLink:hover, a.tableLink:active {",+ ""++" color: #bb1010;",+ ""++" }",+ ""++" #localLinks {",+ ""++" float: left;",+ ""++" background: #deeeee;",+ ""++" margin-left: 100px;",+ ""++" padding: 10px;",+ ""++" }",+ ""++" div.pageHeader {",+ ""++" width: 50%;",+ ""++" margin-top: 10px;",+ ""++" margin-left: auto;",+ ""++" margin-right: auto;",+ ""++" text-align: center;",+ ""++" }",+ ""++" #rules {",+ ""++" margin-left: auto;",+ ""++" margin-right: auto;",+ ""++" width: 100%;",+ ""++" max-width: 1000px;",+ ""++" padding-top: 10px;",+ ""++" }",+ ""++" div.loginForm {",+ ""++" /*float: left;",+ ""++" margin-left: auto;",+ ""++" margin-right: auto;",+ ""++" */",+ ""++" position: absolute;",+ ""++" top: 50%;",+ ""++" left: 50%;",+ ""++" margin-top: -40px;",+ ""++" margin-left: -130px;",+ ""++" }",+ ""++" div.loginForm2 {",+ ""++" height: 80px;",+ ""++" width: 280px;",+ ""++" background: #ffffff;",+ ""++" border: 1px solid #666666;",+ ""++" border-radius: 15px;",+ ""++" -moz-border-radius: 15px;",+ ""++" padding: 15px;",+ ""++" text-align: center;",+ ""++" }",+ ""++" span.loginForm {",+ ""++" color: #ababab;",+ ""++" }",+ ""++" table.loginForm, td.loginForm {",+ ""++" border: none;",+ ""++" padding: 0px;",+ ""++" }",+ ""++" td.loginForm {",+ ""++" padding: 2px;",+ ""++" }",+ ""++" div.editForm {",+ ""++" padding-top: 20px;",+ ""++" margin-left: auto;",+ ""++" margin-right: auto;",+ ""++" max-width: 700px",+ ""++" }",+ ""++" table.rules {",+ ""++" margin-top: 10px;",+ ""++" border: 1px solid #666666;",+ ""++" width: 100%;",+ ""++" }",+ ""++" table.editForm {",+ ""++" border: 1px solid #666666;",+ ""++" }",+ ""++" th.col1 {",+ ""++" width : 15px;",+ ""++" }",+ ""++" th.col4 {",+ ""++" width : 60px;",+ ""++" }",+ ""++" th.col6 {",+ ""++" width : 64px;",+ ""++" }",+ ""++" /*",+ ""++" Цвета для различных targets",+ ""++" */",+ ""++" span.acceptTarget {",+ ""++" color: #4e994f;",+ ""++" }",+ ""++" span.dropTarget {",+ ""++" color: #dd2222;",+ ""++" }",+ ""++" span.rejectTarget {",+ ""++" color: #a54638;",+ ""++" }",+ ""++" span.snatTarget {",+ ""++" color: #7a997b;",+ ""++" }",+ ""++" span.masqueradeTarget {",+ ""++" color: #4e994f;",+ ""++" }",+ ""++" span.dnatTarget {",+ ""++" color: #77aac5;",+ ""++" }",+ ""++" span.redirectTarget {",+ ""++" color: #7783c5;",+ ""++" }",+ ""++" span.chainTarget {",+ ""++" color: #000000;",+ ""++" }",+ ""++" span.unknownTarget {",+ ""++" color: #ababab;",+ ""++" }",+ ""++" /*",+ ""++" Стили для вложенной таблицы и элемента таблицы,",+ ""++" в которой вкладывается таблица",+ ""++" */",+ ""++" td.inline {",+ ""++" margin: 0;",+ ""++" padding: 0;",+ ""++" }",+ ""++" table.inline {",+ ""++" border-style: none;",+ ""++" width: 100%",+ ""++" }",+ ""++" /*",+ ""++" Стили элементов таблиц для скрытия рамки вокруг таблицы,",+ ""++" это приводило к утолщению сетки в местах сопряжения",+ ""++" */",+ ""++" th.target {",+ ""++" border-left: none;",+ ""++" border-top: none;",+ ""++" }",+ ""++" th.targetParam {",+ ""++" border-right: none;",+ ""++" border-top: none;",+ ""++" }",+ ""++" td.target {",+ ""++" border-bottom: none;",+ ""++" border-left: none;",+ ""++" }",+ ""++" td.targetParam {",+ ""++" border-bottom: none;",+ ""++" border-right: none;",+ ""++" }",+ ""++" </style>",+ ""++" </head>",+ ""++" <body>",+ ""++content,+ ""++" </body>",+ ""++"</html>",+ ""]
+ util/ptmpl/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ util/ptmpl/ptmpl.cabal view
@@ -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
+ util/ptmpl/src/Main.hs view
@@ -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 "<!--h "+ spaces+ funcName <- many1 alphaNum+ spaces+ funcParams <- manyTill param $+ try $ string "h-->\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