{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module StrongSwan.SQL (
mkContext,
writeIPSecSettings,
findIPSecSettings,
deleteIPSecSettings,
writeChild2TSConfig,
writeChildSAConfig,
writeIKEConfig,
writePeerConfig,
writePeer2ChildConfig,
writeTrafficSelector,
lookupChild2TSConfig,
findChildSAConfig,
findChildSAConfigByName,
findIKEConfig,
findPeerConfig,
findPeerConfigByName,
findPeer2ChildConfig,
findTrafficSelector,
deleteChild2TSConfig,
deleteChildSAConfig,
deleteIKEConfig,
deletePeer2ChildConfig,
deletePeerConfig,
module StrongSwan.SQL.Lenses,
dbHost,
dbPort,
dbName,
dbUser,
dbPassword,
dbCharSet,
AuthMethod(..),
ChildSAConfig(..),
Child2TSConfig(..),
CertPolicy(..),
Context,
EAPType(..),
IKEConfig(..),
IPSecSettings(..),
PeerConfig(..),
Peer2ChildConfig(..),
Result(..),
SAAction(..),
SAMode(..),
Settings(..),
SQL.OK(..),
SQLRow,
TrafficSelector(..),
TrafficSelectorType(..),
TrafficSelectorKind(..)
) where
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Lens ((^.), (.=), makeLenses, use)
import Control.Monad (void, when)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.State.Strict (MonadTrans, StateT, execStateT, get, lift)
import Data.ByteString.Char8 (pack, unpack)
import Data.Default (Default(..))
import Data.Maybe (isNothing, isJust, fromJust, listToMaybe)
import Data.Text (Text)
import Database.MySQL.Base (MySQLConn)
import Control.Monad.Failable
import Network.Socket (HostName, PortNumber)
import StrongSwan.SQL.Encoding
import StrongSwan.SQL.Lenses
import StrongSwan.SQL.Statements
import StrongSwan.SQL.Types
import qualified Database.MySQL.Base as SQL
import qualified System.IO.Streams as Stream
import qualified Data.Text as Text
type Context = MVar Context_
data Context_ = Context_ {
conn_ :: MySQLConn,
prepared_ :: PreparedStatements
}
data Settings = Settings {
_dbName :: String,
_dbHost :: HostName,
_dbPort :: PortNumber,
_dbUser :: String,
_dbPassword :: String,
_dbCharSet :: MySQLCharacterEncoding
} deriving Show
makeLenses ''Settings
instance Default Settings where
def = let SQL.ConnectInfo {..} = SQL.defaultConnectInfo
in Settings {
_dbName = unpack ciDatabase,
_dbHost = ciHost,
_dbPort = ciPort,
_dbUser = unpack ciUser,
_dbPassword = unpack ciPassword,
_dbCharSet = toEnum $ fromIntegral ciCharset
}
mkContext :: (Failable m, MonadIO m) => Settings -> m Context
mkContext Settings {..} = failableIO $ do
conn <- SQL.connect info
prepared <- prepareStatements conn
newMVar Context_ {
conn_ = conn,
prepared_ = prepared
}
where info = SQL.defaultConnectInfo { SQL.ciDatabase = pack _dbName,
SQL.ciHost = _dbHost,
SQL.ciPort = _dbPort,
SQL.ciUser = pack _dbUser,
SQL.ciPassword = pack _dbPassword,
SQL.ciCharset = fromIntegral $ fromEnum _dbCharSet }
retrieveRows :: (Failable m, MonadIO m, SQLRow a)
=> (PreparedStatements -> SQL.StmtID)
-> [SQL.MySQLValue]
-> Context
-> m [a]
retrieveRows statement clause context = do
xs <- failableIO $ do
(_, valueStream) <- withMVar context lookupConfig'
Stream.toList valueStream
return $ fromValues <$> xs
where lookupConfig' Context_ { ..} =
SQL.queryStmt conn_ (statement prepared_) clause
withContext :: (Failable m, MonadIO m) => (Context_ -> IO a) -> Context -> m a
withContext = ((.).(.)) failableIO $ flip withMVar
writeRow :: (SQLRow r) => Context_
-> SQL.StmtID
-> SQL.StmtID
-> (r -> Maybe Int)
-> r
-> IO (Result Int)
writeRow Context_ {..} update create lens row
| isNothing $ lens row = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ create sqlValues
return Result { lastModifiedKey = okLastInsertID, response = ok}
| otherwise = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ update $ sqlValues ++ [toSQL . toInt . fromJust $ lens row ]
return Result { lastModifiedKey = fromJust $ lens row, response = ok }
where sqlValues = toValues row
justOne :: (Failable m, Show a) => Text -> [a] -> m a
justOne tag xs@(_:_:_) = failure . MultipleResults tag $ show xs
justOne tag [] = failure $ NotFound tag
justOne _ [x] = return x
writeIPSecSettings :: (Failable m, MonadIO m) => IPSecSettings -> Context -> m IPSecSettings
writeIPSecSettings ipsec context = let ?context = context in execStateT writeIPSecSettings' ipsec
writeIPSecSettings' :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m ()
writeIPSecSettings' = do
unlinkConfig
use getIKEConfig >>= inContext writeIKEConfig >>= setId (getIKEConfig . ikeId)
name <- use getIPSecCfgName
ikeCfgId <- use (getIKEConfig . ikeId)
getPeerConfig . peerCfgIKEConfigId .= fromJust ikeCfgId
use getChildSAConfig >>= inContext writeChildSAConfig >>= setId (getChildSAConfig. childSAId)
use getPeerConfig >>= inContext writePeerConfig >>= setId (getPeerConfig . peerCfgId)
use getLocalTrafficSelector >>= inContext writeTrafficSelector >>= setId (getLocalTrafficSelector . tsId)
use getRemoteTrafficSelector >>= inContext writeTrafficSelector >>= setId (getRemoteTrafficSelector . tsId)
ipsec <- get
SQL.OK {..} <-
lift . failableIO $ withMVar ?context $ \Context_ {prepared_ = PreparedStatements{..}, ..} ->
SQL.executeStmt conn_ createIPSecStmt $
(toSQL . toVarChar $ Just name) :
(toSQL . toInt . fromJust <$> [ipsec ^. getChildSAConfig . childSAId,
ipsec ^. getPeerConfig . peerCfgId,
ipsec ^. getIKEConfig . ikeId,
ipsec ^. getLocalTrafficSelector . tsId,
ipsec ^. getRemoteTrafficSelector . tsId])
when (okAffectedRows /= 1) $ lift . failure $ FailedOperation ("createIPSec " <> name)
linkConfig
where setId lens Result {..} = lens .= Just lastModifiedKey
findIPSecSettings :: (Failable m, MonadIO m) => Text -> Context -> m IPSecSettings
findIPSecSettings name context = do
xs <- failableIO $ do
(_,stream) <- withMVar context $
\Context_ {prepared_ = PreparedStatements {..}, ..} ->
SQL.queryStmt conn_ findIPSecStmt [toSQL . toVarChar $ Just name]
listToMaybe <$> Stream.toList stream
maybe (failure . NotFound $ "IPSecSettings " <> name) mkIPSecSettings xs
where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId] = do
childCfg <- findChildSAConfig (sql2Int childCfgId) context
peerCfg <- findPeerConfig (sql2Int peerId) context
ikeCfg <- findIKEConfig (sql2Int ikeCfgId) context
lTS <- findTrafficSelector (sql2Int lTSId) context
rTS <- findTrafficSelector (sql2Int rTSId) context
return IPSecSettings { _getIPSecCfgName = fromJust . fromVarChar $ fromSQL cfgName,
_getChildSAConfig = childCfg,
_getPeerConfig = peerCfg,
_getIKEConfig = ikeCfg,
_getLocalTrafficSelector = lTS,
_getRemoteTrafficSelector = rTS }
mkIPSecSettings vs =
failure $ SQLValuesMismatch ("IPSecSettings " ++ Text.unpack name) (show vs)
sql2Int = fromInt . fromSQL
deleteIPSecSettings :: (Failable m, MonadIO m) => IPSecSettings -> Context -> m IPSecSettings
deleteIPSecSettings ipsec context = let ?context = context in execStateT unlinkConfig ipsec
linkConfig :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m ()
linkConfig =
void . runMaybeT $ do
childCfgId <- MaybeT . use $ getChildSAConfig . childSAId
lTS <- use getLocalTrafficSelector
rTS <- use getRemoteTrafficSelector
addTrafficSelector childCfgId lTS LocalTS
addTrafficSelector childCfgId rTS RemoteTS
peerId <- MaybeT . use $ getPeerConfig . peerCfgId
lift $ inContext writePeer2ChildConfig Peer2ChildConfig {
p2cPeerCfgId = peerId,
p2cChildCfgId = childCfgId
}
where addTrafficSelector childId TrafficSelector {..} kind
| isJust _tsId =
void . lift $ inContext writeChild2TSConfig
Child2TSConfig { c2tsChildCfgId = childId,
c2tsTrafficSelectorCfgId = fromJust _tsId,
c2tsTrafficSelectorKind = kind }
| otherwise =
return ()
inContext :: (?context::Context, Failable m, MonadTrans t) => (a -> Context -> m b) -> a -> t m b
inContext f x = lift $ f x ?context
unlinkConfig :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m ()
unlinkConfig = do
void . runMaybeT $ do
childCfgId <- MaybeT . use $ getChildSAConfig . childSAId
void . lift $ inContext deleteChild2TSConfig childCfgId
void . lift $ inContext deleteChildSAConfig childCfgId
peerId <- MaybeT . use $ getPeerConfig . peerCfgId
void . lift $ inContext (deletePeer2ChildConfig peerId) childCfgId
lift $ inContext deletePeerConfig peerId
use getLocalTrafficSelector >>= removeTrafficSelector
use getRemoteTrafficSelector >>= removeTrafficSelector
name <- use getIPSecCfgName
void . runMaybeT $ do
ikeCfgId <- MaybeT . use $ getIKEConfig . ikeId
lift $ inContext deleteIKEConfig ikeCfgId
void . lift . failableIO . withMVar ?context $
\Context_{prepared_ = PreparedStatements{..}, ..} ->
SQL.executeStmt conn_ deleteIPSecStmt [toSQL . toVarChar $ Just name]
getIKEConfig . ikeId .= Nothing
getChildSAConfig . childSAId .= Nothing
getPeerConfig . peerCfgId .= Nothing
getLocalTrafficSelector . tsId .= Nothing
getRemoteTrafficSelector . tsId .= Nothing
where removeTrafficSelector sel =
void . runMaybeT $ do
tsCfgId <- MaybeT . return $ _tsId sel
lift $ inContext deleteTrafficSelector tsCfgId
writeChildSAConfig :: (Failable m, MonadIO m) => ChildSAConfig -> Context -> m (Result Int)
writeChildSAConfig cfg = withContext writeChildSAConfig''
where writeChildSAConfig'' context@Context_ { prepared_ = PreparedStatements {..}} =
writeRow context updateChildSAStmt createChildSAStmt _childSAId cfg
findChildSAConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [ChildSAConfig]
findChildSAConfigByName name = retrieveRows findChildSAByNameStmt [toSQL . toVarChar $ Just name]
findChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m ChildSAConfig
findChildSAConfig iD context =
justOne ("Child SA " <> Text.pack (show iD)) =<<
retrieveRows findChildSAStmt [toSQL $ toInt iD] context
deleteChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteChildSAConfig iD = withContext deleteChildSAConfig'
where deleteChildSAConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteChildSAStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
writeIKEConfig :: (Failable m, MonadIO m) => IKEConfig -> Context -> m (Result Int)
writeIKEConfig cfg = withContext writeIKEConfig''
where writeIKEConfig'' context@Context_ { prepared_ = PreparedStatements {..}, ..} =
writeRow context updateIKEStmt createIKEStmt _ikeId cfg
findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig
findIKEConfig iD context =
justOne ("IKEConfig " <> Text.pack (show iD)) =<<
retrieveRows findIKEStmt [toSQL $ toInt iD] context
deleteIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteIKEConfig iD = withContext deleteIKEConfig'
where deleteIKEConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteIKEStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
writePeerConfig :: (Failable m, MonadIO m) => PeerConfig -> Context -> m (Result Int)
writePeerConfig cfg = withContext writePeerConfig''
where writePeerConfig'' context@Context_ { prepared_ = PreparedStatements {..} } =
writeRow context updatePeerStmt createPeerStmt _peerCfgId cfg
findPeerConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [PeerConfig]
findPeerConfigByName name = retrieveRows findPeerByNameStmt [toSQL . toVarChar $ Just name]
findPeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m PeerConfig
findPeerConfig iD context =
justOne ("PeerConfig " <> Text.pack (show iD)) =<<
retrieveRows findPeerStmt [toSQL $ toInt iD] context
deletePeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deletePeerConfig iD = withContext deletePeerConfig'
where deletePeerConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deletePeerStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
writePeer2ChildConfig :: (Failable m, MonadIO m) => Peer2ChildConfig -> Context -> m (Result (Int, Int))
writePeer2ChildConfig cfg@Peer2ChildConfig {..} = withContext writeP2CConfig
where writeP2CConfig Context_ { prepared_ = PreparedStatements {..}, .. } = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ createP2CStmt $ toValues cfg
return Result { lastModifiedKey = (p2cPeerCfgId, p2cChildCfgId), response = ok }
findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig
findPeer2ChildConfig peerId childId context =
justOne ("Peer2Child " <> Text.pack (show peerId) <> " - " <> Text.pack (show childId)) =<<
retrieveRows findP2CStmt (toSQL.toInt <$> [peerId, childId]) context
deletePeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Result (Int, Int))
deletePeer2ChildConfig peerId childId = withContext deletePeer2ChildConfig'
where deletePeer2ChildConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteP2CStmt $
toSQL . toInt <$> [peerId, childId]
return Result { lastModifiedKey = (peerId, childId) , response = ok }
writeTrafficSelector :: (Failable m, MonadIO m) => TrafficSelector -> Context -> m (Result Int)
writeTrafficSelector ts = withContext writeTS
where writeTS context@Context_ { prepared_ = PreparedStatements {..}, .. } =
writeRow context updateTSStmt createTSStmt _tsId ts
deleteTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteTrafficSelector iD = withContext deleteTrafficSelector'
where deleteTrafficSelector' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteTSStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector
findTrafficSelector iD context =
justOne ("TrafficSelector " <> Text.pack (show iD)) =<<
retrieveRows findTSStmt [toSQL $ toInt iD] context
writeChild2TSConfig :: (Failable m, MonadIO m) => Child2TSConfig -> Context -> m (Result (Int, Int))
writeChild2TSConfig cfg@Child2TSConfig {..} = withContext writeChild2TSConfig''
where writeChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, .. } = do
result@SQL.OK {..} <- SQL.executeStmt conn_ updateC2TSStmt $ sqlValues ++ selector
result' <- if okAffectedRows == 0
then SQL.executeStmt conn_ createC2TSStmt sqlValues
else return result
return Result { lastModifiedKey = (c2tsChildCfgId, c2tsTrafficSelectorCfgId),
response = result' }
sqlValues = toValues cfg
selector = toSQL . toInt <$> [c2tsChildCfgId, c2tsTrafficSelectorCfgId]
lookupChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m [Child2TSConfig]
lookupChild2TSConfig iD = retrieveRows findC2TSStmt [toSQL $ toInt iD]
deleteChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteChild2TSConfig iD = withContext deleteChild2TSConfig'
where deleteChild2TSConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteC2TSStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }