Utils.hs

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