strongswan-sql-1.2.0.0: app/CLI/Commands/PeerCfg.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module CLI.Commands.PeerCfg where

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

certPolicy :: (Monad m) => Validator m CertPolicy
certPolicy = return . fromName

authMethod :: (Monad m) => Validator m AuthMethod
authMethod = return . fromName

eapType :: (Monad m) => Validator m EAPType
eapType = return . fromName

cfgPeer :: Commands ()
cfgPeer = do
  cfgIKEVersion
  cfgIKEConfigId
  cfgLocalId
  cfgRemoteId
  cfgCertPolicy
  cfgUniqueIds
  cfgAuthMethod
  cfgEAPType
  cfgEAPVendor
  cfgKeyingTries
  cfgRekeyTime
  cfgReauthTime
  cfgJitter
  cfgOverTime
  cfgMobike
  cfgDPDDelay
  cfgVirtual
  cfgPool
  cfgMediation
  cfgMediatedBy
  cfgPeerId

setPeerCfg :: Text -> StateT AppState IO Action
setPeerCfg name = do
  peerCfg <- setConfig findPeerConfigByName def { _peerCfgName = name} name
  ipsecSettings . getPeerConfig .= peerCfg
  flush .= Just flushPeerCfg
  return NewLevel

cfgIKEVersion :: Commands ()
cfgIKEVersion =
    param "ike-version" "<IKE version number>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgIKEVersion .= val
      flushIt

cfgIKEConfigId :: Commands ()
cfgIKEConfigId =
    param "ike-config-id" "<IKE configuration ID>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= Just val
      flushIt

cfgLocalId :: Commands ()
cfgLocalId =
    param "local-identity-id" "<local identity>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgLocalId .= Just val
      flushIt

cfgRemoteId :: Commands ()
cfgRemoteId =
    param "remote-identity-id" "<remote identity>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgRemoteId .= Just val
      flushIt

cfgCertPolicy :: Commands ()
cfgCertPolicy =
    param "cert-policy" "<certificate transmission policy: always-send|send-if-asked|never-send" certPolicy $ \policy -> do
      ipsecSettings . getPeerConfig . peerCfgCertPolicy .= policy
      flushIt

cfgUniqueIds :: Commands ()
cfgUniqueIds =
    param "unique-ids" "<true | false>" readBool $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgUniqueIds .= val
      flushIt

cfgAuthMethod :: Commands ()
cfgAuthMethod =
    param "auth-method" "<any|rsa|psk|eap|xauth>" authMethod $ \method -> do
      ipsecSettings . getPeerConfig . peerCfgAuthMethod .= method
      flushIt

cfgEAPType :: Commands ()
cfgEAPType =
    param "eap-type" "<md5|gtc|tls|sim|ttls|aka|mschapv2|tnc|radius>" eapType $ \t -> do
      ipsecSettings . getPeerConfig . peerCfgEAPType .= t
      flushIt

cfgEAPVendor :: Commands ()
cfgEAPVendor =
    param "eap-vendor" "<EAP vendor id>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgEAPVendor .= val
      flushIt

cfgKeyingTries :: Commands ()
cfgKeyingTries =
    param "keying-tries" "<number of keying attempts" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgKeyingTries .= val
      flushIt

cfgRekeyTime :: Commands ()
cfgRekeyTime =
    param "rekey-timeout" "<seconds>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgRekeyTime .= val
      flushIt

cfgReauthTime :: Commands ()
cfgReauthTime =
    param "reauth-timeout" "<seconds>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgReauthTime .= val
      flushIt

cfgJitter :: Commands ()
cfgJitter =
    param "jitter" "<connection jitter>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgJitter .= val
      flushIt

cfgOverTime :: Commands ()
cfgOverTime =
    param "overtime" "<seconds>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgOverTime .= val
      flushIt

cfgMobike :: Commands ()
cfgMobike =
    param "mobike" "<enabled|disabled>" readEnabled $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgMobike .= val
      flushIt

cfgDPDDelay :: Commands ()
cfgDPDDelay =
    param "dpd-delay" "<seconds>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgDPDDelay .= val
      flushIt

cfgVirtual :: Commands ()
cfgVirtual =
    param "virtual-ip" "<IP address>" ipAddress $ \addr -> do
      ipsecSettings . getPeerConfig . peerCfgVirtual .= (return . pack $ show addr)
      flushIt

