diff --git a/app/CLI/Commands.hs b/app/CLI/Commands.hs --- a/app/CLI/Commands.hs +++ b/app/CLI/Commands.hs @@ -4,6 +4,7 @@ import CLI.Commands.ChildSA import CLI.Commands.Common +import CLI.Commands.Identity import CLI.Commands.PeerCfg import CLI.Commands.TrafficSelector import CLI.Types @@ -48,7 +49,13 @@ showTrafficSelector' getRemoteTrafficSelector exitCmd showConnection + command "remove" "Wipes out this connection from the DB" $ do + db <- use dbContext + ipsecCfg <- use ipsecSettings + void . runMaybeT $ deleteIPSecSettings ipsecCfg db + return NoAction exitCmd + cfgIdentity where setConnection name = do db <- use dbContext result <- runMaybeT $ findIPSecSettings name db diff --git a/app/CLI/Commands/Common.hs b/app/CLI/Commands/Common.hs --- a/app/CLI/Commands/Common.hs +++ b/app/CLI/Commands/Common.hs @@ -9,23 +9,34 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (StateT, lift) import Data.Bool (bool) -import Data.IP (IP) +import Data.ByteString.Char8 (ByteString) +import Data.IP (IP, IPv4, IPv6) import Data.List (find) import Data.Text (Text, pack) import Text.Read (readMaybe) import StrongSwan.SQL (SQLRow) import System.Console.StructuredCLI hiding (Commands) -import qualified StrongSwan.SQL as SQL +import qualified Data.ByteString.Char8 as B +import qualified StrongSwan.SQL as SQL string :: (Monad m) => String -> m (Maybe Text) string = return . Just . pack +bytes :: (Monad m) => String -> m (Maybe ByteString) +bytes = return . Just . B.pack + integer :: (Monad m, Integral n ) => String -> m (Maybe n) integer = return . fmap fromIntegral . readMaybe @Integer ipAddress :: (Monad m) => String -> m (Maybe IP) ipAddress = return . readMaybe + +ipV4Address :: (Monad m) => String -> m (Maybe IPv4) +ipV4Address = return . readMaybe + +ipV6Address :: (Monad m) => String -> m (Maybe IPv6) +ipV6Address = return . readMaybe boolean :: (Monad m) => String -> String -> String -> m (Maybe Bool) boolean yes no str | str == yes = return $ Just True diff --git a/app/CLI/Commands/Identity.hs b/app/CLI/Commands/Identity.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands/Identity.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} + +module CLI.Commands.Identity where + +import Control.Lens ((.=), use) +import Control.Monad (void) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import CLI.Commands.Common +import CLI.Types +import Data.Default (def) +import Data.Maybe (fromMaybe) +import Control.Monad.State.Strict (StateT, lift) +import StrongSwan.SQL +import System.Console.StructuredCLI hiding (Commands) + +secretType' :: (Monad m) => Validator m SharedSecretType +secretType' = return . fromName + +cfgIdentity :: Commands () +cfgIdentity = + command "identity" "Identity configuration" newLevel >+ do + command "any" "Matches any ID" (setIdentity $ AnyID Nothing) >+ do + identityCmds + param "ipv4" "" ipV4Address (setIdentity . IPv4AddrID Nothing) >+ do + identityCmds + param "ipv4" "" ipV6Address (setIdentity . IPv6AddrID Nothing) >+ do + identityCmds + +cfgSecret :: Commands () +cfgSecret = + param "shared-secret" "" bytes setSecret >+ do + param "type" "" secretType' $ \sType -> do + db <- use dbContext + ident <- use identity + str <- use secretStr + let secret = def { _ssData = str, _ssType = sType } + ident' <- lift $ addSecret ident secret db + identity .= ident' + return NoAction + where setSecret str = do + secretStr .= str + return NewLevel + +setIdentity :: Identity -> StateT AppState IO Action +setIdentity ident = do + db <- use dbContext + result <- runMaybeT $ findIdentityBySelf ident db + identity .= fromMaybe ident result + return NewLevel + +removeIdent :: Commands () +removeIdent = + command "remove" "delete identity from DB and all associated secrets, etc" $ do + db <- use dbContext + ident <- use identity + void . runMaybeT $ removeIdentity ident db + return NoAction + +identityCmds :: Commands () +identityCmds = do + removeIdent + cfgSecret + exitCmd diff --git a/app/CLI/Types.hs b/app/CLI/Types.hs --- a/app/CLI/Types.hs +++ b/app/CLI/Types.hs @@ -7,6 +7,7 @@ import Control.Monad.Failable (Failable(..)) import Control.Monad.State.Strict (StateT) import Control.Exception (Exception) +import Data.ByteString (ByteString) import Data.Char (toLower) import Data.Default import Data.Text (Text) @@ -36,6 +37,8 @@ _options :: Options, _dbContext :: SQL.Context, _ipsecSettings :: SQL.IPSecSettings, + _identity :: SQL.Identity, + _secretStr :: ByteString, _flush :: Maybe (StateT AppState IO Action) } @@ -110,7 +113,7 @@ instance Nameable SQL.AuthMethod where nameOf = fmap toLower . show - fromName "any" = return SQL.Any + fromName "any" = return SQL.AnyAuth fromName "rsa" = return SQL.PubKey fromName "psk" = return SQL.PSK fromName "eap" = return SQL.EAP @@ -123,4 +126,18 @@ fromName "ipv4" = return SQL.IPv4AddrRange fromName "ipv6" = return SQL.IPv6AddrRange fromName str = failure $ InvalidValue str + +instance Nameable SQL.SharedSecretType where + nameOf SQL.SharedIKE = "psk" + nameOf SQL.SharedEAP = "eap" + nameOf SQL.SharedRSA = "rsa" + nameOf SQL.SharedPIN = "pin" + fromName "psk" = return SQL.SharedIKE + fromName "eap" = return SQL.SharedEAP + fromName "rsa" = return SQL.SharedRSA + fromName "pin" = return SQL.SharedPIN + fromName str = failure $ InvalidValue str + + + diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -42,9 +42,13 @@ let state = AppState { _options = options', _dbContext = db, _ipsecSettings = def, - _flush = Nothing } - runCLI "strongswan SQL" def commands `evalStateT` state >>= hoist FatalError + _flush = Nothing, + _identity = def, + _secretStr = "" } + runCLI "strongswan SQL" cliSettings commands `evalStateT` state >>= hoist FatalError where mkContext' Options{..} = SQL.mkContext _settings + cliSettings = def { getHistory = Just ".strongswan-sql.history" } + modifySettings :: (SQL.Settings -> SQL.Settings) -> ArgsParser () modifySettings = (settings %=) diff --git a/src/StrongSwan/SQL.hs b/src/StrongSwan/SQL.hs --- a/src/StrongSwan/SQL.hs +++ b/src/StrongSwan/SQL.hs @@ -37,6 +37,9 @@ 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 @@ -65,21 +68,31 @@ 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# @@ -100,6 +113,7 @@ CertPolicy(..), Context, EAPType(..), + Identity(..), IKEConfig(..), IPSecSettings(..), PeerConfig(..), @@ -108,6 +122,9 @@ SAAction(..), SAMode(..), Settings(..), + SharedSecret(..), + SharedSecretIdentity(..), + SharedSecretType(..), SQL.OK(..), SQLRow, TrafficSelector(..), @@ -117,13 +134,13 @@ import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Lens ((^.), (.=), makeLenses, use) -import Control.Monad (void, when) +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 (isNothing, isJust, fromJust, listToMaybe) +import Data.Maybe (catMaybes, isNothing, isJust, fromJust, listToMaybe) import Data.Text (Text) import Database.MySQL.Base (MySQLConn) import Control.Monad.Failable @@ -352,6 +369,50 @@ 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 {..}} = @@ -460,3 +521,94 @@ 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 + + + + + + + + diff --git a/src/StrongSwan/SQL/Encoding.hs b/src/StrongSwan/SQL/Encoding.hs --- a/src/StrongSwan/SQL/Encoding.hs +++ b/src/StrongSwan/SQL/Encoding.hs @@ -54,22 +54,25 @@ fromSQL SQL.MySQLNull = NullChar fromSQL v = throw $ InvalidValueForType "VarChar" (show v) +fromId :: SQL.MySQLValue -> Maybe Int +fromId = return . fromInt . fromSQL + instance SQLRow Identity where - toValues AnyID = [toSQL $ toTinyInt (0::Word8), toSQL $ toVarBinary "%any"] - toValues (IPv4AddrID v4) = [toSQL $ toTinyInt (1::Word8), toSQL $ toVarBinary v4] - toValues (NameID str) = [toSQL $ toTinyInt (2::Word8), toSQL $ toVarBinary str] - toValues (EmailID local domain) = [toSQL $ toTinyInt (3::Word8), toSQL $ toVarBinary (local ++ '@':domain)] - toValues (IPv6AddrID v6) = [toSQL $ toTinyInt (5::Word8), toSQL $ toVarBinary v6] - toValues (ASN1ID elements) = [toSQL $ toTinyInt (9::Word8), toSQL $ toVarBinary (encodeASN1' DER elements)] - toValues (OpaqueID bytes) = [toSQL $ toTinyInt (11::Word8), toSQL $ toVarBinary bytes] + toValues (AnyID _) = [toSQL $ toTinyInt (0::Word8), toSQL $ toVarBinary "%any"] + toValues (IPv4AddrID _ v4) = [toSQL $ toTinyInt (1::Word8), toSQL $ toVarBinary v4] + toValues (NameID _ str) = [toSQL $ toTinyInt (2::Word8), toSQL $ toVarBinary str] + toValues (EmailID _ local domain) = [toSQL $ toTinyInt (3::Word8), toSQL $ toVarBinary (local ++ '@':domain)] + toValues (IPv6AddrID _ v6) = [toSQL $ toTinyInt (5::Word8), toSQL $ toVarBinary v6] + toValues (ASN1ID _ elements) = [toSQL $ toTinyInt (9::Word8), toSQL $ toVarBinary (encodeASN1' DER elements)] + toValues (OpaqueID _ bytes) = [toSQL $ toTinyInt (11::Word8), toSQL $ toVarBinary bytes] - fromValues [SQL.MySQLInt8U 0, _] = AnyID - fromValues [SQL.MySQLInt8U 1, v] = IPv4AddrID . fromVarBinary $ fromSQL v - fromValues [SQL.MySQLInt8U 2, v] = NameID . fromVarBinary $ fromSQL v - fromValues [SQL.MySQLInt8U 3, v] = uncurry EmailID . parseEmail . fromVarBinary $ fromSQL v - fromValues [SQL.MySQLInt8U 5, v] = IPv6AddrID . fromVarBinary $ fromSQL v - fromValues [SQL.MySQLInt8U 9, v] = ASN1ID . either throw id . decodeASN1' DER . fromVarBinary $ fromSQL v - fromValues v = throw $ SQLValuesMismatch "Identity" (show v) + fromValues [iD, SQL.MySQLInt8U 0, _] = AnyID (fromId iD) + fromValues [iD, SQL.MySQLInt8U 1, v] = IPv4AddrID (fromId iD) . fromVarBinary $ fromSQL v + fromValues [iD, SQL.MySQLInt8U 2, v] = NameID (fromId iD) . fromVarBinary $ fromSQL v + fromValues [iD, SQL.MySQLInt8U 3, v] = uncurry (EmailID $ fromId iD) . parseEmail . fromVarBinary $ fromSQL v + fromValues [iD, SQL.MySQLInt8U 5, v] = IPv6AddrID (fromId iD) . fromVarBinary $ fromSQL v + fromValues [iD, SQL.MySQLInt8U 9, v] = ASN1ID (fromId iD) . either throw id . decodeASN1' DER . fromVarBinary $ fromSQL v + fromValues v = throw $ SQLValuesMismatch "Identity" (show v) parseEmail :: ByteString -> (String, String) parseEmail = second (drop 1) . span (/= '@') . unpack @@ -266,6 +269,27 @@ c2tsTrafficSelectorKind = fromTinyInt $ fromSQL trafficSelectorKind } fromValues xs = throw $ SQLValuesMismatch "Child2TSConfig" (show xs) + +instance SQLRow SharedSecret where + toValues SharedSecret {..} = [ + toSQL $ toTinyInt _ssType, + toSQL $ toVarBinary _ssData ] + fromValues (iD : sharedSecretType : sharedSecretData : []) = + SharedSecret { + _ssId = return . fromInt $ fromSQL iD, + _ssType = fromTinyInt $ fromSQL sharedSecretType, + _ssData = fromVarBinary $ fromSQL sharedSecretData + } + fromValues xs = throw $ SQLValuesMismatch "SharedSecret" (show xs) + +instance SQLRow SharedSecretIdentity where + toValues SharedSecretIdentity {..} = toSQL . toInt <$> [_sharedSecretId, _identityId] + fromValues [ssId, identityId] = SharedSecretIdentity { + _sharedSecretId = fromInt $ fromSQL ssId, + _identityId = fromInt $ fromSQL identityId + } + fromValues xs = throw $ SQLValuesMismatch "SharedSecretIdentity" (show xs) + encodeHex :: ByteString -> String encodeHex = B.foldr showHex "" diff --git a/src/StrongSwan/SQL/Lenses.hs b/src/StrongSwan/SQL/Lenses.hs --- a/src/StrongSwan/SQL/Lenses.hs +++ b/src/StrongSwan/SQL/Lenses.hs @@ -9,4 +9,6 @@ makeLenses ''ChildSAConfig makeLenses ''PeerConfig makeLenses ''TrafficSelector +makeLenses ''SharedSecret +makeLenses ''SharedSecretIdentity makeLenses ''IPSecSettings diff --git a/src/StrongSwan/SQL/Statements.hs b/src/StrongSwan/SQL/Statements.hs --- a/src/StrongSwan/SQL/Statements.hs +++ b/src/StrongSwan/SQL/Statements.hs @@ -61,6 +61,28 @@ findC2TSStatement, deleteC2TSStatement] + [createIdentity, updateIdentity, findIdentity, findIdentityBySelf, deleteIdentity] <- + initializeWith createIdentityTable + [createIdentityStatement, + updateIdentityStatement, + findIdentityStatement, + findIdentityBySelfStatement, + deleteIdentityStatement] + + [createSharedSecret, updateSharedSecret, findSharedSecret, deleteSharedSecret] <- + initializeWith createSharedSecretTable + [createSharedSecretStatement, + updateSharedSecretStatement, + findSharedSecretStatement, + deleteSharedSecretStatement] + + [createSSIdentity, updateSSIdentity, findSSIdentity, deleteSSIdentity] <- + initializeWith createSSIdentityTable + [createSSIdentityStatement, + updateSSIdentityStatement, + findSSIdentityStatement, + deleteSSIdentityStatement] + [createIPSec, findIPSec, deleteIPSec] <- initializeWith createIPSecTableStatement [createIPSecStatement, @@ -68,35 +90,48 @@ deleteIPSecStatement] return PreparedStatements { - updateChildSAStmt = updateChildSA, - createChildSAStmt = createChildSA, - findChildSAByNameStmt = findChildSAByName, - findChildSAStmt = findChildSA, - deleteChildSAStmt = deleteChildSA, - updateIKEStmt = updateIKE, - createIKEStmt = createIKE, - findIKEStmt = findIKE, - deleteIKEStmt = deleteIKE, - updatePeerStmt = updatePeer, - createPeerStmt = createPeer, - findPeerStmt = findPeer, - findPeerByNameStmt = findPeerByName, - deletePeerStmt = deletePeer, - updateP2CStmt = updateP2C, - createP2CStmt = createP2C, - findP2CStmt = findP2C, - deleteP2CStmt = deleteP2C, - findTSStmt = findTS, - createTSStmt = createTS, - updateTSStmt = updateTS, - deleteTSStmt = deleteTS, - updateC2TSStmt = updateC2TS, - createC2TSStmt = createC2TS, - findC2TSStmt = findC2TS, - deleteC2TSStmt = deleteC2TS, - createIPSecStmt = createIPSec, - findIPSecStmt = findIPSec, - deleteIPSecStmt = deleteIPSec + updateChildSAStmt = updateChildSA, + createChildSAStmt = createChildSA, + findChildSAByNameStmt = findChildSAByName, + findChildSAStmt = findChildSA, + deleteChildSAStmt = deleteChildSA, + updateIKEStmt = updateIKE, + createIKEStmt = createIKE, + findIKEStmt = findIKE, + deleteIKEStmt = deleteIKE, + updatePeerStmt = updatePeer, + createPeerStmt = createPeer, + findPeerStmt = findPeer, + findPeerByNameStmt = findPeerByName, + deletePeerStmt = deletePeer, + updateP2CStmt = updateP2C, + createP2CStmt = createP2C, + findP2CStmt = findP2C, + deleteP2CStmt = deleteP2C, + findTSStmt = findTS, + createTSStmt = createTS, + updateTSStmt = updateTS, + deleteTSStmt = deleteTS, + updateC2TSStmt = updateC2TS, + createC2TSStmt = createC2TS, + findC2TSStmt = findC2TS, + deleteC2TSStmt = deleteC2TS, + updateIdentityStmt = updateIdentity, + createIdentityStmt = createIdentity, + findIdentityStmt = findIdentity, + findIdentityBySelfStmt = findIdentityBySelf, + deleteIdentityStmt = deleteIdentity, + updateSharedSecretStmt = updateSharedSecret, + createSharedSecretStmt = createSharedSecret, + findSharedSecretStmt = findSharedSecret, + deleteSharedSecretStmt = deleteSharedSecret, + updateSSIdentityStmt = updateSSIdentity, + createSSIdentityStmt = createSSIdentity, + findSSIdentityStmt = findSSIdentity, + deleteSSIdentityStmt = deleteSSIdentity, + createIPSecStmt = createIPSec, + findIPSecStmt = findIPSec, + deleteIPSecStmt = deleteIPSec } prepare :: (?conn :: MySQLConn, Failable m, MonadIO m) => SQL.Query -> m SQL.StmtID @@ -197,6 +232,54 @@ deleteC2TSStatement :: SQL.Query deleteC2TSStatement = "DELETE FROM child_config_traffic_selector WHERE child_cfg = ?;" + +createSharedSecretTable :: SQL.Query +createSharedSecretTable = "CREATE TABLE shared_secrets (`id` int(10) unsigned NOT NULL auto_increment, `type` tinyint(3) unsigned NOT NULL, `data` varbinary(256) NOT NULL, PRIMARY KEY (`id`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createSharedSecretStatement :: SQL.Query +createSharedSecretStatement = "INSERT INTO shared_secrets (type, data) VALUES (?, ?);" + +updateSharedSecretStatement :: SQL.Query +updateSharedSecretStatement = "UPDATE shared_secrets SET type = ?, data = ? WHERE id = ?;" + +findSharedSecretStatement :: SQL.Query +findSharedSecretStatement = "SELECT * FROM shared_secrets WHERE id = ?;" + +deleteSharedSecretStatement :: SQL.Query +deleteSharedSecretStatement = "DELETE FROM shared_secrets WHERE id = ?;" + +createIdentityTable :: SQL.Query +createIdentityTable = "CREATE TABLE `identities` (`id` int(10) unsigned NOT NULL auto_increment, `type` tinyint(4) unsigned NOT NULL, `data` varbinary(64) NOT NULL, PRIMARY KEY (`id`), UNIQUE (`type`, `data`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createIdentityStatement :: SQL.Query +createIdentityStatement = "INSERT INTO identities (type, data) VALUES (?, ?);" + +updateIdentityStatement :: SQL.Query +updateIdentityStatement = "UPDATE identities SET type = ?, data = ? WHERE id = ?;" + +findIdentityStatement :: SQL.Query +findIdentityStatement = "SELECT * FROM identities WHERE id = ?;" + +findIdentityBySelfStatement :: SQL.Query +findIdentityBySelfStatement = "SELECT * FROM identities WHERE type = ? AND data = ?;" + +deleteIdentityStatement :: SQL.Query +deleteIdentityStatement = "DELETE FROM identities WHERE id = ?;" + +createSSIdentityTable :: SQL.Query +createSSIdentityTable = "CREATE TABLE shared_secret_identity (`shared_secret` int(10) unsigned NOT NULL, `identity` int(10) unsigned NOT NULL, PRIMARY KEY (`shared_secret`, `identity`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createSSIdentityStatement :: SQL.Query +createSSIdentityStatement = "INSERT INTO shared_secret_identity (shared_secret, identity) VALUES (?, ?);" + +updateSSIdentityStatement :: SQL.Query +updateSSIdentityStatement = "UPDATE shared_secret_identity SET shared_secret = ?, identity = ? WHERE shared_secret = ? AND identity = ?;" + +findSSIdentityStatement :: SQL.Query +findSSIdentityStatement = "SELECT * from shared_secret_identity WHERE identity = ?;" + +deleteSSIdentityStatement :: SQL.Query +deleteSSIdentityStatement = "DELETE FROM shared_secret_identity WHERE shared_secret = ? AND identity = ?;" createIPSecTableStatement :: SQL.Query createIPSecTableStatement = "CREATE TABLE `ipsec_configs` (`name` varchar(64) NOT NULL, `child_cfg` int(10) unsigned NOT NULL, `peer_cfg` int(10) unsigned NOT NULL, `ike_cfg` int(10) unsigned NOT NULL, `local_ts` int(10) unsigned NOT NULL, `remote_ts` int(10) unsigned NOT NULL, PRIMARY KEY (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" diff --git a/src/StrongSwan/SQL/Types.hs b/src/StrongSwan/SQL/Types.hs --- a/src/StrongSwan/SQL/Types.hs +++ b/src/StrongSwan/SQL/Types.hs @@ -29,6 +29,7 @@ | UnknownEAPType Int | UnknownTrafficSelectorType Int | UnknownTrafficSelectorKind Int + | UnknownSharedSecretType Int | InvalidValueForType String String | SQLValuesMismatch String String | NotFound Text @@ -66,14 +67,36 @@ toEnum 60 = UTF32 toEnum x = throw $ UnknownCharacterEncoding x -data Identity = AnyID -- Matches any ID (/%any/) - | IPv4AddrID IPv4 -- IPv4 Address - | NameID String -- Fully qualified Domain Name - | EmailID String String -- ^ RFC 822 Email Address /mailbox/@/domain/ - | IPv6AddrID IPv6 -- IPv6 Address - | ASN1ID [ASN1] - | OpaqueID ByteString -- Opaque octet string as ID +data Identity = AnyID (Maybe Int) -- Matches any ID (/%any/) + | IPv4AddrID (Maybe Int) IPv4 -- IPv4 Address + | NameID (Maybe Int) String -- Fully qualified Domain Name + | EmailID (Maybe Int) String String -- ^ RFC 822 Email Address /mailbox/@/domain/ + | IPv6AddrID (Maybe Int) IPv6 -- IPv6 Address + | ASN1ID (Maybe Int) [ASN1] -- DER encoded ASN.1 distinguished name + | OpaqueID (Maybe Int) ByteString -- Opaque octet string as ID + deriving Show +getIdentityId :: Identity -> Maybe Int +getIdentityId (AnyID iD) = iD +getIdentityId (IPv4AddrID iD _) = iD +getIdentityId (NameID iD _) = iD +getIdentityId (EmailID iD _ _) = iD +getIdentityId (IPv6AddrID iD _) = iD +getIdentityId (ASN1ID iD _) = iD +getIdentityId (OpaqueID iD _) = iD + +setIdentityId :: Identity -> Int -> Identity +setIdentityId (AnyID _) iD = AnyID (Just iD) +setIdentityId (IPv4AddrID _ x) iD = IPv4AddrID (Just iD) x +setIdentityId (NameID _ x) iD = NameID (Just iD) x +setIdentityId (EmailID _ x y) iD = EmailID (Just iD) x y +setIdentityId (IPv6AddrID _ x) iD = IPv6AddrID (Just iD) x +setIdentityId (ASN1ID _ x) iD = ASN1ID (Just iD) x +setIdentityId (OpaqueID _ x) iD = OpaqueID (Just iD) x + +instance Default Identity where + def = AnyID Nothing + data Value (a :: k -> SQL.MySQLValue) where TinyInt :: Word8 -> Value 'SQL.MySQLInt8U SmallInt :: Word16 -> Value 'SQL.MySQLInt16U @@ -131,6 +154,10 @@ toTinyInt = toSQLEnum fromTinyInt = fromSQLEnum +instance TinyInt SharedSecretType where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + class SmallInt a where toSmallInt :: a -> Value 'SQL.MySQLInt16U fromSmallInt :: Value 'SQL.MySQLInt16U -> a @@ -236,7 +263,7 @@ toEnum 2 = NeverSend toEnum x = throw $ UnknownCertPolicy x -data AuthMethod = Any +data AuthMethod = AnyAuth | PubKey | PSK | EAP @@ -244,13 +271,13 @@ deriving (Eq, Show) instance Enum AuthMethod where - fromEnum Any = 0 - fromEnum PubKey = 1 - fromEnum PSK = 2 - fromEnum EAP = 3 - fromEnum XAUTH = 4 + fromEnum AnyAuth = 0 + fromEnum PubKey = 1 + fromEnum PSK = 2 + fromEnum EAP = 3 + fromEnum XAUTH = 4 - toEnum 0 = Any + toEnum 0 = AnyAuth toEnum 1 = PubKey toEnum 2 = PSK toEnum 3 = EAP @@ -318,6 +345,23 @@ toEnum 3 = RemoteDynamicTS toEnum x = throw $ UnknownTrafficSelectorKind x +data SharedSecretType = SharedIKE + | SharedEAP + | SharedRSA + | SharedPIN + deriving (Eq, Show) + +instance Enum SharedSecretType where + fromEnum SharedIKE = 1 + fromEnum SharedEAP = 2 + fromEnum SharedRSA = 3 + fromEnum SharedPIN = 4 + toEnum 1 = SharedIKE + toEnum 2 = SharedEAP + toEnum 3 = SharedRSA + toEnum 4 = SharedPIN + toEnum x = throw $ UnknownSharedSecretType x + data IKEConfig = IKEConfig { _ikeId :: Maybe Int, _ikeReqCert :: Bool, @@ -453,36 +497,63 @@ c2tsTrafficSelectorKind :: TrafficSelectorKind } deriving Show +data SharedSecret = SharedSecret { + _ssId :: Maybe Int, + _ssType :: SharedSecretType, + _ssData :: ByteString + } deriving Show + +instance Default SharedSecret where + def = SharedSecret Nothing SharedIKE "" + +data SharedSecretIdentity = SharedSecretIdentity { + _sharedSecretId :: Int, + _identityId :: Int + } + data PreparedStatements = PreparedStatements { - updateChildSAStmt :: SQL.StmtID, - createChildSAStmt :: SQL.StmtID, - findChildSAStmt :: SQL.StmtID, - findChildSAByNameStmt :: SQL.StmtID, - deleteChildSAStmt :: SQL.StmtID, - updateIKEStmt :: SQL.StmtID, - createIKEStmt :: SQL.StmtID, - findIKEStmt :: SQL.StmtID, - deleteIKEStmt :: SQL.StmtID, - updatePeerStmt :: SQL.StmtID, - createPeerStmt :: SQL.StmtID, - findPeerStmt :: SQL.StmtID, - findPeerByNameStmt :: SQL.StmtID, - deletePeerStmt :: SQL.StmtID, - updateP2CStmt :: SQL.StmtID, - createP2CStmt :: SQL.StmtID, - findP2CStmt :: SQL.StmtID, - deleteP2CStmt :: SQL.StmtID, - updateTSStmt :: SQL.StmtID, - createTSStmt :: SQL.StmtID, - findTSStmt :: SQL.StmtID, - deleteTSStmt :: SQL.StmtID, - updateC2TSStmt :: SQL.StmtID, - createC2TSStmt :: SQL.StmtID, - findC2TSStmt :: SQL.StmtID, - deleteC2TSStmt :: SQL.StmtID, - createIPSecStmt :: SQL.StmtID, - findIPSecStmt :: SQL.StmtID, - deleteIPSecStmt :: SQL.StmtID + updateChildSAStmt :: SQL.StmtID, + createChildSAStmt :: SQL.StmtID, + findChildSAStmt :: SQL.StmtID, + findChildSAByNameStmt :: SQL.StmtID, + deleteChildSAStmt :: SQL.StmtID, + updateIKEStmt :: SQL.StmtID, + createIKEStmt :: SQL.StmtID, + findIKEStmt :: SQL.StmtID, + deleteIKEStmt :: SQL.StmtID, + updatePeerStmt :: SQL.StmtID, + createPeerStmt :: SQL.StmtID, + findPeerStmt :: SQL.StmtID, + findPeerByNameStmt :: SQL.StmtID, + deletePeerStmt :: SQL.StmtID, + updateP2CStmt :: SQL.StmtID, + createP2CStmt :: SQL.StmtID, + findP2CStmt :: SQL.StmtID, + deleteP2CStmt :: SQL.StmtID, + updateTSStmt :: SQL.StmtID, + createTSStmt :: SQL.StmtID, + findTSStmt :: SQL.StmtID, + deleteTSStmt :: SQL.StmtID, + updateC2TSStmt :: SQL.StmtID, + createC2TSStmt :: SQL.StmtID, + findC2TSStmt :: SQL.StmtID, + deleteC2TSStmt :: SQL.StmtID, + updateIdentityStmt :: SQL.StmtID, + createIdentityStmt :: SQL.StmtID, + findIdentityStmt :: SQL.StmtID, + findIdentityBySelfStmt :: SQL.StmtID, + deleteIdentityStmt :: SQL.StmtID, + updateSharedSecretStmt :: SQL.StmtID, + createSharedSecretStmt :: SQL.StmtID, + findSharedSecretStmt :: SQL.StmtID, + deleteSharedSecretStmt :: SQL.StmtID, + updateSSIdentityStmt :: SQL.StmtID, + createSSIdentityStmt :: SQL.StmtID, + findSSIdentityStmt :: SQL.StmtID, + deleteSSIdentityStmt :: SQL.StmtID, + createIPSecStmt :: SQL.StmtID, + findIPSecStmt :: SQL.StmtID, + deleteIPSecStmt :: SQL.StmtID } deriving Show -- | The managed IPsec configuration type encompasses a complete set of elements which are pushed and interlinked diff --git a/strongswan-sql.cabal b/strongswan-sql.cabal --- a/strongswan-sql.cabal +++ b/strongswan-sql.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: df70c57c8e5221e054346a59c78abfe9477cb3ae1e175f69d1def6b29fe3f9da +-- hash: 60f2148a71514af362ac55216959613c573fd36159eb6446d93d1a2bf439a397 name: strongswan-sql -version: 1.0.0.0 +version: 1.0.1.0 synopsis: Interface library for strongSwan SQL backend description: Interface library and companion CLI tool to configure strongSwan IPsec over MySQL backend category: Console, Library, Network APIs, SQL @@ -65,6 +65,7 @@ CLI.Commands CLI.Commands.ChildSA CLI.Commands.Common + CLI.Commands.Identity CLI.Commands.PeerCfg CLI.Commands.TrafficSelector hs-source-dirs: