diff --git a/app/CLI/Commands.hs b/app/CLI/Commands.hs --- a/app/CLI/Commands.hs +++ b/app/CLI/Commands.hs @@ -34,28 +34,41 @@ cfgTrafficSelector getLocalTrafficSelector showTrafficSelector exitCmd + command "identity" "Configure an identity" setIdentityCfg >+ do + cfgIdentity identity + exitCmd exitCmd param "connection" "" string setConnection >+ do - cfgChildSA - cfgPeer - command "local-traffic-selector" "Configure local traffic selector" newLevel >+ do - cfgTrafficSelector getLocalTrafficSelector - command "show" "Display local traffic selector's parameters" $ + command "child-sa" "Configure child SA parameters" newLevel >+ do + cfgChildSA + exitCmd + command "peer" "Configure peer parameters" newLevel >+ do + cfgPeer + exitCmd + command "local" "Local endpoint configuration" newLevel >+ do + command "traffic-selector" "Configure local traffic selector" newLevel >+ do + cfgTrafficSelector getLocalTrafficSelector + command "show" "Display local traffic selector's parameters" $ showTrafficSelector' getLocalTrafficSelector + exitCmd + cfgIdentity (ipsecSettings . getLocalIdentity) exitCmd - command "remote-traffic-selector" "Configure remote traffic selector" newLevel >+ do - cfgTrafficSelector getRemoteTrafficSelector - command "show" "Display remote traffic selector's parameters" $ + command "remote" "Remote endpoint configuration" newLevel >+ do + command "traffic-selector" "Configure remote traffic selector" newLevel >+ do + cfgTrafficSelector getRemoteTrafficSelector + command "show" "Display remote traffic selector's parameters" $ showTrafficSelector' getRemoteTrafficSelector + exitCmd + cfgIdentity (ipsecSettings . getRemoteIdentity) exitCmd showConnection + cfgSecret (ipsecSettings . getLocalIdentity ) (ipsecSettings . getRemoteIdentity) command "remove" "Wipes out this connection from the DB" $ do db <- use dbContext ipsecCfg <- use ipsecSettings void . runMaybeT $ deleteIPSecSettings ipsecCfg db - return NoAction + return $ LevelUp 1 exitCmd - cfgIdentity where setConnection name = do db <- use dbContext result <- runMaybeT $ findIPSecSettings name db 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 @@ -1,14 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, RankNTypes #-} module CLI.Commands.Identity where -import Control.Lens ((.=), use) -import Control.Monad (void) +import Control.Lens (Lens', (.=), use) +import Control.Monad (void, when) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import CLI.Commands.Common import CLI.Types import Data.Default (def) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Control.Monad.State.Strict (StateT, lift) import StrongSwan.SQL import System.Console.StructuredCLI hiding (Commands) @@ -16,48 +16,71 @@ secretType' :: (Monad m) => Validator m SharedSecretType secretType' = return . fromName -cfgIdentity :: Commands () -cfgIdentity = +cfgIdentity :: Lens' AppState Identity -> Commands () +cfgIdentity lens = 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 + command "any" "Matches any ID" (setIdentity lens $ AnyID Nothing) >+ identityCmds lens + param "name" "" string (setIdentity lens . NameID Nothing) >+ identityCmds lens + param "ipv4" "" ipV4Address (setIdentity lens . IPv4AddrID Nothing) >+ identityCmds lens + param "ipv6" "" ipV6Address (setIdentity lens . IPv6AddrID Nothing) >+ identityCmds lens + command "exit" "Exit identity configuration" (return $ LevelUp 2) -cfgSecret :: Commands () -cfgSecret = +setIdentityCfg :: StateT AppState IO Action +setIdentityCfg = do + flush .= Just flushIdentity + return NewLevel + +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 - ident <- use identity + db <- use dbContext + ident1 <- use lensA + ident2 <- use lensB str <- use secretStr let secret = def { _ssData = str, _ssType = sType } - ident' <- lift $ addSecret ident secret db - identity .= ident' + 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 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 +flushIdentity :: StateT AppState IO Action +flushIdentity = do + db <- use dbContext + ident <- use identity + void . lift $ writeIdentity ident db + return NoAction + +setIdentity :: Lens' AppState Identity -> Identity -> StateT AppState IO Action +setIdentity lens ident = do + db <- use dbContext + result <- runMaybeT $ findIdentityBySelf ident db + lens .= fromMaybe ident result + when (isNothing result) newIdentity return NewLevel + where newIdentity = + void . runMaybeT $ do + fn <- MaybeT $ use flush + lift fn -removeIdent :: Commands () -removeIdent = +removeIdent :: Lens' AppState Identity -> Commands () +removeIdent lens = command "remove" "delete identity from DB and all associated secrets, etc" $ do db <- use dbContext - ident <- use identity + ident <- use lens void . runMaybeT $ removeIdentity ident db - return NoAction + lens .= def + return $ LevelUp 2 -identityCmds :: Commands () -identityCmds = do - removeIdent - cfgSecret - exitCmd +identityCmds :: Lens' AppState Identity -> Commands () +identityCmds lens = do + removeIdent lens + command "exit" "Exit identity configuration" (return $ LevelUp 3) + diff --git a/app/CLI/Commands/PeerCfg.hs b/app/CLI/Commands/PeerCfg.hs --- a/app/CLI/Commands/PeerCfg.hs +++ b/app/CLI/Commands/PeerCfg.hs @@ -63,19 +63,19 @@ cfgIKEConfigId :: Commands () cfgIKEConfigId = param "ike-config-id" "" integer $ \val -> do - ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= val + ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= Just val flushIt cfgLocalId :: Commands () cfgLocalId = - param "local-identity-id" "" string $ \str -> do - ipsecSettings . getPeerConfig . peerCfgLocalId .= str + param "local-identity-id" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgLocalId .= Just val flushIt cfgRemoteId :: Commands () cfgRemoteId = - param "remote-identity-id" "" string $ \str -> do - ipsecSettings . getPeerConfig . peerCfgRemoteId .= str + param "remote-identity-id" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgRemoteId .= Just val flushIt cfgCertPolicy :: Commands () @@ -209,8 +209,8 @@ putStrLn $ "=================================="; putStrLn $ "IKE version: " ++ show _peerCfgIKEVersion putStrLn $ "IKE config ID: " ++ show _peerCfgIKEConfigId - putStrLn $ "Local identity: " ++ unpack _peerCfgLocalId - putStrLn $ "Remote identity: " ++ unpack _peerCfgRemoteId + putStrLn $ "Local identity: " ++ show _peerCfgLocalId + putStrLn $ "Remote identity: " ++ show _peerCfgRemoteId putStrLn $ "Cert. policy: " ++ nameOf _peerCfgCertPolicy putStrLn $ "Unique Ids: " ++ nameOf _peerCfgUniqueIds putStrLn $ "Auth method: " ++ nameOf _peerCfgAuthMethod diff --git a/src/StrongSwan/SQL.hs b/src/StrongSwan/SQL.hs --- a/src/StrongSwan/SQL.hs +++ b/src/StrongSwan/SQL.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {- | Module: StrongSwan.SQL Description: Interface Library for strongSwan (My)SQL backend @@ -133,11 +134,11 @@ ) where import Control.Concurrent.MVar (MVar, newMVar, withMVar) -import Control.Lens ((^.), (.=), makeLenses, use) +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 (MonadTrans, StateT, execStateT, get, lift) +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) @@ -253,17 +254,25 @@ writeIPSecSettings' = do unlinkConfig - use getIKEConfig >>= inContext writeIKEConfig >>= setId (getIKEConfig . ikeId) + use getIKEConfig >>= lift . writeIKEConfig' >>= setId (getIKEConfig . ikeId) name <- use getIPSecCfgName ikeCfgId <- use (getIKEConfig . ikeId) - getPeerConfig . peerCfgIKEConfigId .= fromJust ikeCfgId + localIdent <- saveIdent getLocalIdentity + remoteIdent <- saveIdent getRemoteIdentity - 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) + 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 {..} <- @@ -274,11 +283,26 @@ ipsec ^. getPeerConfig . peerCfgId, ipsec ^. getIKEConfig . ikeId, ipsec ^. getLocalTrafficSelector . tsId, - ipsec ^. getRemoteTrafficSelector . 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' + -- | 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' @@ -290,18 +314,23 @@ 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 + 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 } + _getRemoteTrafficSelector = rTS, + _getLocalIdentity = localId, + _getRemoteIdentity = remoteId } mkIPSecSettings vs = failure $ SQLValuesMismatch ("IPSecSettings " ++ Text.unpack name) (show vs) sql2Int = fromInt . fromSQL @@ -320,31 +349,25 @@ addTrafficSelector childCfgId lTS LocalTS addTrafficSelector childCfgId rTS RemoteTS peerId <- MaybeT . use $ getPeerConfig . peerCfgId - lift $ inContext writePeer2ChildConfig Peer2ChildConfig { - p2cPeerCfgId = peerId, - p2cChildCfgId = childCfgId - } + writePeer2ChildConfig' Peer2ChildConfig {p2cPeerCfgId = peerId, p2cChildCfgId = childCfgId } where addTrafficSelector childId TrafficSelector {..} kind | isJust _tsId = - void . lift $ inContext writeChild2TSConfig + void $ 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 + void $ deleteChild2TSConfig' childCfgId + void $ deleteChildSAConfig' childCfgId peerId <- MaybeT . use $ getPeerConfig . peerCfgId - void . lift $ inContext (deletePeer2ChildConfig peerId) childCfgId - lift $ inContext deletePeerConfig peerId + void $ deletePeer2ChildConfig' peerId childCfgId + void $ deletePeerConfig' peerId use getLocalTrafficSelector >>= removeTrafficSelector use getRemoteTrafficSelector >>= removeTrafficSelector @@ -353,7 +376,7 @@ void . runMaybeT $ do ikeCfgId <- MaybeT . use $ getIKEConfig . ikeId - lift $ inContext deleteIKEConfig ikeCfgId + deleteIKEConfig' ikeCfgId void . lift . failableIO . withMVar ?context $ \Context_{prepared_ = PreparedStatements{..}, ..} -> @@ -367,7 +390,7 @@ where removeTrafficSelector sel = void . runMaybeT $ do tsCfgId <- MaybeT . return $ _tsId sel - lift $ inContext deleteTrafficSelector tsCfgId + 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. @@ -418,6 +441,9 @@ 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] @@ -426,33 +452,51 @@ 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 +deleteChildSAConfig iD = withContext deleteChildSAConfig'' + where deleteChildSAConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteChildSAStmt [toSQL $ toInt iD] return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int) +deleteChildSAConfig' = flip deleteChildSAConfig ?context + writeIKEConfig :: (Failable m, MonadIO m) => IKEConfig -> Context -> m (Result Int) writeIKEConfig cfg = withContext writeIKEConfig'' where writeIKEConfig'' context@Context_ { prepared_ = PreparedStatements {..}, ..} = writeRow context updateIKEStmt createIKEStmt _ikeId cfg +writeIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => IKEConfig -> m (Result Int) +writeIKEConfig' = flip writeIKEConfig ?context + findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig findIKEConfig iD context = justOne ("IKEConfig " <> Text.pack (show iD)) =<< retrieveRows findIKEStmt [toSQL $ toInt iD] context +findIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m IKEConfig +findIKEConfig' = flip findIKEConfig ?context + deleteIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int) -deleteIKEConfig iD = withContext deleteIKEConfig' - where deleteIKEConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do +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] @@ -461,46 +505,67 @@ 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 +deletePeerConfig iD = withContext deletePeerConfig'' + where deletePeerConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do ok@SQL.OK {..} <- SQL.executeStmt conn_ deletePeerStmt [toSQL $ toInt iD] return Result { lastModifiedKey = okLastInsertID, response = ok } +deletePeerConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int) +deletePeerConfig' = flip deletePeerConfig ?context + writePeer2ChildConfig :: (Failable m, MonadIO m) => Peer2ChildConfig -> Context -> m (Result (Int, Int)) writePeer2ChildConfig cfg@Peer2ChildConfig {..} = withContext writeP2CConfig where writeP2CConfig Context_ { prepared_ = PreparedStatements {..}, .. } = do ok@SQL.OK {..} <- SQL.executeStmt conn_ createP2CStmt $ toValues cfg return Result { lastModifiedKey = (p2cPeerCfgId, p2cChildCfgId), response = ok } +writePeer2ChildConfig' :: (Failable m, MonadIO m, ?context::Context) => Peer2ChildConfig -> m (Result (Int, Int)) +writePeer2ChildConfig' = flip writePeer2ChildConfig ?context + findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig findPeer2ChildConfig peerId childId context = justOne ("Peer2Child " <> Text.pack (show peerId) <> " - " <> Text.pack (show childId)) =<< retrieveRows findP2CStmt (toSQL.toInt <$> [peerId, childId]) context deletePeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Result (Int, Int)) -deletePeer2ChildConfig peerId childId = withContext deletePeer2ChildConfig' - where deletePeer2ChildConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do +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 +deleteTrafficSelector iD = withContext deleteTrafficSelector'' + where deleteTrafficSelector'' Context_ { prepared_ = PreparedStatements {..}, ..} = do ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteTSStmt [toSQL $ toInt iD] return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int) +deleteTrafficSelector' = flip deleteTrafficSelector ?context + findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector findTrafficSelector iD context = justOne ("TrafficSelector " <> Text.pack (show iD)) =<< retrieveRows findTSStmt [toSQL $ toInt iD] context +findTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m TrafficSelector +findTrafficSelector' = flip findTrafficSelector ?context + writeChild2TSConfig :: (Failable m, MonadIO m) => Child2TSConfig -> Context -> m (Result (Int, Int)) writeChild2TSConfig cfg@Child2TSConfig {..} = withContext writeChild2TSConfig'' where writeChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, .. } = do @@ -513,24 +578,36 @@ 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 +deleteChild2TSConfig iD = withContext deleteChild2TSConfig'' + where deleteChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteC2TSStmt [toSQL $ toInt iD] return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteChild2TSConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int) +deleteChild2TSConfig' = flip deleteChild2TSConfig ?context + writeIdentity :: (Failable m, MonadIO m) => Identity -> Context -> m (Result Int) writeIdentity identity = withContext writeIdentity'' where writeIdentity'' context@Context_ { prepared_ = PreparedStatements {..}, ..} = writeRow context updateIdentityStmt createIdentityStmt getIdentityId identity +writeIdentity' :: (Failable m, MonadIO m, ?context::Context) => Identity -> m (Result Int) +writeIdentity' = flip writeIdentity ?context + findIdentity :: (Failable m, MonadIO m) => Int -> Context -> m Identity findIdentity iD context = justOne ("findIdentity" <> Text.pack (show iD)) =<< retrieveRows findIdentityStmt [toSQL $ toInt iD] context + +findIdentity' :: (Failable m, MonadIO m, ?context::Context ) => Int -> m Identity +findIdentity' = flip findIdentity ?context findIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m Identity findIdentityBySelf identity context = 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 @@ -1,20 +1,25 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} module StrongSwan.SQL.Encoding where import Control.Exception (throw) +import Control.Lens (over, each) import Data.ASN1.BinaryEncoding (DER(..)) import Data.ASN1.Encoding (encodeASN1', decodeASN1') import Data.Bifunctor (second) import Data.ByteString.Char8 (ByteString, unpack) import Data.Maybe (fromJust) +import Data.Text (Text) import Data.Word (Word8) import Numeric (showHex) import StrongSwan.SQL.Types +import Text.Read (readMaybe) import qualified Data.ByteString as B +import qualified Data.Text as T import qualified Database.MySQL.Base as SQL class SQLRow a where @@ -58,10 +63,10 @@ fromId = return . fromInt . fromSQL instance SQLRow Identity where - toValues (AnyID _) = [toSQL $ toTinyInt (0::Word8), toSQL $ toVarBinary "%any"] + toValues (AnyID _) = [toSQL $ toTinyInt (0::Word8), toSQL $ toVarBinary ("%any" :: String)] 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 (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] @@ -74,8 +79,8 @@ 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 +parseEmail :: ByteString -> (Text, Text) +parseEmail str = over each T.pack . second (drop 1) $ span (/= '@') $ unpack str instance SQLRow IKEConfig where toValues IKEConfig {..} = [ @@ -142,13 +147,19 @@ } fromValues xs = throw $ SQLValuesMismatch "ChildSAConfig" (show xs) +iDToVarChar :: Maybe Int -> SQL.MySQLValue +iDToVarChar = toSQL . toVarChar . (>>= return . T.pack . show) + +varCharToId :: SQL.MySQLValue -> Maybe Int +varCharToId = (readMaybe . T.unpack =<<) . fromVarChar . fromSQL + instance SQLRow PeerConfig where toValues PeerConfig {..} = [ toSQL . toVarChar $ Just _peerCfgName, toSQL $ toTinyInt _peerCfgIKEVersion, - toSQL $ toInt _peerCfgIKEConfigId, - toSQL . toVarChar $ Just _peerCfgLocalId, - toSQL . toVarChar $ Just _peerCfgRemoteId, + toSQL . toInt $ fromJust _peerCfgIKEConfigId, + iDToVarChar _peerCfgLocalId, + iDToVarChar _peerCfgRemoteId, toSQL $ toTinyInt _peerCfgCertPolicy, toSQL $ toTinyInt _peerCfgUniqueIds, toSQL $ toTinyInt _peerCfgAuthMethod, @@ -193,9 +204,9 @@ _peerCfgId = return . fromInt $ fromSQL iD, _peerCfgName = fromJust . fromVarChar $ fromSQL name, _peerCfgIKEVersion = fromTinyInt $ fromSQL ikeVersion, - _peerCfgIKEConfigId = fromInt $ fromSQL ikeConfig, - _peerCfgLocalId = fromJust . fromVarChar $ fromSQL localId, - _peerCfgRemoteId = fromJust . fromVarChar $ fromSQL remoteId, + _peerCfgIKEConfigId = return . fromInt $ fromSQL ikeConfig, + _peerCfgLocalId = varCharToId localId, + _peerCfgRemoteId = varCharToId remoteId, _peerCfgCertPolicy = fromTinyInt $ fromSQL certPolicy, _peerCfgUniqueIds = fromTinyInt $ fromSQL uniqueIds, _peerCfgAuthMethod = fromTinyInt $ fromSQL authMethod, 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 @@ -282,17 +282,16 @@ 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;" +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, `local_id` int(10) unsigned NOT NULL, `remote_id` int(10) unsigned NOT NULL, PRIMARY KEY (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" createIPSecStatement :: SQL.Query -createIPSecStatement = "INSERT INTO ipsec_configs (name, child_cfg, peer_cfg, ike_cfg, local_ts, remote_ts) VALUES (?, ?, ?, ?, ?, ?);" +createIPSecStatement = "INSERT INTO ipsec_configs (name, child_cfg, peer_cfg, ike_cfg, local_ts, remote_ts, local_id, remote_id) VALUES (?, ?, ?, ?, ?, ?, ?, ?);" findIPSecStatement :: SQL.Query findIPSecStatement = "SELECT * FROM ipsec_configs WHERE name = ?;" deleteIPSecStatement :: SQL.Query deleteIPSecStatement = "DELETE FROM ipsec_configs WHERE name = ?;" - initializeWith :: (Failable m, MonadIO m, ?conn::SQL.MySQLConn) => SQL.Query 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 @@ -19,6 +19,7 @@ import Network.Socket (PortNumber) import qualified Data.ByteString as B +import qualified Data.Text as T import qualified Database.MySQL.Base as SQL data Error = UnknownCharacterEncoding Int @@ -69,12 +70,12 @@ 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/ + | NameID (Maybe Int) Text -- Fully qualified Domain Name + | EmailID (Maybe Int) Text Text -- ^ 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 + deriving (Eq, Show) getIdentityId :: Identity -> Maybe Int getIdentityId (AnyID iD) = iD @@ -196,6 +197,10 @@ toVarBinary = VarBinary . pack fromVarBinary (VarBinary bytes) = unpack bytes +instance VarBinary Text where + toVarBinary = VarBinary . pack . T.unpack + fromVarBinary (VarBinary bytes) = T.pack $ unpack bytes + instance VarBinary ByteString where toVarBinary = VarBinary fromVarBinary (VarBinary bytes) = bytes @@ -416,9 +421,9 @@ _peerCfgId :: Maybe Int, _peerCfgName :: Text, _peerCfgIKEVersion :: Word8, - _peerCfgIKEConfigId :: Int, - _peerCfgLocalId :: Text, - _peerCfgRemoteId :: Text, + _peerCfgIKEConfigId :: Maybe Int, + _peerCfgLocalId :: Maybe Int, + _peerCfgRemoteId :: Maybe Int, _peerCfgCertPolicy :: CertPolicy, _peerCfgUniqueIds :: Bool, _peerCfgAuthMethod :: AuthMethod, @@ -443,9 +448,9 @@ _peerCfgId = Nothing, _peerCfgName = "", _peerCfgIKEVersion = 2, - _peerCfgIKEConfigId = maxBound, - _peerCfgLocalId = "%any", - _peerCfgRemoteId = "%any", + _peerCfgIKEConfigId = Nothing, + _peerCfgLocalId = Nothing, + _peerCfgRemoteId = Nothing, _peerCfgCertPolicy = SendIfAsked, _peerCfgUniqueIds = True, _peerCfgAuthMethod = PubKey, @@ -565,9 +570,10 @@ _getChildSAConfig :: ChildSAConfig, _getPeerConfig :: PeerConfig, _getLocalTrafficSelector :: TrafficSelector, - _getRemoteTrafficSelector :: TrafficSelector + _getRemoteTrafficSelector :: TrafficSelector, + _getLocalIdentity :: Identity, + _getRemoteIdentity :: Identity } deriving (Eq, Show) - instance Default IPSecSettings where - def = IPSecSettings "" def def def def def + def = IPSecSettings "" def def def def def def def 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: 60f2148a71514af362ac55216959613c573fd36159eb6446d93d1a2bf439a397 +-- hash: 8e901b023b4ac4274a0d123daf925a7dbcda18addb33e2bf88f710374ce1813d name: strongswan-sql -version: 1.0.1.0 +version: 1.1.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