strongswan-sql-1.0.0.0: app/CLI/Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module CLI.Types where

import Control.Lens                 (makeLenses)
import Control.Monad.Failable       (Failable(..))
import Control.Monad.State.Strict   (StateT)
import Control.Exception            (Exception)
import Data.Char                    (toLower)
import Data.Default
import Data.Text                    (Text)
import Data.Typeable                (Typeable)
import System.Console.StructuredCLI

import qualified Data.Attoparsec.Text as A
import qualified StrongSwan.SQL       as SQL

data Error = BadArguments String
           | FatalError CLIException
           | InvalidValue String
            deriving (Typeable, Show)

instance Exception Error

data Options = Options {
                 _settings      :: SQL.Settings,
                 _askPassword   :: Bool,
                 _requestedHelp :: Bool,
                 _badInput      :: Text
               } deriving Show

makeLenses ''Options

data AppState = AppState {
                  _options       :: Options,
                  _dbContext     :: SQL.Context,
                  _ipsecSettings :: SQL.IPSecSettings,
                  _flush         :: Maybe (StateT AppState IO Action)
                }

makeLenses ''AppState

instance Default Options where
    def = Options { _settings      = def,
                    _askPassword   = False,
                    _requestedHelp = False,
                    _badInput      = "" }

type Commands   = CommandsT (StateT AppState IO)
type ArgsParser = StateT Options A.Parser

class Nameable a where
    nameOf   :: a -> String
    fromName :: (Failable m) => String -> m a

instance Nameable Bool where
    nameOf True  = "true"
    nameOf False = "false"
    fromName "true"  = return True
    fromName "false" = return False
    fromName str     = failure $ InvalidValue str

instance Nameable SQL.CertPolicy where
    nameOf SQL.AlwaysSend  = "always-send"
    nameOf SQL.SendIfAsked = "send-if-asked"
    nameOf SQL.NeverSend   = "never-send"
    fromName "always-send"   = return SQL.AlwaysSend
    fromName "send-if-asked" = return SQL.SendIfAsked
    fromName "never-send "   = return SQL.NeverSend
    fromName str             = failure $ InvalidValue str

instance Nameable SQL.SAAction where
    nameOf = fmap toLower . show
    fromName "none"    = return SQL.None
    fromName "route"   = return SQL.Route
    fromName "restart" = return SQL.Restart
    fromName str       = failure $ InvalidValue str


instance Nameable SQL.SAMode where
    nameOf = fmap toLower . show
    fromName "tunnel"    = return SQL.Tunnel
    fromName "transport" = return SQL.Transport
    fromName "beet"      = return SQL.Beet
    fromName "pass"      = return SQL.Pass
    fromName "drop"      = return SQL.Drop
    fromName str         = failure $ InvalidValue str

instance Nameable SQL.EAPType where
    nameOf SQL.EAPMD5      = "md5"
    nameOf SQL.EAPGTC      = "gtc"
    nameOf SQL.EAPTLS      = "tls"
    nameOf SQL.EAPSIM      = "sim"
    nameOf SQL.EAPTTLS     = "ttls"
    nameOf SQL.EAPAKA      = "aka"
    nameOf SQL.EAPMSCHAPV2 = "mschapv2"
    nameOf SQL.EAPTNC      = "tnc"
    nameOf SQL.EAPRADIUS   = "radius"
    fromName "md5"      = return SQL.EAPMD5
    fromName "gtc"      = return SQL.EAPGTC
    fromName "tls"      = return SQL.EAPTLS
    fromName "sim"      = return SQL.EAPSIM
    fromName "ttls"     = return SQL.EAPTTLS
    fromName "aka"      = return SQL.EAPAKA
    fromName "mschapv2" = return SQL.EAPMSCHAPV2
    fromName "tnc"      = return SQL.EAPTNC
    fromName "radius"   = return SQL.EAPRADIUS
    fromName str        = failure $ InvalidValue str

instance Nameable SQL.AuthMethod where
    nameOf = fmap toLower . show
    fromName "any"   = return SQL.Any
    fromName "rsa"   = return SQL.PubKey
    fromName "psk"   = return SQL.PSK
    fromName "eap"   = return SQL.EAP
    fromName "xauth" = return SQL.XAUTH
    fromName str     = failure $ InvalidValue str

instance Nameable SQL.TrafficSelectorType where
    nameOf SQL.IPv4AddrRange = "ipv4"
    nameOf SQL.IPv6AddrRange = "ipv6"
    fromName "ipv4" = return SQL.IPv4AddrRange
    fromName "ipv6" = return SQL.IPv6AddrRange
    fromName str    = failure $ InvalidValue str