{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module StrongSwan.SQL (
mkContext,
writeIPSecSettings,
findIPSecSettings,
deleteIPSecSettings,
addSecret,
removeSecret,
removeIdentity,
writeChild2TSConfig,
writeChildSAConfig,
writeIdentity,
writeIKEConfig,
writePeerConfig,
writePeer2ChildConfig,
writeSharedSecret,
writeSSIdentity,
writeTrafficSelector,
lookupChild2TSConfig,
findChildSAConfig,
findChildSAConfigByName,
findIdentity,
findIdentityBySelf,
findIKEConfig,
findPeerConfig,
findPeerConfigByName,
findPeer2ChildConfig,
findSharedSecret,
findSSIdentity,
findTrafficSelector,
deleteChild2TSConfig,
deleteChildSAConfig,
deleteIdentity,
deleteIKEConfig,
deleteSharedSecret,
deleteSSIdentity,
deletePeer2ChildConfig,
deletePeerConfig,
module StrongSwan.SQL.Lenses,
dbHost,
dbPort,
dbName,
dbUser,
dbPassword,
dbCharSet,
AuthMethod(..),
ChildSAConfig(..),
Child2TSConfig(..),
CertPolicy(..),
Context,
EAPType(..),
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
}
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 >>= 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'
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, 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
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
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
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 (findSharedSecret' . _sharedSecretId) ssIdentities
let toDelete = catMaybes $ _ssId <$> filter ((sType ==) . _ssType) secrets
ssIdentities' = filter (\ss2Id -> elem (_sharedSecretId ss2Id) toDelete) ssIdentities
mapM_ deleteSharedSecret' toDelete
mapM_ deleteSSIdentity' ssIdentities'
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
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 =
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 =
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 =
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 =
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 =
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 =
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 =
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 =
justOne ("SharedSecret" <> Text.pack (show iD)) =<<
retrieveRows findSharedSecretStmt [toSQL . toInt $ iD] context
findSharedSecret' :: (Failable m, MonadIO m, ?context::Context) => Int -> m SharedSecret
findSharedSecret' = flip findSharedSecret ?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