TrafficSelector.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module CLI.Commands.TrafficSelector where

import Control.Lens                        (Lens', (.=), use)
import Control.Monad                       (void, when)
import Control.Monad.IO.Class              (liftIO)
import Control.Monad.Trans.Maybe           (MaybeT(..), runMaybeT)
import CLI.Commands.Common
import CLI.Types
import Data.Default                        (def)
import Data.Maybe                          (fromMaybe)
import Control.Monad.State.Strict          (StateT, get, lift)
import StrongSwan.SQL
import System.Console.StructuredCLI hiding (Commands)
import Text.Read                           (readMaybe)

trafficSelectorType :: (Monad m) => Validator m TrafficSelectorType
trafficSelectorType = return . fromName

parseTSId :: (Monad m) => Validator m (Maybe Int)
parseTSId "new" = return $ Just Nothing
parseTSId str   = return $ Just <$> readMaybe str

cfgTrafficSelector :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTrafficSelector lens = do
  cfgTSType lens
  cfgTSProtocol lens
  cfgTSStartAddr lens
  cfgTSEndAddr lens
  cfgTSStartPort lens
  cfgTSEndPort lens

setTrafficSelector :: Maybe Int -> StateT AppState IO Action
setTrafficSelector mId = do
  ts <- case mId of
          Nothing ->
            return def
          Just iD -> do
            db <- use dbContext
            liftIO $ findTrafficSelector iD db
  ipsecSettings . getLocalTrafficSelector .= ts
  flush .= Just flushTrafficSelector
  return NewLevel

showTrafficSelector :: Commands ()
showTrafficSelector =
  command "show" "Display this traffic selector's parameters" $
    showTrafficSelector' getLocalTrafficSelector

showTrafficSelector' :: Lens' IPSecSettings TrafficSelector -> StateT AppState IO Action
showTrafficSelector' lens = do
  TrafficSelector {..} <- use $ ipsecSettings . lens
  let iD = _tsId >>= return . show
  liftIO $ do
    putStr "Traffic Selector "
    putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")"
    putStrLn $ "==================================";
    putStrLn $ "Type:          " ++ nameOf _tsType
    putStrLn $ "Protocol:      " ++ show _tsProtocol
    putStrLn $ "Start address: " ++ show _tsStartAddr
    putStrLn $ "End address:   " ++ show _tsEndAddr
    putStrLn $ "Start port:    " ++ show _tsStartPort
    putStrLn $ "End port:      " ++ show _tsEndPort
  return NoAction

cfgTSType :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSType lens =
    param "type" "<ipv4|ipv6>" trafficSelectorType $ \t -> do
      ipsecSettings . lens . tsType .= t
      flushIt

cfgTSProtocol :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSProtocol lens =
    param "protocol" "<protocol number>" integer $ \val -> do
      ipsecSettings . lens . tsProtocol .= val
      flushIt

cfgTSStartAddr :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSStartAddr lens =
    param "start-address" "<first IP address in range>" ipAddress $ \addr -> do
      ipsecSettings . lens .tsStartAddr .= addr
      flushIt

cfgTSEndAddr :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSEndAddr lens =
    param "end-address" "<last IP address in range>" ipAddress $ \addr -> do
      ipsecSettings . lens . tsEndAddr .= addr
      flushIt

cfgTSStartPort :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSStartPort lens =
    param "start-port" "<first L4 port number in range>" integer $ \port -> do
      ipsecSettings . lens . tsStartPort .= port
      flushIt

cfgTSEndPort :: Lens' IPSecSettings TrafficSelector -> Commands ()
cfgTSEndPort lens =
    param "end-port" "<last L4 port number in range>" integer $ \port -> do
      ipsecSettings . lens . tsEndPort .= port
      flushIt

flushTrafficSelector :: StateT AppState IO Action
flushTrafficSelector = do
    AppState{_ipsecSettings = IPSecSettings{_getLocalTrafficSelector=ts@TrafficSelector{..}}, ..} <- get
    Result {response = OK {..}, ..} <- lift $ writeTrafficSelector ts _dbContext
    when (okAffectedRows /= 1 ) $
      liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)"
    db <- use dbContext
    void . runMaybeT $ do
      ts' <- findTrafficSelector lastModifiedKey db
      lift $ ipsecSettings . getLocalTrafficSelector .= ts'
    return NoAction