Identity.hs

{-# LANGUAGE FlexibleContexts, RankNTypes #-}

module CLI.Commands.Identity where

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

secretType' :: (Monad m) => Validator m SharedSecretType
secretType' = return . fromName

cfgIdentity :: Lens' AppState Identity -> Commands ()
cfgIdentity lens =
  command "identity" "Identity configuration" newLevel >+ do
    command "any" "Matches any ID" (setIdentity lens $ AnyID Nothing)                 >+ identityCmds lens
    param "name" "<FQDN>" string (setIdentity lens . NameID Nothing)                  >+ identityCmds lens
    param "ipv4" "<IPv4 address>" ipV4Address (setIdentity lens . IPv4AddrID Nothing) >+ identityCmds lens
    param "ipv6" "<IPv6 address>" ipV6Address (setIdentity lens . IPv6AddrID Nothing) >+ identityCmds lens
    command "exit" "Exit identity configuration" (return $ LevelUp 2)

setIdentityCfg :: StateT AppState IO Action
setIdentityCfg = do
  flush .= Just flushIdentity
  return NewLevel

cfgSecret :: Lens' AppState Identity -> Lens' AppState Identity -> Commands ()
cfgSecret lensA lensB =
  command "shared-secret" "Manipulate shared secrets for this connection" newLevel >+ do
    param "add" "<shared secret>" bytes setSecret >+ do
      param "type" "<psk|eap|rsa|pin>" secretType' $ \sType -> do
        db     <- use dbContext
        ident1 <- use lensA
        ident2 <- use lensB
        str   <- use secretStr
        let secret = def { _ssData = str, _ssType = sType }
        Result {..} <- lift $ writeSharedSecret secret db
        let secret' = secret { _ssId = Just lastModifiedKey }
        ident1' <- lift $ addSecret ident1 secret' db
        ident2' <- lift $ addSecret ident2 secret' db
        lensA .= ident1'
        lensB .= ident2'
        return NoAction
      exitCmd
    command "remove" "Delete all shared secrets from this connection" $ do
      db <- use dbContext
      ident1 <- use lensA
      ident2 <- use lensB
      lift $ mapM_ (\t -> removeSecret ident1 t db) allTypes
      lift $ mapM_ (\t -> removeSecret ident2 t db) allTypes
      return NoAction
    exitCmd
        where setSecret str = do
                secretStr .= str
                return NewLevel
              allTypes = [minBound..maxBound]

flushIdentity :: StateT AppState IO Action
flushIdentity = do
  db    <- use dbContext
  ident <- use identity
  void . lift $ writeIdentity ident db
  return NoAction

setIdentity :: Lens' AppState Identity -> Identity -> StateT AppState IO Action
setIdentity lens ident = do
  db      <- use dbContext
  result  <- runMaybeT $ findIdentityBySelf ident db
  lens .= fromMaybe ident result
  when (isNothing result) newIdentity
  return NewLevel
    where newIdentity =
            void . runMaybeT $ do
              fn <- MaybeT $ use flush
              lift fn

removeIdent :: Lens' AppState Identity -> Commands ()
removeIdent lens =
  command "remove" "delete identity from DB and all associated secrets, etc" $ do
    db <- use dbContext
    ident <- use lens
    void . runMaybeT $ removeIdentity ident db
    lens .= def
    return $ LevelUp 2

identityCmds :: Lens' AppState Identity -> Commands ()
identityCmds lens = do
  removeIdent lens
  command "exit" "Exit identity configuration" (return $ LevelUp 3)