cfgPool :: Commands ()
cfgPool =
    param "addr-pool" "<pool name>" string $ \name -> do
      ipsecSettings . getPeerConfig . peerCfgPool .= return name
      flushIt

cfgMediation :: Commands ()
cfgMediation =
    param "mediaton" "<enabled|disabled>" readEnabled $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgMediation .= val
      flushIt

cfgMediatedBy :: Commands ()
cfgMediatedBy =
    param "mediated-by" "<mediator id>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgMediatedBy .= val
      flushIt

cfgPeerId :: Commands ()
cfgPeerId =
    param "peer-id" "<peer id>" integer $ \val -> do
      ipsecSettings . getPeerConfig . peerCfgPeerId .= val
      flushIt

flushPeerCfg :: StateT AppState IO Action
flushPeerCfg = do
    AppState{_ipsecSettings = IPSecSettings{_getPeerConfig=peer@PeerConfig{..}}, ..} <- get
    Result {response = OK {..}} <- lift $ writePeerConfig peer _dbContext
    when (okAffectedRows /= 1 ) $
      liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)"
    void . runMaybeT $ do
      peerCfg:xs <- findPeerConfigByName _peerCfgName _dbContext
      when (xs /= []) $
        liftIO . putStrLn $
          "Warning: more than one peer config named " ++ unpack _peerCfgName ++ " found"
      lift $ ipsecSettings . getPeerConfig .= peerCfg
    return NoAction

showPeer :: Commands ()
showPeer =
  command "show" "Show this peer configuration" showPeer'

showPeer' :: StateT AppState IO Action
showPeer' = do
  AppState{_ipsecSettings = IPSecSettings{_getPeerConfig=PeerConfig{..}}} <- get
  let iD = _peerCfgId >>= return . show
  localId  <- fetchIdentity _peerCfgLocalId
  remoteId <- fetchIdentity _peerCfgRemoteId
  liftIO $ do
    putStr "Peer Config "
    when (_peerCfgName /= "") $ putStr $ '\'': unpack _peerCfgName ++ "' "
    putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")"
    putStrLn $ "==================================";
    putStrLn $ "IKE version:     " ++ show _peerCfgIKEVersion
    putStrLn $ "IKE config ID:   " ++ maybe "<not set>" show _peerCfgIKEConfigId
    putStrLn $ "Local identity:  " ++ maybe "<not set>" show localId
    putStrLn $ "Remote identity: " ++ maybe "<not set>" show remoteId
    putStrLn $ "Cert. policy:    " ++ nameOf _peerCfgCertPolicy
    putStrLn $ "Unique Ids:      " ++ nameOf _peerCfgUniqueIds
    putStrLn $ "Auth method:     " ++ nameOf _peerCfgAuthMethod
    putStrLn $ "EAP type:        " ++ nameOf _peerCfgEAPType
    putStrLn $ "EAP vendor:      " ++ show _peerCfgEAPVendor
    putStrLn $ "Keying tries:    " ++ show _peerCfgKeyingTries
    putStrLn $ "Rekey timeout:   " ++ show _peerCfgRekeyTime ++ " secs"
    putStrLn $ "Reauth timeout:  " ++ show _peerCfgReauthTime ++ " secs"
    putStrLn $ "Jitter:          " ++ show _peerCfgJitter ++ " secs"
    putStrLn $ "Overtime:        " ++ show _peerCfgOverTime ++ " secs"
    putStrLn $ "MobIKE:          " ++ showEnabled _peerCfgMobike
    putStrLn $ "DPD delay:       " ++ show _peerCfgDPDDelay ++ " secs"
    putStrLn $ "Virtual IP:      " ++ maybe "<none>" unpack _peerCfgVirtual
    putStrLn $ "Address pool:    " ++ maybe "<none>" unpack _peerCfgPool
    putStrLn $ "Mediation:       " ++ showEnabled _peerCfgMediation
    putStrLn $ "Mediated by:     " ++ show _peerCfgMediatedBy
    putStrLn $ "Peer ID:         " ++ show _peerCfgPeerId
  return NoAction
    where fetchIdentity ident = runMaybeT $ do
                                  db <- lift $ use dbContext
                                  iD <- MaybeT $ return ident
                                  findIdentity iD db