ChildSA.hs

{-# LANGUAGE OverloadedStrings #-}
module CLI.Commands.ChildSA where

import Control.Lens                        ((.=))
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 Data.Text                           (Text,unpack)
import Control.Monad.State.Strict          (StateT, get, lift)
import StrongSwan.SQL
import System.Console.StructuredCLI hiding (Commands)

saAction :: (Monad m) => Validator m SAAction
saAction = return . fromName

saMode :: (Monad m) =>  Validator m SAMode
saMode = return . fromName

cfgChildSA :: Commands ()
cfgChildSA = do
  cfgLifeTime
  cfgRekeyTime
  cfgJitter
  cfgUpDown
  cfgHostAccess
  cfgSAMode
  cfgStartAction
  cfgDPDAction
  cfgCloseAction
  cfgIPCompression
  cfgReqID

setChildSA :: Text -> StateT AppState IO Action
setChildSA name = do
  childSA <- setConfig findChildSAConfigByName def { _childSAName = name } name
  ipsecSettings . getChildSAConfig .= childSA
  flush .= Just flushChildSA
  return NewLevel

showChildSA :: Commands ()
showChildSA =
  command "show" "Show this child SA configuration" showChildSA'

showChildSA' :: StateT AppState IO Action
showChildSA' = do
  AppState{_ipsecSettings = IPSecSettings{_getChildSAConfig=ChildSAConfig{..}}} <- get
  let iD = _childSAId >>= return . show
  liftIO $ do
    putStr "Child SA "
    when (_childSAName /= "") $ putStr $ '\'':unpack _childSAName ++ "\' "
    putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")"
    putStrLn $ "==================================";
    putStrLn $ "Lifetime:       " ++ show _childSALifeTime
    putStrLn $ "Rekeytime:      " ++ show _childSARekeyTime
    putStrLn $ "Jitter:         " ++ show _childSAJitter
    putStrLn $ "UpDown:         " ++ maybe "<none>" unpack _childSAUpDown
    putStrLn $ "HostAccess:     " ++ showEnabled _childSAHostAccess
    putStrLn $ "SA Mode:        " ++ nameOf _childSAMode
    putStrLn $ "Start Action:   " ++ nameOf _childSAStartAction
    putStrLn $ "DPD Action:     " ++ nameOf _childSADPDAction
    putStrLn $ "Close Action:   " ++ nameOf _childSACloseAction
    putStrLn $ "IP compression: " ++ showEnabled _childSAIPCompression
    putStrLn $ "Request ID:     " ++ show _childSAReqID
  return NoAction

cfgLifeTime :: Commands ()
cfgLifeTime =
    param "lifetime" "<SA lifetime in seconds>" integer $ \lifetime -> do
      ipsecSettings . getChildSAConfig . childSALifeTime .= lifetime
      flushIt

cfgRekeyTime :: Commands ()
cfgRekeyTime =
    param "rekeytime" "<SA rekey timeout in seconds>" integer $ \timeout -> do
    ipsecSettings . getChildSAConfig . childSARekeyTime .= timeout
    flushIt

cfgJitter :: Commands ()
cfgJitter =
    param "jitter" "<SA retransmit jitter>" integer $ \jitter -> do
    ipsecSettings . getChildSAConfig . childSAJitter .= jitter
    flushIt

cfgUpDown :: Commands ()
cfgUpDown =
    param "updown-script" "<path to script to run upon SA establishment/teardown>" string $ \script -> do
      ipsecSettings . getChildSAConfig . childSAUpDown .= Just script
      flushIt

cfgSAMode :: Commands ()
cfgSAMode =
    param "mode" "<tunnel|transport|beet|pass|drop>" saMode $ \mode -> do
      ipsecSettings . getChildSAConfig . childSAMode .= mode
      flushIt

cfgHostAccess :: Commands ()
cfgHostAccess =
    param "host-access" "<enabled|disabled>" readEnabled $ \status -> do
      ipsecSettings . getChildSAConfig . childSAHostAccess .= status
      flushIt

cfgStartAction :: Commands ()
cfgStartAction =
    param "start-action" "<none|route|restart>" saAction $ \action -> do
      ipsecSettings . getChildSAConfig . childSAStartAction .= action
      flushIt

cfgDPDAction :: Commands ()
cfgDPDAction =
    param "dpd-action" "<none|route|restart>" saAction $ \action -> do
      ipsecSettings . getChildSAConfig . childSADPDAction .= action
      flushIt

cfgCloseAction :: Commands ()
cfgCloseAction =
    param "close-action" "<none|route|restart>" saAction $ \action -> do
      ipsecSettings . getChildSAConfig . childSACloseAction .= action
      flushIt

cfgIPCompression :: Commands ()
cfgIPCompression =
    param "ip-compression" "<enabled|disabled>" readEnabled $ \status -> do
      ipsecSettings . getChildSAConfig . childSAIPCompression .= status
      flushIt

cfgReqID :: Commands ()
cfgReqID =
    param "req-id" "<SA request ID>" integer $ \reqID -> do
      ipsecSettings . getChildSAConfig . childSAReqID .= reqID
      flushIt

flushChildSA :: StateT AppState IO Action
flushChildSA = do
    AppState{_ipsecSettings = IPSecSettings{_getChildSAConfig=childSA@ChildSAConfig{..}}, ..} <- get
    Result {response = OK {..}} <- lift $ writeChildSAConfig childSA _dbContext
    when (okAffectedRows /= 1 ) $
      liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)"
    void . runMaybeT $ do
      childSA':xs <- findChildSAConfigByName _childSAName _dbContext
      when (xs /= []) $
        liftIO . putStrLn $
          "Warning: more than one child SA config named " ++ unpack _childSAName ++ " found"
      lift $ ipsecSettings . getChildSAConfig .= childSA'
    return NoAction