diff --git a/app/CLI/Commands/Identity.hs b/app/CLI/Commands/Identity.hs --- a/app/CLI/Commands/Identity.hs +++ b/app/CLI/Commands/Identity.hs @@ -32,24 +32,34 @@ cfgSecret :: Lens' AppState Identity -> Lens' AppState Identity -> Commands () cfgSecret lensA lensB = - param "shared-secret" "" bytes setSecret >+ do - param "type" "" secretType' $ \sType -> do - db <- use dbContext + command "shared-secret" "Manipulate shared secrets for this connection" newLevel >+ do + param "add" "" bytes setSecret >+ do + param "type" "" secretType' $ \sType -> do + db <- use dbContext + ident1 <- use lensA + ident2 <- use lensB + str <- use secretStr + let secret = def { _ssData = str, _ssType = sType } + Result {..} <- lift $ writeSharedSecret secret db + let secret' = secret { _ssId = Just lastModifiedKey } + ident1' <- lift $ addSecret ident1 secret' db + ident2' <- lift $ addSecret ident2 secret' db + lensA .= ident1' + lensB .= ident2' + return NoAction + exitCmd + command "remove" "Delete all shared secrets from this connection" $ do + db <- use dbContext ident1 <- use lensA ident2 <- use lensB - str <- use secretStr - let secret = def { _ssData = str, _ssType = sType } - Result {..} <- lift $ writeSharedSecret secret db - let secret' = secret { _ssId = Just lastModifiedKey } - ident1' <- lift $ addSecret ident1 secret' db - ident2' <- lift $ addSecret ident2 secret' db - lensA .= ident1' - lensB .= ident2' + lift $ mapM_ (\t -> removeSecret ident1 t db) allTypes + lift $ mapM_ (\t -> removeSecret ident2 t db) allTypes return NoAction exitCmd where setSecret str = do secretStr .= str return NewLevel + allTypes = [minBound..maxBound] flushIdentity :: StateT AppState IO Action flushIdentity = do diff --git a/src/StrongSwan/SQL.hs b/src/StrongSwan/SQL.hs --- a/src/StrongSwan/SQL.hs +++ b/src/StrongSwan/SQL.hs @@ -24,6 +24,7 @@ module StrongSwan.SQL ( -- * Initialization mkContext, + rmContext, -- -- * Managed API -- | Since managing each configuration object per hand and establishing the relationships @@ -177,7 +178,7 @@ data Context_ = Context_ { conn_ :: MySQLConn, - prepared_ :: PreparedStatements + prepared_ :: PreparedStatements SQL.StmtID } data Settings = Settings { @@ -224,8 +225,15 @@ SQL.ciPassword = pack _dbPassword, SQL.ciCharset = fromIntegral $ fromEnum _dbCharSet } +-- | Destroy an SQL context previously created by 'mkContext' +rmContext :: (Failable m, MonadIO m) => Context -> m () +rmContext = withContext rmContext' + where rmContext' Context_ {..} = do + mapM_ (SQL.closeStmt conn_) prepared_ + SQL.close conn_ + retrieveRows :: (Failable m, MonadIO m, SQLRow a) - => (PreparedStatements -> SQL.StmtID) + => (PreparedStatements SQL.StmtID -> SQL.StmtID) -> [SQL.MySQLValue] -> Context -> m [a] @@ -443,9 +451,14 @@ 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 + secrets <- mapM (lookupSharedSecret' . _sharedSecretId) ssIdentities + let secrets' = catMaybes secrets + toDelete = catMaybes $ _ssId <$> filter ((sType ==) . _ssType) secrets' + ssIdentities' = case secrets' of + [] -> + ssIdentities + _ -> + filter (\ss2Id -> elem (_sharedSecretId ss2Id) toDelete) ssIdentities mapM_ deleteSharedSecret' toDelete mapM_ deleteSSIdentity' ssIdentities' @@ -697,8 +710,8 @@ 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 +lookupSharedSecret' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Maybe SharedSecret) +lookupSharedSecret' = flip lookupSharedSecret ?context deleteSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int) deleteSharedSecret iD = withContext deleteSS 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 @@ -12,7 +12,7 @@ import qualified Database.MySQL.Base as SQL -prepareStatements :: (Failable m, MonadIO m, MonadFail m) => SQL.MySQLConn -> m PreparedStatements +prepareStatements :: (Failable m, MonadIO m, MonadFail m) => SQL.MySQLConn -> m (PreparedStatements SQL.StmtID) prepareStatements conn = do let ?conn = conn [createChildSA, updateChildSA, findChildSA, deleteChildSA] <- 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 @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} @@ -379,6 +380,10 @@ toEnum 4 = SharedPIN toEnum x = throw $ UnknownSharedSecretType x +instance Bounded SharedSecretType where + minBound = SharedIKE + maxBound = SharedPIN + data IKEConfig = IKEConfig { _ikeId :: Maybe Int, _ikeReqCert :: Bool, @@ -505,7 +510,7 @@ _tsType = IPv4AddrRange, _tsProtocol = 0, _tsStartAddr = "0.0.0.0", - _tsEndAddr = "0.0.0.0", + _tsEndAddr = "255.255.255.255", _tsStartPort = 0, _tsEndPort = 65535 } @@ -530,50 +535,50 @@ _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, - 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 +data PreparedStatements a = PreparedStatements { + updateChildSAStmt :: a, + createChildSAStmt :: a, + findChildSAStmt :: a, + findChildSAByNameStmt :: a, + deleteChildSAStmt :: a, + updateIKEStmt :: a, + createIKEStmt :: a, + findIKEStmt :: a, + deleteIKEStmt :: a, + updatePeerStmt :: a, + createPeerStmt :: a, + findPeerStmt :: a, + findPeerByNameStmt :: a, + deletePeerStmt :: a, + updateP2CStmt :: a, + createP2CStmt :: a, + findP2CStmt :: a, + deleteP2CStmt :: a, + updateTSStmt :: a, + createTSStmt :: a, + findTSStmt :: a, + deleteTSStmt :: a, + updateC2TSStmt :: a, + createC2TSStmt :: a, + findC2TSStmt :: a, + deleteC2TSStmt :: a, + updateIdentityStmt :: a, + createIdentityStmt :: a, + findIdentityStmt :: a, + findIdentityBySelfStmt :: a, + deleteIdentityStmt :: a, + updateSharedSecretStmt :: a, + createSharedSecretStmt :: a, + findSharedSecretStmt :: a, + deleteSharedSecretStmt :: a, + updateSSIdentityStmt :: a, + createSSIdentityStmt :: a, + findSSIdentityStmt :: a, + deleteSSIdentityStmt :: a, + createIPSecStmt :: a, + findIPSecStmt :: a, + deleteIPSecStmt :: a + } deriving (Show, Functor, Foldable) -- | The managed IPsec configuration type encompasses a complete set of elements which are pushed and interlinked -- as necessary by the /Managed/ API (see above). Note that there are lenses available to facilitate accessing all 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: f8b1dcf53f685958f34e7efb6fbb4777882c2ac6a753432528f03d0f5a0a115d +-- hash: 49806ef952eb6d507dcea5453e717f840d0021c2cf7026d46d1ccffade207fe7 name: strongswan-sql -version: 1.2.2.0 +version: 1.3.0.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 @@ -45,7 +45,7 @@ , base >=4.7 && <5 , bytestring >=0.10 && <0.11 , data-default >=0.7 && <0.8 - , failable >=1.1 && <1.2 + , failable >=1.1 && <1.3 , haskeline >=0.7 && <0.8 , io-streams >=1.5 && <1.6 , iproute >=1.7 && <1.8 @@ -79,7 +79,7 @@ , base >=4.7 && <5 , bytestring >=0.10 && <0.11 , data-default >=0.7 && <0.8 - , failable >=1.1 && <1.2 + , failable >=1.1 && <1.3 , haskeline >=0.7 && <0.8 , io-streams >=1.5 && <1.6 , iproute >=1.7 && <1.8 @@ -109,7 +109,7 @@ , base >=4.7 && <5 , bytestring >=0.10 && <0.11 , data-default >=0.7 && <0.8 - , failable >=1.1 && <1.2 + , failable >=1.1 && <1.3 , haskeline >=0.7 && <0.8 , io-streams >=1.5 && <1.6 , iproute >=1.7 && <1.8