{-# 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,
--
-- * 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,
                        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
               }

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 }

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 (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 (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'

-- | 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

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