Commands.hs

{-# LANGUAGE FlexibleContexts #-}

module CLI.Commands where

import CLI.Commands.ChildSA
import CLI.Commands.Common
import CLI.Commands.PeerCfg
import CLI.Commands.TrafficSelector
import CLI.Types
import Control.Lens                        ((&), (.=), (.~), use)
import Control.Monad                       (void)
import Control.Monad.IO.Class              (liftIO)
import Control.Monad.Trans.Maybe           (runMaybeT)
import Control.Monad.State.Strict          (StateT, lift)
import Data.Default                        (def)
import Data.Maybe                          (fromMaybe)
import Data.Text                           (unpack)
import System.Console.StructuredCLI hiding (Commands)
import StrongSwan.SQL

commands :: Commands ()
commands = do
  command "advanced" "Configure individual elements manually" newLevel >+ do
    param "child-sa" "<child SA configuration name>" string setChildSA >+ do
      cfgChildSA
      showChildSA
      exitCmd
    param "peer-cfg" "<peer connection configuration name>" string setPeerCfg >+ do
      cfgPeer
      showPeer
      exitCmd
    param "traffic-selector" "<existing traffic selector ID | new>" parseTSId setTrafficSelector >+ do
      cfgTrafficSelector getLocalTrafficSelector
      showTrafficSelector
      exitCmd
    exitCmd
  param "connection" "<managed connection name>" string setConnection >+ do
    cfgChildSA
    cfgPeer
    command "local-traffic-selector" "Configure local traffic selector" newLevel >+ do
      cfgTrafficSelector getLocalTrafficSelector
      command "show" "Display local traffic selector's parameters" $
          showTrafficSelector' getLocalTrafficSelector
      exitCmd
    command "remote-traffic-selector" "Configure remote traffic selector" newLevel >+ do
      cfgTrafficSelector getRemoteTrafficSelector
      command "show" "Display remote traffic selector's parameters" $
          showTrafficSelector' getRemoteTrafficSelector
      exitCmd
    showConnection
    exitCmd
  where setConnection name = do
          db <- use dbContext
          result <- runMaybeT $ findIPSecSettings name db
          let ipsec = fromMaybe def result
          ipsecSettings .= (ipsec & getIPSecCfgName .~ name)
          flush .= Just flushConnection
          return NewLevel

flushConnection :: StateT AppState IO Action
flushConnection = do
  ipsecCfg <- use ipsecSettings
  db       <- use dbContext
  ipsec'   <- lift $ writeIPSecSettings ipsecCfg db
  ipsecSettings .= ipsec'
  return NoAction

showConnection :: Commands ()
showConnection =
  command "show" "display connection parameters" $ do
    name <- use $ ipsecSettings . getIPSecCfgName
    liftIO . putStrLn $ "IPSec connection -  \'" ++ unpack name ++ "'"
    void showChildSA'
    void $ showPeer'
    liftIO $ putStr "Local "
    void $ showTrafficSelector' getLocalTrafficSelector
    liftIO $ putStr "Remote "
    showTrafficSelector' getRemoteTrafficSelector