strongswan-sql-1.3.0.0: src/StrongSwan/SQL.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{- |
Module: StrongSwan.SQL
Description: Interface Library for strongSwan (My)SQL backend
Copyright: (c) Erick Gonzalez, 2019
License: BSD3
Maintainer: erick@codemonkeylabs.de
This library allows for the manipulation of strongSwan connection configuration stored in a
MySQL database in a manner that is compatible with the strongSwan SQL plugin for charon.
= How to use this module:
The strongSwan IPsec package offers the means to store connection configuration in a
SQL database. This module offers some facilities to manipulate these config elements
from Haskell code in a simplified abstracted way.
This library offers two approaches to manipulating strongswan configuration in an
SQL database as expected by the SQL plugin. See /Managed/ vs /Manual/ API below.
-}
module StrongSwan.SQL (
-- * Initialization
mkContext,
rmContext,
--
-- * Managed API
-- | Since managing each configuration object per hand and establishing the relationships
-- amongst them can be tricky and demands internal knowledge of the SQL plugin inner workings,
-- a special API is offered in which all configuration parameters are bundled together
-- in a single type (see 'IPSecSettings'). The simplified API allows then for writing, reading
-- and deleting these, while behind bars the required elements are created and linked
-- together unbeknownst to the caller. This of course greatly simplifies things /but/ the
-- catch is that the ability to share configuration elements amongst connections is of
-- course lost. Each managed connection configuration gets a separate IKE, Child SA, Peer
-- config etc and no attempt is made to reuse them amongst managed connections.
writeIPSecSettings,
findIPSecSettings,
lookupIPSecSettings,
deleteIPSecSettings,
addSecret,
removeSecret,
removeIdentity,
-- * Manual API
-- | The different strongswan configuration elements are mapped to a Haskell type and they
-- can be manually written or read from the SQL database. This offers utmost control in
-- terms of what elements get created and how they are interlinked. So for example one can
-- create a single IKE session configuration to be shared for all connections or have some
-- child SA configurations being shared amongst peers of a given type, etc. The downside
-- of course to this level of control is that it requires for the user of the library to
-- be familiar with the (poorly documented) way in which the plugin expects the
-- relationships to be expressed in terms of entries in the SQL tables etc.
--
-- The manual API has been reverse engineered based on the SQL table definitions available
-- [here](https://wiki.strongswan.org/projects/strongswan/repository/entry/src/pool/mysql.sql)
--
-- * __Child SA__ : All configuration parameters related to an IPsec SA.
--
-- * __IKE Configuration__ : Configuration applicable to the IKE session (/phase 1/ in IKEv1
-- parlance).
--
-- * __Peer Configuration__ : All elements related to configuration of a peering connection.
-- A peer connection links to a specific IKE configuration (by means of ID), and it is
-- furthermore associated to the Child SA by means of a 'Peer2ChildConfig' type.
--
-- * __Traffic Selectors__: These are independent values linked to a Child SA by means of a
-- 'Child2TSConfig' type.
--
-- The manual API consists mainly of one @writeXXX@, @findXXX@, @lookupXXX@ and a @deleteXXX@
-- function for each object to be stored as an SQL row in its respective table. The @writeXXX@
-- functions trigger an insertion or an update of the given row in the SQL database depending
-- on whether the given object owns a key already or not (usually an ID). The search functions
-- (@findXXX@ and @lookupXXX@) perform a search in the DB for the given key. The difference is
-- that a @findXXX@ will trigger a 'failure' in the 'Failable' context with a 'NotFound' error
-- and that the @lookupXXX@ functions simply return 'Nothing' if a key doesn't exist in the DB
-- (they can of course trigger other errors in the Failable context)
writeChild2TSConfig,
writeChildSAConfig,
writeIdentity,
writeIKEConfig,
writePeerConfig,
writePeer2ChildConfig,
writeSharedSecret,
writeSSIdentity,
writeTrafficSelector,
lookupChild2TSConfig,
findChildSAConfig,
findChildSAConfigByName,
findIdentity,
findIdentityBySelf,
findIKEConfig,
findPeerConfig,
findPeerConfigByName,
findPeer2ChildConfig,
findSharedSecret,
findSSIdentity,
findTrafficSelector,
lookupChildSAConfig,
lookupIdentity,
lookupIdentityBySelf,
lookupIKEConfig,
lookupPeerConfig,
lookupPeer2ChildConfig,
lookupSharedSecret,
lookupTrafficSelector,
deleteChild2TSConfig,
deleteChildSAConfig,
deleteIdentity,
deleteIKEConfig,
deleteSharedSecret,
deleteSSIdentity,
deletePeer2ChildConfig,
deletePeerConfig,
-- #Lenses#
-- * Lenses
-- | There are lenses exported to facilitate access to the records in the
-- type section below.
module StrongSwan.SQL.Lenses,
dbHost,
dbPort,
dbName,
dbUser,
dbPassword,
dbCharSet,
-- * Types
AuthMethod(..),
ChildSAConfig(..),
Child2TSConfig(..),
CertPolicy(..),
Context,
EAPType(..),
Error(..),
Identity(..),
IKEConfig(..),
IPSecSettings(..),
PeerConfig(..),
Peer2ChildConfig(..),
Result(..),
SAAction(..),
SAMode(..),
Settings(..),
SharedSecret(..),
SharedSecretIdentity(..),
SharedSecretType(..),
SQL.OK(..),
SQLRow,
TrafficSelector(..),
TrafficSelectorType(..),
TrafficSelectorKind(..)
) where
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Lens (Lens', (^.), (.=), makeLenses, use)
import Control.Monad (mapM_, void, when)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.State.Strict (StateT, execStateT, get, lift)
import Data.ByteString.Char8 (pack, unpack)
import Data.Default (Default(..))
import Data.Maybe (catMaybes, 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 SQL.StmtID
}
data Settings = Settings {
_dbName :: String, -- ^ Name of the DB to use
_dbHost :: HostName, -- ^ SQL server host (defaults to localhost)
_dbPort :: PortNumber, -- ^ TCP port (defaults to 3306)
_dbUser :: String, -- ^ DB username (defaults to root)
_dbPassword :: String, -- ^ DB user password
_dbCharSet :: MySQLCharacterEncoding -- ^ Defaults to 'UTF8MB4'
} 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
}
-- | Initialize an SQL context. Use the 'Default' instance of 'Settings' and fine tune
-- parameters as needed. For example:
--
-- @
-- context <- init def { dbName = "acmeDB" }
-- @
--
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 }
-- | Destroy an SQL context previously created by 'mkContext'
rmContext :: (Failable m, MonadIO m) => Context -> m ()
rmContext = withContext rmContext'
where rmContext' Context_ {..} = do
mapM_ (SQL.closeStmt conn_) prepared_
SQL.close conn_
retrieveRows :: (Failable m, MonadIO m, SQLRow a)
=> (PreparedStatements SQL.StmtID -> 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 (Maybe a)
justOne tag xs@(_:_:_) = failure . MultipleResults tag $ show xs
justOne _ xs = return $ listToMaybe xs
-- | Pushes an IPsec configuration into the DB specified in the given context. Note that if there are any
-- existing elements in the configuration, they are first released (and their inter relationships in the
-- SQL DB removed), before creating them. As a result the different IDs inside the elements etc will probably
-- change. This is the reason why a /new/ 'IPSecSettings' value is returned as a result of the operation and
-- the value "pushed" to the DB originally should not be used any further.
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 >>= lift . writeIKEConfig' >>= setId (getIKEConfig . ikeId)
name <- use getIPSecCfgName
ikeCfgId <- use (getIKEConfig . ikeId)
localIdent <- saveIdent getLocalIdentity
remoteIdent <- saveIdent getRemoteIdentity
let localId = getIdentityId localIdent
remoteId = getIdentityId remoteIdent
getPeerConfig . peerCfgIKEConfigId .= ikeCfgId
getPeerConfig . peerCfgLocalId .= localId
getPeerConfig . peerCfgRemoteId .= remoteId
use getChildSAConfig >>= lift . writeChildSAConfig' >>= setId (getChildSAConfig. childSAId)
use getPeerConfig >>= lift . writePeerConfig' >>= setId (getPeerConfig . peerCfgId)
use getLocalTrafficSelector >>= lift . writeTrafficSelector' >>= setId (getLocalTrafficSelector . tsId)
use getRemoteTrafficSelector >>= lift . 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,
localId,
remoteId])
when (okAffectedRows /= 1) $ lift . failure $ FailedOperation ("createIPSec " <> name)
linkConfig
where setId lens Result {..} = lens .= Just lastModifiedKey
saveIdent :: (Failable m, MonadIO m, ?context::Context)
=> Lens' IPSecSettings Identity
-> StateT IPSecSettings m Identity
saveIdent lens = do
ident <- use lens
result <- runMaybeT $ findIdentityBySelf' ident
maybe (newIdentity ident) return result
where newIdentity ident = do
Result {..} <- lift $ writeIdentity' ident
let ident' = setIdentityId ident lastModifiedKey
lens .= ident'
return ident'
notFound :: (Failable m, MonadIO m) => Text -> Maybe a -> m a
notFound txt = maybe (failure $ NotFound txt) return
-- | Search for an IPsec connection configuration by its unique name. Take note of the 'Failable' context,
-- which means that unless it is desired that this function throws an asynchronous exception upon not finding
-- a configuration, you probably want to run this inside a monadic transformer such as 'MaybeT' or 'ExceptT'
findIPSecSettings :: (Failable m, MonadIO m) => Text -> Context -> m IPSecSettings
findIPSecSettings name context = notFound ("IPSecSettings" <> name) =<< lookupIPSecSettings name context
-- | Lookup an IPsec connection configuration by its unique name. Returns @Nothing@ if the connection
-- is not found. Other errors are reported according to the Failable context the function
-- is called on ('MaybeT', 'ExceptT', 'IO', etc).
lookupIPSecSettings :: (Failable m, MonadIO m) => Text -> Context -> m (Maybe IPSecSettings)
lookupIPSecSettings name context = runMaybeT $ do
xs <- MaybeT . failableIO $ do
(_,stream) <- withMVar context $
\Context_ {prepared_ = PreparedStatements {..}, ..} ->
SQL.queryStmt conn_ findIPSecStmt [toSQL . toVarChar $ Just name]
listToMaybe <$> Stream.toList stream
mkIPSecSettings xs
where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId, lId, rId] = do
let ?context = context
childCfg <- findChildSAConfig' $ sql2Int childCfgId
peerCfg <- findPeerConfig' $ sql2Int peerId
ikeCfg <- findIKEConfig' $ sql2Int ikeCfgId
lTS <- findTrafficSelector' $ sql2Int lTSId
rTS <- findTrafficSelector' $ sql2Int rTSId
localId <- findIdentity' $ sql2Int lId
remoteId <- findIdentity' $ sql2Int rId
return IPSecSettings { _getIPSecCfgName = fromJust . fromVarChar $ fromSQL cfgName,
_getChildSAConfig = childCfg,
_getPeerConfig = peerCfg,
_getIKEConfig = ikeCfg,
_getLocalTrafficSelector = lTS,
_getRemoteTrafficSelector = rTS,
_getLocalIdentity = localId,
_getRemoteIdentity = remoteId }
mkIPSecSettings vs =
failure $ SQLValuesMismatch ("IPSecSettings " ++ Text.unpack name) (show vs)
sql2Int = fromInt . fromSQL
-- | Removes the specified 'IPSecSettings' from the DB, releasing all linked elements. The returned
-- IPSecSettings will contain now "unlinked" elements (i.e. no IDs, etc).
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
writePeer2ChildConfig' Peer2ChildConfig {p2cPeerCfgId = peerId, p2cChildCfgId = childCfgId }
where addTrafficSelector childId TrafficSelector {..} kind
| isJust _tsId =
void $ writeChild2TSConfig'
Child2TSConfig { c2tsChildCfgId = childId,
c2tsTrafficSelectorCfgId = fromJust _tsId,
c2tsTrafficSelectorKind = kind }
| otherwise =
return ()
unlinkConfig :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m ()
unlinkConfig = do
void . runMaybeT $ do
childCfgId <- MaybeT . use $ getChildSAConfig . childSAId
void $ deleteChild2TSConfig' childCfgId
void $ deleteChildSAConfig' childCfgId
peerId <- MaybeT . use $ getPeerConfig . peerCfgId
void $ deletePeer2ChildConfig' peerId childCfgId
void $ deletePeerConfig' peerId
use getLocalTrafficSelector >>= removeTrafficSelector
use getRemoteTrafficSelector >>= removeTrafficSelector
name <- use getIPSecCfgName
void . runMaybeT $ do
ikeCfgId <- MaybeT . use $ getIKEConfig . ikeId
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
deleteTrafficSelector' tsCfgId
-- | Adds a shared secret to a given identity. If the identity doesn't exist it will get created.
-- If the identity already exists and it already has a secret of the same type, it will be overwritten.
-- This means there can only be one secret of any given type per identity (which makes sense of course
-- from strongswan's perspective).
addSecret :: (Failable m, MonadIO m) => Identity -> SharedSecret -> Context -> m Identity
addSecret identity secret context = do
let ?context = context
result <- runMaybeT $ findIdentityBySelf' identity
identity' <- maybe newIdentity return result
removeSecret identity' (_ssType secret) context
Result {..} <- writeSharedSecret' secret
void $ writeSSIdentity' SharedSecretIdentity { _sharedSecretId = lastModifiedKey,
_identityId = fromJust $ getIdentityId identity' }
return identity'
where newIdentity = do
Result {..} <- writeIdentity identity context
return $ setIdentityId identity lastModifiedKey
-- | Removes a secret of the given type (if present) from the specified identity
removeSecret :: (Failable m, MonadIO m) => Identity -> SharedSecretType -> Context -> m ()
removeSecret identity sType context =
void . runMaybeT $ do
let ?context = context
identId <- MaybeT . return $ getIdentityId identity
ssIdentities <- findSSIdentity' identId
secrets <- mapM (lookupSharedSecret' . _sharedSecretId) ssIdentities
let secrets' = catMaybes secrets
toDelete = catMaybes $ _ssId <$> filter ((sType ==) . _ssType) secrets'
ssIdentities' = case secrets' of
[] ->
ssIdentities
_ ->
filter (\ss2Id -> elem (_sharedSecretId ss2Id) toDelete) ssIdentities
mapM_ deleteSharedSecret' toDelete
mapM_ deleteSSIdentity' ssIdentities'
-- | Removes an identity and its secrets and related entries altogether
removeIdentity :: (Failable m, MonadIO m) => Identity -> Context -> m ()
removeIdentity identity context =
void . runMaybeT $ do
let ?context = context
identId <- MaybeT . return $ getIdentityId identity
ssIdentities <- findSSIdentity' identId
mapM_ (deleteSharedSecret' . _sharedSecretId) ssIdentities
mapM_ deleteSSIdentity' ssIdentities
deleteIdentity' identId
-- manual API
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
writeChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => ChildSAConfig -> m (Result Int)
writeChildSAConfig' = flip writeChildSAConfig ?context
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 =
notFound ("ChildSA" <> Text.pack (show iD)) =<< lookupChildSAConfig iD context
lookupChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe ChildSAConfig)
lookupChildSAConfig iD context =
justOne ("Child SA " <> Text.pack (show iD)) =<<
retrieveRows findChildSAStmt [toSQL $ toInt iD] context
findChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m ChildSAConfig
findChildSAConfig' = flip findChildSAConfig ?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 }
deleteChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteChildSAConfig' = flip deleteChildSAConfig ?context
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
writeIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => IKEConfig -> m (Result Int)
writeIKEConfig' = flip writeIKEConfig ?context
findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig
findIKEConfig iD context =
notFound ("IKEConfig " <> Text.pack (show iD)) =<< lookupIKEConfig iD context
lookupIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe IKEConfig)
lookupIKEConfig iD context =
justOne ("IKEConfig " <> Text.pack (show iD)) =<<
retrieveRows findIKEStmt [toSQL $ toInt iD] context
findIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m IKEConfig
findIKEConfig' = flip findIKEConfig ?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 }
deleteIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteIKEConfig' = flip deleteIKEConfig ?context
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
writePeerConfig' :: (Failable m, MonadIO m, ?context::Context) => PeerConfig -> m (Result Int)
writePeerConfig' = flip writePeerConfig ?context
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 =
notFound ("PeerConfig " <> Text.pack (show iD)) =<< lookupPeerConfig iD context
lookupPeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe PeerConfig)
lookupPeerConfig iD context =
justOne ("PeerConfig " <> Text.pack (show iD)) =<<
retrieveRows findPeerStmt [toSQL $ toInt iD] context
findPeerConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m PeerConfig
findPeerConfig' = flip findPeerConfig ?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 }
deletePeerConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deletePeerConfig' = flip deletePeerConfig ?context
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 }
writePeer2ChildConfig' :: (Failable m, MonadIO m, ?context::Context) => Peer2ChildConfig -> m (Result (Int, Int))
writePeer2ChildConfig' = flip writePeer2ChildConfig ?context
findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig
findPeer2ChildConfig peerId childId context =
notFound ("Peer2Child " <> Text.pack (show peerId)) =<< lookupPeer2ChildConfig peerId childId context
lookupPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Maybe Peer2ChildConfig)
lookupPeer2ChildConfig 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 }
deletePeer2ChildConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> Int -> m (Result (Int, Int))
deletePeer2ChildConfig' peerId = flip (deletePeer2ChildConfig peerId) ?context
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
writeTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => TrafficSelector -> m (Result Int)
writeTrafficSelector' = flip writeTrafficSelector ?context
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 }
deleteTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteTrafficSelector' = flip deleteTrafficSelector ?context
findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector
findTrafficSelector iD context =
notFound ("TrafficSelector " <> Text.pack (show iD)) =<< lookupTrafficSelector iD context
lookupTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe TrafficSelector)
lookupTrafficSelector iD context =
justOne ("TrafficSelector " <> Text.pack (show iD)) =<<
retrieveRows findTSStmt [toSQL $ toInt iD] context
findTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m TrafficSelector
findTrafficSelector' = flip findTrafficSelector ?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]
writeChild2TSConfig' :: (Failable m, MonadIO m, ?context::Context) => Child2TSConfig -> m (Result (Int, Int))
writeChild2TSConfig' = flip writeChild2TSConfig ?context
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 }
deleteChild2TSConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteChild2TSConfig' = flip deleteChild2TSConfig ?context
writeIdentity :: (Failable m, MonadIO m) => Identity -> Context -> m (Result Int)
writeIdentity identity = withContext writeIdentity''
where writeIdentity'' context@Context_ { prepared_ = PreparedStatements {..}, ..} =
writeRow context updateIdentityStmt createIdentityStmt getIdentityId identity
writeIdentity' :: (Failable m, MonadIO m, ?context::Context) => Identity -> m (Result Int)
writeIdentity' = flip writeIdentity ?context
findIdentity :: (Failable m, MonadIO m) => Int -> Context -> m Identity
findIdentity iD context =
notFound ("findIdentity" <> Text.pack (show iD)) =<< lookupIdentity iD context
lookupIdentity :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe Identity)
lookupIdentity iD context =
justOne ("findIdentity" <> Text.pack (show iD)) =<<
retrieveRows findIdentityStmt [toSQL $ toInt iD] context
findIdentity' :: (Failable m, MonadIO m, ?context::Context ) => Int -> m Identity
findIdentity' = flip findIdentity ?context
findIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m Identity
findIdentityBySelf identity context =
notFound ("findIdentityBySelf" <> Text.pack (show identity)) =<< lookupIdentityBySelf identity context
lookupIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m (Maybe Identity)
lookupIdentityBySelf identity context =
justOne ("findIdentityBySelf" <> Text.pack (show identity)) =<<
retrieveRows findIdentityBySelfStmt (toValues identity) context
findIdentityBySelf' :: (Failable m, MonadIO m, ?context::Context ) => Identity -> m Identity
findIdentityBySelf' = flip findIdentityBySelf ?context
deleteIdentity :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteIdentity iD = withContext deleteIdentity''
where deleteIdentity'' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteIdentityStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
deleteIdentity' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteIdentity' = flip deleteIdentity ?context
writeSharedSecret :: (Failable m, MonadIO m) => SharedSecret -> Context -> m (Result Int)
writeSharedSecret ss = withContext writeSS
where writeSS context@Context_ { prepared_ = PreparedStatements{..}, ..} =
writeRow context updateSharedSecretStmt createSharedSecretStmt _ssId ss
writeSharedSecret' :: (Failable m, MonadIO m, ?context::Context) => SharedSecret -> m (Result Int)
writeSharedSecret' = flip writeSharedSecret ?context
findSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m SharedSecret
findSharedSecret iD context =
notFound ("SharedSecret" <> Text.pack (show iD)) =<< lookupSharedSecret iD context
lookupSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe SharedSecret)
lookupSharedSecret iD context =
justOne ("SharedSecret" <> Text.pack (show iD)) =<<
retrieveRows findSharedSecretStmt [toSQL . toInt $ iD] context
lookupSharedSecret' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Maybe SharedSecret)
lookupSharedSecret' = flip lookupSharedSecret ?context
deleteSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteSharedSecret iD = withContext deleteSS
where deleteSS Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteSharedSecretStmt [toSQL $ toInt iD]
return Result { lastModifiedKey = okLastInsertID, response = ok }
deleteSharedSecret' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)
deleteSharedSecret' = flip deleteSharedSecret ?context
writeSSIdentity :: (Failable m, MonadIO m) => SharedSecretIdentity -> Context -> m (Result (Int, Int))
writeSSIdentity ssIdent@SharedSecretIdentity {..} = withContext writeSSIdentity''
where writeSSIdentity'' Context_{ prepared_ = PreparedStatements {..}, ..} = do
result@SQL.OK {..} <- SQL.executeStmt conn_ updateSSIdentityStmt $ sqlValues ++ selector
result' <- if okAffectedRows == 0
then SQL.executeStmt conn_ createSSIdentityStmt sqlValues
else return result
return Result { lastModifiedKey = (_sharedSecretId, _identityId),
response = result' }
sqlValues = toValues ssIdent
selector = toSQL . toInt <$> [_sharedSecretId, _identityId]
writeSSIdentity' :: (Failable m, MonadIO m, ?context::Context) => SharedSecretIdentity -> m (Result (Int, Int))
writeSSIdentity' = flip writeSSIdentity ?context
findSSIdentity :: (Failable m, MonadIO m) => Int -> Context -> m [SharedSecretIdentity]
findSSIdentity iD = retrieveRows findSSIdentityStmt [toSQL . toInt $ iD]
findSSIdentity' :: (Failable m, MonadIO m, ?context::Context) => Int -> m [SharedSecretIdentity]
findSSIdentity' = flip findSSIdentity ?context
deleteSSIdentity :: (Failable m, MonadIO m) => SharedSecretIdentity -> Context -> m (Result (Int, Int))
deleteSSIdentity SharedSecretIdentity {..} = withContext deleteSSIdentity''
where deleteSSIdentity'' Context_ { prepared_ = PreparedStatements {..}, ..} = do
ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteSSIdentityStmt values
return Result { lastModifiedKey = (_sharedSecretId, _identityId), response = ok }
values = toSQL . toInt <$> [_sharedSecretId, _identityId]
deleteSSIdentity' :: (Failable m, MonadIO m, ?context::Context) => SharedSecretIdentity -> m (Result (Int, Int))
deleteSSIdentity' = flip deleteSSIdentity ?context