{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.
--

                        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,
-- #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(..),
                        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                 ((^.), (.=), 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   (MonadTrans, 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 a
justOne tag xs@(_:_:_) = failure . MultipleResults tag $ show xs
justOne tag []          = failure $ NotFound tag
justOne _ [x]           = return x

-- | 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 >>= inContext writeIKEConfig >>= setId (getIKEConfig . ikeId)
  name             <- use getIPSecCfgName
  ikeCfgId         <- use (getIKEConfig . ikeId)

  getPeerConfig . peerCfgIKEConfigId .= fromJust ikeCfgId

  use getChildSAConfig         >>= inContext writeChildSAConfig   >>= setId (getChildSAConfig. childSAId)
  use getPeerConfig            >>= inContext writePeerConfig      >>= setId (getPeerConfig . peerCfgId)
  use getLocalTrafficSelector  >>= inContext writeTrafficSelector >>= setId (getLocalTrafficSelector . tsId)
  use getRemoteTrafficSelector >>= inContext writeTrafficSelector >>= setId (getRemoteTrafficSelector . tsId)

  ipsec <- get

  SQL.OK {..} <-
    lift . failableIO $ withMVar ?context $ \Context_ {prepared_ = PreparedStatements{..}, ..} ->
      SQL.executeStmt conn_ createIPSecStmt $
        (toSQL . toVarChar $ Just name) :
        (toSQL . toInt . fromJust <$> [ipsec ^. getChildSAConfig . childSAId,
                                       ipsec ^. getPeerConfig . peerCfgId,
                                       ipsec ^. getIKEConfig . ikeId,
                                       ipsec ^. getLocalTrafficSelector . tsId,
                                       ipsec ^. getRemoteTrafficSelector . tsId])
  when (okAffectedRows /= 1) $ lift . failure $ FailedOperation ("createIPSec " <> name)
  linkConfig
    where setId lens Result {..} = lens .= Just lastModifiedKey

-- | 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 = do
  xs <- failableIO $ do
          (_,stream) <- withMVar context $
            \Context_ {prepared_ = PreparedStatements {..}, ..} ->
              SQL.queryStmt conn_ findIPSecStmt [toSQL . toVarChar $ Just name]
          listToMaybe <$> Stream.toList stream
  maybe (failure . NotFound $ "IPSecSettings " <> name) mkIPSecSettings xs
    where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId] = do
            childCfg <- findChildSAConfig (sql2Int childCfgId) context
            peerCfg  <- findPeerConfig (sql2Int peerId) context
            ikeCfg   <- findIKEConfig (sql2Int ikeCfgId) context
            lTS      <- findTrafficSelector (sql2Int lTSId) context
            rTS      <- findTrafficSelector (sql2Int rTSId) context
            return IPSecSettings { _getIPSecCfgName          = fromJust . fromVarChar $ fromSQL cfgName,
                                   _getChildSAConfig         = childCfg,
                                   _getPeerConfig            = peerCfg,
                                   _getIKEConfig             = ikeCfg,
                                   _getLocalTrafficSelector  = lTS,
                                   _getRemoteTrafficSelector = rTS }
          mkIPSecSettings vs =
            failure $ SQLValuesMismatch ("IPSecSettings " ++ Text.unpack name) (show vs)
          sql2Int = fromInt . fromSQL

-- | 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
        lift $ inContext writePeer2ChildConfig Peer2ChildConfig {
                                                   p2cPeerCfgId  = peerId,
                                                   p2cChildCfgId = childCfgId
                                               }
            where addTrafficSelector childId TrafficSelector {..} kind
                    | isJust _tsId =
                        void . lift $ inContext writeChild2TSConfig
                          Child2TSConfig { c2tsChildCfgId           = childId,
                                           c2tsTrafficSelectorCfgId = fromJust _tsId,
                                           c2tsTrafficSelectorKind  = kind }
                    | otherwise =
                        return ()

inContext :: (?context::Context, Failable m, MonadTrans t) => (a -> Context -> m b) -> a -> t m b
inContext f x = lift $ f x ?context

unlinkConfig :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m ()
unlinkConfig = do
    void . runMaybeT $ do
        childCfgId <- MaybeT . use $ getChildSAConfig . childSAId
        void . lift $ inContext deleteChild2TSConfig childCfgId
        void . lift $ inContext deleteChildSAConfig childCfgId
        peerId  <- MaybeT . use $ getPeerConfig . peerCfgId
        void . lift $ inContext (deletePeer2ChildConfig peerId) childCfgId
        lift $ inContext deletePeerConfig peerId

    use getLocalTrafficSelector  >>= removeTrafficSelector
    use getRemoteTrafficSelector >>= removeTrafficSelector

    name <- use getIPSecCfgName

    void . runMaybeT $ do
        ikeCfgId <- MaybeT . use $ getIKEConfig . ikeId
        lift $ inContext deleteIKEConfig ikeCfgId

    void . lift . failableIO . withMVar ?context $
      \Context_{prepared_ = PreparedStatements{..}, ..} ->
        SQL.executeStmt conn_ deleteIPSecStmt [toSQL . toVarChar $ Just name]

    getIKEConfig             . ikeId     .= Nothing
    getChildSAConfig         . childSAId .= Nothing
    getPeerConfig            . peerCfgId .= Nothing
    getLocalTrafficSelector  . tsId      .= Nothing
    getRemoteTrafficSelector . tsId      .= Nothing
      where removeTrafficSelector sel =
              void . runMaybeT $ do
                tsCfgId <- MaybeT . return $ _tsId sel
                lift $ inContext deleteTrafficSelector tsCfgId

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

findChildSAConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [ChildSAConfig]
findChildSAConfigByName name = retrieveRows findChildSAByNameStmt [toSQL . toVarChar $ Just name]

findChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m ChildSAConfig
findChildSAConfig iD context =
  justOne ("Child SA " <> Text.pack (show iD)) =<<
    retrieveRows findChildSAStmt [toSQL $ toInt iD] context

deleteChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteChildSAConfig iD = withContext deleteChildSAConfig'
    where deleteChildSAConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteChildSAStmt [toSQL $ toInt iD]
            return Result { lastModifiedKey = okLastInsertID, response = ok }

writeIKEConfig :: (Failable m, MonadIO m) => IKEConfig -> Context -> m (Result Int)
writeIKEConfig cfg = withContext writeIKEConfig''
    where writeIKEConfig'' context@Context_ { prepared_ = PreparedStatements {..}, ..} =
            writeRow context updateIKEStmt createIKEStmt _ikeId cfg

findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig
findIKEConfig iD context =
  justOne ("IKEConfig " <> Text.pack (show iD)) =<<
    retrieveRows findIKEStmt [toSQL $ toInt iD] context

deleteIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteIKEConfig iD = withContext deleteIKEConfig'
    where deleteIKEConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteIKEStmt [toSQL $ toInt iD]
            return Result { lastModifiedKey = okLastInsertID, response = ok }

writePeerConfig :: (Failable m, MonadIO m) => PeerConfig -> Context -> m (Result Int)
writePeerConfig cfg = withContext writePeerConfig''
    where writePeerConfig'' context@Context_ { prepared_ = PreparedStatements {..} } =
            writeRow context updatePeerStmt createPeerStmt _peerCfgId cfg

findPeerConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [PeerConfig]
findPeerConfigByName name = retrieveRows findPeerByNameStmt [toSQL . toVarChar $ Just name]

findPeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m PeerConfig
findPeerConfig iD context =
  justOne ("PeerConfig " <> Text.pack (show iD)) =<<
    retrieveRows findPeerStmt [toSQL $ toInt iD] context

deletePeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deletePeerConfig iD = withContext deletePeerConfig'
    where deletePeerConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deletePeerStmt [toSQL $ toInt iD]
            return Result { lastModifiedKey = okLastInsertID, response = ok }

writePeer2ChildConfig :: (Failable m, MonadIO m) => Peer2ChildConfig -> Context -> m (Result (Int, Int))
writePeer2ChildConfig cfg@Peer2ChildConfig {..} = withContext writeP2CConfig
    where writeP2CConfig Context_ { prepared_ = PreparedStatements {..}, .. } = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ createP2CStmt $ toValues cfg
            return Result { lastModifiedKey = (p2cPeerCfgId, p2cChildCfgId), response = ok }

findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig
findPeer2ChildConfig peerId childId context =
  justOne ("Peer2Child " <> Text.pack (show peerId) <> " - " <> Text.pack (show childId)) =<<
    retrieveRows findP2CStmt (toSQL.toInt <$> [peerId, childId]) context

deletePeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Result (Int, Int))
deletePeer2ChildConfig peerId childId  = withContext deletePeer2ChildConfig'
    where deletePeer2ChildConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteP2CStmt $
                                toSQL . toInt <$> [peerId, childId]
            return Result { lastModifiedKey = (peerId, childId) , response = ok }

writeTrafficSelector :: (Failable m, MonadIO m) => TrafficSelector -> Context -> m (Result Int)
writeTrafficSelector ts = withContext writeTS
    where writeTS context@Context_ { prepared_ = PreparedStatements {..}, .. } =
            writeRow context updateTSStmt createTSStmt _tsId ts

deleteTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteTrafficSelector iD = withContext deleteTrafficSelector'
    where deleteTrafficSelector' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteTSStmt [toSQL $ toInt iD]
            return Result { lastModifiedKey = okLastInsertID, response = ok }

findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector
findTrafficSelector iD context =
  justOne ("TrafficSelector " <> Text.pack (show iD)) =<<
    retrieveRows findTSStmt [toSQL $ toInt iD] context

writeChild2TSConfig :: (Failable m, MonadIO m) => Child2TSConfig -> Context -> m (Result (Int, Int))
writeChild2TSConfig cfg@Child2TSConfig {..} = withContext writeChild2TSConfig''
    where writeChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, .. } = do
            result@SQL.OK {..} <- SQL.executeStmt conn_ updateC2TSStmt $ sqlValues ++ selector
            result' <- if okAffectedRows == 0
                         then SQL.executeStmt conn_ createC2TSStmt sqlValues
                         else return result
            return Result { lastModifiedKey = (c2tsChildCfgId, c2tsTrafficSelectorCfgId),
                            response = result' }
          sqlValues = toValues cfg
          selector  = toSQL . toInt <$> [c2tsChildCfgId, c2tsTrafficSelectorCfgId]

lookupChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m [Child2TSConfig]
lookupChild2TSConfig iD = retrieveRows findC2TSStmt [toSQL $ toInt iD]

deleteChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)
deleteChild2TSConfig iD = withContext deleteChild2TSConfig'
    where deleteChild2TSConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do
            ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteC2TSStmt [toSQL $ toInt iD]
            return Result { lastModifiedKey = okLastInsertID, response = ok }

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

findIdentity :: (Failable m, MonadIO m) => Int -> Context -> m Identity
findIdentity iD context =
  justOne ("findIdentity" <> Text.pack (show iD)) =<<
    retrieveRows findIdentityStmt [toSQL $ toInt iD] 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