diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for strongswan-sql + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +# strongswan-sql +#### Configuration of StrongSwan SQL backend + +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. + +* 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. + +* 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/CLI/Commands.hs b/app/CLI/Commands.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleContexts #-} + +module CLI.Commands where + +import CLI.Commands.ChildSA +import CLI.Commands.Common +import CLI.Commands.PeerCfg +import CLI.Commands.TrafficSelector +import CLI.Types +import Control.Lens ((&), (.=), (.~), use) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (runMaybeT) +import Control.Monad.State.Strict (StateT, lift) +import Data.Default (def) +import Data.Maybe (fromMaybe) +import Data.Text (unpack) +import System.Console.StructuredCLI hiding (Commands) +import StrongSwan.SQL + +commands :: Commands () +commands = do + command "advanced" "Configure individual elements manually" newLevel >+ do + param "child-sa" "" string setChildSA >+ do + cfgChildSA + showChildSA + exitCmd + param "peer-cfg" "" string setPeerCfg >+ do + cfgPeer + showPeer + exitCmd + param "traffic-selector" "" parseTSId setTrafficSelector >+ do + cfgTrafficSelector getLocalTrafficSelector + showTrafficSelector + 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" $ + showTrafficSelector' getLocalTrafficSelector + exitCmd + command "remote-traffic-selector" "Configure remote traffic selector" newLevel >+ do + cfgTrafficSelector getRemoteTrafficSelector + command "show" "Display remote traffic selector's parameters" $ + showTrafficSelector' getRemoteTrafficSelector + exitCmd + showConnection + exitCmd + where setConnection name = do + db <- use dbContext + result <- runMaybeT $ findIPSecSettings name db + let ipsec = fromMaybe def result + ipsecSettings .= (ipsec & getIPSecCfgName .~ name) + flush .= Just flushConnection + return NewLevel + +flushConnection :: StateT AppState IO Action +flushConnection = do + ipsecCfg <- use ipsecSettings + db <- use dbContext + ipsec' <- lift $ writeIPSecSettings ipsecCfg db + ipsecSettings .= ipsec' + return NoAction + +showConnection :: Commands () +showConnection = + command "show" "display connection parameters" $ do + name <- use $ ipsecSettings . getIPSecCfgName + liftIO . putStrLn $ "IPSec connection - \'" ++ unpack name ++ "'" + void showChildSA' + void $ showPeer' + liftIO $ putStr "Local " + void $ showTrafficSelector' getLocalTrafficSelector + liftIO $ putStr "Remote " + showTrafficSelector' getRemoteTrafficSelector + + + diff --git a/app/CLI/Commands/ChildSA.hs b/app/CLI/Commands/ChildSA.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands/ChildSA.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +module CLI.Commands.ChildSA where + +import Control.Lens ((.=)) +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import CLI.Commands.Common +import CLI.Types +import Data.Default (def) +import Data.Maybe (fromMaybe) +import Data.Text (Text,unpack) +import Control.Monad.State.Strict (StateT, get, lift) +import StrongSwan.SQL +import System.Console.StructuredCLI hiding (Commands) + +saAction :: (Monad m) => Validator m SAAction +saAction = return . fromName + +saMode :: (Monad m) => Validator m SAMode +saMode = return . fromName + +cfgChildSA :: Commands () +cfgChildSA = do + cfgLifeTime + cfgRekeyTime + cfgJitter + cfgUpDown + cfgHostAccess + cfgSAMode + cfgStartAction + cfgDPDAction + cfgCloseAction + cfgIPCompression + cfgReqID + +setChildSA :: Text -> StateT AppState IO Action +setChildSA name = do + childSA <- setConfig findChildSAConfigByName def { _childSAName = name } name + ipsecSettings . getChildSAConfig .= childSA + flush .= Just flushChildSA + return NewLevel + +showChildSA :: Commands () +showChildSA = + command "show" "Show this child SA configuration" showChildSA' + +showChildSA' :: StateT AppState IO Action +showChildSA' = do + AppState{_ipsecSettings = IPSecSettings{_getChildSAConfig=ChildSAConfig{..}}} <- get + let iD = _childSAId >>= return . show + liftIO $ do + putStr "Child SA " + when (_childSAName /= "") $ putStr $ '\'':unpack _childSAName ++ "\' " + putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")" + putStrLn $ "=================================="; + putStrLn $ "Lifetime: " ++ show _childSALifeTime + putStrLn $ "Rekeytime: " ++ show _childSARekeyTime + putStrLn $ "Jitter: " ++ show _childSAJitter + putStrLn $ "UpDown: " ++ maybe "" unpack _childSAUpDown + putStrLn $ "HostAccess: " ++ showEnabled _childSAHostAccess + putStrLn $ "SA Mode: " ++ nameOf _childSAMode + putStrLn $ "Start Action: " ++ nameOf _childSAStartAction + putStrLn $ "DPD Action: " ++ nameOf _childSADPDAction + putStrLn $ "Close Action: " ++ nameOf _childSACloseAction + putStrLn $ "IP compression: " ++ showEnabled _childSAIPCompression + putStrLn $ "Request ID: " ++ show _childSAReqID + return NoAction + +cfgLifeTime :: Commands () +cfgLifeTime = + param "lifetime" "" integer $ \lifetime -> do + ipsecSettings . getChildSAConfig . childSALifeTime .= lifetime + flushIt + +cfgRekeyTime :: Commands () +cfgRekeyTime = + param "rekeytime" "" integer $ \timeout -> do + ipsecSettings . getChildSAConfig . childSARekeyTime .= timeout + flushIt + +cfgJitter :: Commands () +cfgJitter = + param "jitter" "" integer $ \jitter -> do + ipsecSettings . getChildSAConfig . childSAJitter .= jitter + flushIt + +cfgUpDown :: Commands () +cfgUpDown = + param "updown-script" "" string $ \script -> do + ipsecSettings . getChildSAConfig . childSAUpDown .= Just script + flushIt + +cfgSAMode :: Commands () +cfgSAMode = + param "mode" "" saMode $ \mode -> do + ipsecSettings . getChildSAConfig . childSAMode .= mode + flushIt + +cfgHostAccess :: Commands () +cfgHostAccess = + param "host-access" "" readEnabled $ \status -> do + ipsecSettings . getChildSAConfig . childSAHostAccess .= status + flushIt + +cfgStartAction :: Commands () +cfgStartAction = + param "start-action" "" saAction $ \action -> do + ipsecSettings . getChildSAConfig . childSAStartAction .= action + flushIt + +cfgDPDAction :: Commands () +cfgDPDAction = + param "dpd-action" "" saAction $ \action -> do + ipsecSettings . getChildSAConfig . childSADPDAction .= action + flushIt + +cfgCloseAction :: Commands () +cfgCloseAction = + param "close-action" "" saAction $ \action -> do + ipsecSettings . getChildSAConfig . childSACloseAction .= action + flushIt + +cfgIPCompression :: Commands () +cfgIPCompression = + param "ip-compression" "" readEnabled $ \status -> do + ipsecSettings . getChildSAConfig . childSAIPCompression .= status + flushIt + +cfgReqID :: Commands () +cfgReqID = + param "req-id" "" integer $ \reqID -> do + ipsecSettings . getChildSAConfig . childSAReqID .= reqID + flushIt + +flushChildSA :: StateT AppState IO Action +flushChildSA = do + AppState{_ipsecSettings = IPSecSettings{_getChildSAConfig=childSA@ChildSAConfig{..}}, ..} <- get + Result {response = OK {..}} <- lift $ writeChildSAConfig childSA _dbContext + when (okAffectedRows /= 1 ) $ + liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)" + void . runMaybeT $ do + childSA':xs <- findChildSAConfigByName _childSAName _dbContext + when (xs /= []) $ + liftIO . putStrLn $ + "Warning: more than one child SA config named " ++ unpack _childSAName ++ " found" + lift $ ipsecSettings . getChildSAConfig .= childSA' + return NoAction diff --git a/app/CLI/Commands/Common.hs b/app/CLI/Commands/Common.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands/Common.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TypeApplications #-} + +module CLI.Commands.Common where + +import CLI.Types +import Control.Lens (use) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.State.Strict (StateT, lift) +import Data.Bool (bool) +import Data.IP (IP) +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 + +string :: (Monad m) => String -> m (Maybe Text) +string = return . Just . 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 + +boolean :: (Monad m) => String -> String -> String -> m (Maybe Bool) +boolean yes no str | str == yes = return $ Just True + | str == no = return $ Just False + | otherwise = return Nothing + +oneOf :: (Monad m) => [(String, a)] -> String -> m (Maybe a) +oneOf opts str = runMaybeT $ do + (_, x) <- MaybeT . return $ find ((str == ) . fst) opts + return x + +exitCmd :: Commands () +exitCmd = command "exit" "Go back one level" exit + +showEnabled :: Bool -> String +showEnabled = bool "disabled" "enabled" + +readEnabled :: (Monad m) => String -> m (Maybe Bool) +readEnabled = boolean "enabled" "disabled" + +readBool :: (Monad m) => String -> m (Maybe Bool) +readBool = return . fromName + +flushIt :: StateT AppState IO Action +flushIt = do + result <- runMaybeT $ do + f <- MaybeT $ use flush + lift f + maybe (return NoAction) return result + +setConfig :: (SQLRow a, Eq a, Show k) + => (k -> SQL.Context -> IO [a]) -> a -> k -> StateT AppState IO a +setConfig getFn def' key = do + db <- use dbContext + result <- liftIO $ getFn key db + case result of + [] -> + return def' + x:xs -> do + when (xs /= []) $ + liftIO . putStrLn $ "Warning: multiple config named " ++ show key ++ " found" + return x diff --git a/app/CLI/Commands/PeerCfg.hs b/app/CLI/Commands/PeerCfg.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands/PeerCfg.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} +module CLI.Commands.PeerCfg where + +import Control.Lens ((.=)) +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import CLI.Commands.Common +import CLI.Types +import Data.Default (def) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, unpack) +import Control.Monad.State.Strict (StateT, get, lift) +import StrongSwan.SQL +import System.Console.StructuredCLI hiding (Commands) + +certPolicy :: (Monad m) => Validator m CertPolicy +certPolicy = return . fromName + +authMethod :: (Monad m) => Validator m AuthMethod +authMethod = return . fromName + +eapType :: (Monad m) => Validator m EAPType +eapType = return . fromName + +cfgPeer :: Commands () +cfgPeer = do + cfgIKEVersion + cfgIKEConfigId + cfgLocalId + cfgRemoteId + cfgCertPolicy + cfgUniqueIds + cfgAuthMethod + cfgEAPType + cfgEAPVendor + cfgKeyingTries + cfgRekeyTime + cfgReauthTime + cfgJitter + cfgOverTime + cfgMobike + cfgDPDDelay + cfgVirtual + cfgPool + cfgMediation + cfgMediatedBy + cfgPeerId + +setPeerCfg :: Text -> StateT AppState IO Action +setPeerCfg name = do + peerCfg <- setConfig findPeerConfigByName def { _peerCfgName = name} name + ipsecSettings . getPeerConfig .= peerCfg + flush .= Just flushPeerCfg + return NewLevel + +cfgIKEVersion :: Commands () +cfgIKEVersion = + param "ike-version" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgIKEVersion .= val + flushIt + +cfgIKEConfigId :: Commands () +cfgIKEConfigId = + param "ike-config-id" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= val + flushIt + +cfgLocalId :: Commands () +cfgLocalId = + param "local-identity-id" "" string $ \str -> do + ipsecSettings . getPeerConfig . peerCfgLocalId .= str + flushIt + +cfgRemoteId :: Commands () +cfgRemoteId = + param "remote-identity-id" "" string $ \str -> do + ipsecSettings . getPeerConfig . peerCfgRemoteId .= str + flushIt + +cfgCertPolicy :: Commands () +cfgCertPolicy = + param "cert-policy" " do + ipsecSettings . getPeerConfig . peerCfgCertPolicy .= policy + flushIt + +cfgUniqueIds :: Commands () +cfgUniqueIds = + param "unique-ids" "" readBool $ \val -> do + ipsecSettings . getPeerConfig . peerCfgUniqueIds .= val + flushIt + +cfgAuthMethod :: Commands () +cfgAuthMethod = + param "auth-method" "" authMethod $ \method -> do + ipsecSettings . getPeerConfig . peerCfgAuthMethod .= method + flushIt + +cfgEAPType :: Commands () +cfgEAPType = + param "eap-type" "" eapType $ \t -> do + ipsecSettings . getPeerConfig . peerCfgEAPType .= t + flushIt + +cfgEAPVendor :: Commands () +cfgEAPVendor = + param "eap-vendor" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgEAPVendor .= val + flushIt + +cfgKeyingTries :: Commands () +cfgKeyingTries = + param "keying-tries" " do + ipsecSettings . getPeerConfig . peerCfgKeyingTries .= val + flushIt + +cfgRekeyTime :: Commands () +cfgRekeyTime = + param "rekey-timeout" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgRekeyTime .= val + flushIt + +cfgReauthTime :: Commands () +cfgReauthTime = + param "reauth-timeout" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgReauthTime .= val + flushIt + +cfgJitter :: Commands () +cfgJitter = + param "jitter" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgJitter .= val + flushIt + +cfgOverTime :: Commands () +cfgOverTime = + param "overtime" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgOverTime .= val + flushIt + +cfgMobike :: Commands () +cfgMobike = + param "mobike" "" readEnabled $ \val -> do + ipsecSettings . getPeerConfig . peerCfgMobike .= val + flushIt + +cfgDPDDelay :: Commands () +cfgDPDDelay = + param "dpd-delay" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgDPDDelay .= val + flushIt + +cfgVirtual :: Commands () +cfgVirtual = + param "virtual-ip" "" ipAddress $ \addr -> do + ipsecSettings . getPeerConfig . peerCfgVirtual .= (return . pack $ show addr) + flushIt + +cfgPool :: Commands () +cfgPool = + param "addr-pool" "" string $ \name -> do + ipsecSettings . getPeerConfig . peerCfgPool .= return name + flushIt + +cfgMediation :: Commands () +cfgMediation = + param "mediaton" "" readEnabled $ \val -> do + ipsecSettings . getPeerConfig . peerCfgMediation .= val + flushIt + +cfgMediatedBy :: Commands () +cfgMediatedBy = + param "mediated-by" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgMediatedBy .= val + flushIt + +cfgPeerId :: Commands () +cfgPeerId = + param "peer-id" "" integer $ \val -> do + ipsecSettings . getPeerConfig . peerCfgPeerId .= val + flushIt + +flushPeerCfg :: StateT AppState IO Action +flushPeerCfg = do + AppState{_ipsecSettings = IPSecSettings{_getPeerConfig=peer@PeerConfig{..}}, ..} <- get + Result {response = OK {..}} <- lift $ writePeerConfig peer _dbContext + when (okAffectedRows /= 1 ) $ + liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)" + void . runMaybeT $ do + peerCfg:xs <- findPeerConfigByName _peerCfgName _dbContext + when (xs /= []) $ + liftIO . putStrLn $ + "Warning: more than one peer config named " ++ unpack _peerCfgName ++ " found" + lift $ ipsecSettings . getPeerConfig .= peerCfg + return NoAction + +showPeer :: Commands () +showPeer = + command "show" "Show this peer configuration" showPeer' + +showPeer' :: StateT AppState IO Action +showPeer' = do + AppState{_ipsecSettings = IPSecSettings{_getPeerConfig=PeerConfig{..}}} <- get + let iD = _peerCfgId >>= return . show + liftIO $ do + putStr "Peer Config " + when (_peerCfgName /= "") $ putStr $ '\'': unpack _peerCfgName ++ "' " + putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")" + putStrLn $ "=================================="; + putStrLn $ "IKE version: " ++ show _peerCfgIKEVersion + putStrLn $ "IKE config ID: " ++ show _peerCfgIKEConfigId + putStrLn $ "Local identity: " ++ unpack _peerCfgLocalId + putStrLn $ "Remote identity: " ++ unpack _peerCfgRemoteId + putStrLn $ "Cert. policy: " ++ nameOf _peerCfgCertPolicy + putStrLn $ "Unique Ids: " ++ nameOf _peerCfgUniqueIds + putStrLn $ "Auth method: " ++ nameOf _peerCfgAuthMethod + putStrLn $ "EAP type: " ++ nameOf _peerCfgEAPType + putStrLn $ "EAP vendor: " ++ show _peerCfgEAPVendor + putStrLn $ "Keying tries: " ++ show _peerCfgKeyingTries + putStrLn $ "Rekey timeout: " ++ show _peerCfgRekeyTime ++ " secs" + putStrLn $ "Reauth timeout: " ++ show _peerCfgReauthTime ++ " secs" + putStrLn $ "Jitter: " ++ show _peerCfgJitter ++ " secs" + putStrLn $ "Overtime: " ++ show _peerCfgOverTime ++ " secs" + putStrLn $ "MobIKE: " ++ showEnabled _peerCfgMobike + putStrLn $ "DPD delay: " ++ show _peerCfgDPDDelay ++ " secs" + putStrLn $ "Virtual IP: " ++ maybe "" unpack _peerCfgVirtual + putStrLn $ "Address pool: " ++ maybe "" unpack _peerCfgPool + putStrLn $ "Mediation: " ++ showEnabled _peerCfgMediation + putStrLn $ "Mediated by: " ++ show _peerCfgMediatedBy + putStrLn $ "Peer ID: " ++ show _peerCfgPeerId + return NoAction diff --git a/app/CLI/Commands/TrafficSelector.hs b/app/CLI/Commands/TrafficSelector.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Commands/TrafficSelector.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module CLI.Commands.TrafficSelector where + +import Control.Lens (Lens', (.=), use) +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +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, get, lift) +import StrongSwan.SQL +import System.Console.StructuredCLI hiding (Commands) +import Text.Read (readMaybe) + +trafficSelectorType :: (Monad m) => Validator m TrafficSelectorType +trafficSelectorType = return . fromName + +parseTSId :: (Monad m) => Validator m (Maybe Int) +parseTSId "new" = return $ Just Nothing +parseTSId str = return $ Just <$> readMaybe str + +cfgTrafficSelector :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTrafficSelector lens = do + cfgTSType lens + cfgTSProtocol lens + cfgTSStartAddr lens + cfgTSEndAddr lens + cfgTSStartPort lens + cfgTSEndPort lens + +setTrafficSelector :: Maybe Int -> StateT AppState IO Action +setTrafficSelector mId = do + ts <- case mId of + Nothing -> + return def + Just iD -> do + db <- use dbContext + liftIO $ findTrafficSelector iD db + ipsecSettings . getLocalTrafficSelector .= ts + flush .= Just flushTrafficSelector + return NewLevel + +showTrafficSelector :: Commands () +showTrafficSelector = + command "show" "Display this traffic selector's parameters" $ + showTrafficSelector' getLocalTrafficSelector + +showTrafficSelector' :: Lens' IPSecSettings TrafficSelector -> StateT AppState IO Action +showTrafficSelector' lens = do + TrafficSelector {..} <- use $ ipsecSettings . lens + let iD = _tsId >>= return . show + liftIO $ do + putStr "Traffic Selector " + putStrLn $ "(ID: " ++ fromMaybe "*uncommitted*" iD ++ ")" + putStrLn $ "=================================="; + putStrLn $ "Type: " ++ nameOf _tsType + putStrLn $ "Protocol: " ++ show _tsProtocol + putStrLn $ "Start address: " ++ show _tsStartAddr + putStrLn $ "End address: " ++ show _tsEndAddr + putStrLn $ "Start port: " ++ show _tsStartPort + putStrLn $ "End port: " ++ show _tsEndPort + return NoAction + +cfgTSType :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSType lens = + param "type" "" trafficSelectorType $ \t -> do + ipsecSettings . lens . tsType .= t + flushIt + +cfgTSProtocol :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSProtocol lens = + param "protocol" "" integer $ \val -> do + ipsecSettings . lens . tsProtocol .= val + flushIt + +cfgTSStartAddr :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSStartAddr lens = + param "start-address" "" ipAddress $ \addr -> do + ipsecSettings . lens .tsStartAddr .= addr + flushIt + +cfgTSEndAddr :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSEndAddr lens = + param "end-address" "" ipAddress $ \addr -> do + ipsecSettings . lens . tsEndAddr .= addr + flushIt + +cfgTSStartPort :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSStartPort lens = + param "start-port" "" integer $ \port -> do + ipsecSettings . lens . tsStartPort .= port + flushIt + +cfgTSEndPort :: Lens' IPSecSettings TrafficSelector -> Commands () +cfgTSEndPort lens = + param "end-port" "" integer $ \port -> do + ipsecSettings . lens . tsEndPort .= port + flushIt + +flushTrafficSelector :: StateT AppState IO Action +flushTrafficSelector = do + AppState{_ipsecSettings = IPSecSettings{_getLocalTrafficSelector=ts@TrafficSelector{..}}, ..} <- get + Result {response = OK {..}, ..} <- lift $ writeTrafficSelector ts _dbContext + when (okAffectedRows /= 1 ) $ + liftIO . putStrLn $ "(1) warning: affected " ++ show okAffectedRows ++ " (expected 1)" + db <- use dbContext + void . runMaybeT $ do + ts' <- findTrafficSelector lastModifiedKey db + lift $ ipsecSettings . getLocalTrafficSelector .= ts' + return NoAction diff --git a/app/CLI/Types.hs b/app/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/app/CLI/Types.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module CLI.Types where + +import Control.Lens (makeLenses) +import Control.Monad.Failable (Failable(..)) +import Control.Monad.State.Strict (StateT) +import Control.Exception (Exception) +import Data.Char (toLower) +import Data.Default +import Data.Text (Text) +import Data.Typeable (Typeable) +import System.Console.StructuredCLI + +import qualified Data.Attoparsec.Text as A +import qualified StrongSwan.SQL as SQL + +data Error = BadArguments String + | FatalError CLIException + | InvalidValue String + deriving (Typeable, Show) + +instance Exception Error + +data Options = Options { + _settings :: SQL.Settings, + _askPassword :: Bool, + _requestedHelp :: Bool, + _badInput :: Text + } deriving Show + +makeLenses ''Options + +data AppState = AppState { + _options :: Options, + _dbContext :: SQL.Context, + _ipsecSettings :: SQL.IPSecSettings, + _flush :: Maybe (StateT AppState IO Action) + } + +makeLenses ''AppState + +instance Default Options where + def = Options { _settings = def, + _askPassword = False, + _requestedHelp = False, + _badInput = "" } + +type Commands = CommandsT (StateT AppState IO) +type ArgsParser = StateT Options A.Parser + +class Nameable a where + nameOf :: a -> String + fromName :: (Failable m) => String -> m a + +instance Nameable Bool where + nameOf True = "true" + nameOf False = "false" + fromName "true" = return True + fromName "false" = return False + fromName str = failure $ InvalidValue str + +instance Nameable SQL.CertPolicy where + nameOf SQL.AlwaysSend = "always-send" + nameOf SQL.SendIfAsked = "send-if-asked" + nameOf SQL.NeverSend = "never-send" + fromName "always-send" = return SQL.AlwaysSend + fromName "send-if-asked" = return SQL.SendIfAsked + fromName "never-send " = return SQL.NeverSend + fromName str = failure $ InvalidValue str + +instance Nameable SQL.SAAction where + nameOf = fmap toLower . show + fromName "none" = return SQL.None + fromName "route" = return SQL.Route + fromName "restart" = return SQL.Restart + fromName str = failure $ InvalidValue str + + +instance Nameable SQL.SAMode where + nameOf = fmap toLower . show + fromName "tunnel" = return SQL.Tunnel + fromName "transport" = return SQL.Transport + fromName "beet" = return SQL.Beet + fromName "pass" = return SQL.Pass + fromName "drop" = return SQL.Drop + fromName str = failure $ InvalidValue str + +instance Nameable SQL.EAPType where + nameOf SQL.EAPMD5 = "md5" + nameOf SQL.EAPGTC = "gtc" + nameOf SQL.EAPTLS = "tls" + nameOf SQL.EAPSIM = "sim" + nameOf SQL.EAPTTLS = "ttls" + nameOf SQL.EAPAKA = "aka" + nameOf SQL.EAPMSCHAPV2 = "mschapv2" + nameOf SQL.EAPTNC = "tnc" + nameOf SQL.EAPRADIUS = "radius" + fromName "md5" = return SQL.EAPMD5 + fromName "gtc" = return SQL.EAPGTC + fromName "tls" = return SQL.EAPTLS + fromName "sim" = return SQL.EAPSIM + fromName "ttls" = return SQL.EAPTTLS + fromName "aka" = return SQL.EAPAKA + fromName "mschapv2" = return SQL.EAPMSCHAPV2 + fromName "tnc" = return SQL.EAPTNC + fromName "radius" = return SQL.EAPRADIUS + fromName str = failure $ InvalidValue str + +instance Nameable SQL.AuthMethod where + nameOf = fmap toLower . show + fromName "any" = return SQL.Any + fromName "rsa" = return SQL.PubKey + fromName "psk" = return SQL.PSK + fromName "eap" = return SQL.EAP + fromName "xauth" = return SQL.XAUTH + fromName str = failure $ InvalidValue str + +instance Nameable SQL.TrafficSelectorType where + nameOf SQL.IPv4AddrRange = "ipv4" + nameOf SQL.IPv6AddrRange = "ipv6" + fromName "ipv4" = return SQL.IPv4AddrRange + fromName "ipv6" = return SQL.IPv6AddrRange + fromName str = failure $ InvalidValue str + diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Applicative ((<|>)) +import Control.Lens ((.=), (.~), (%=), (&), set) +import Control.Monad (void) +import Control.Monad.Failable +import Control.Monad.State.Strict (evalStateT, execStateT, lift, modify) +import CLI.Types +import CLI.Commands +import Data.Char (isSpace) +import Data.Default (def) +import Data.List (unwords) +import Data.Text (Text, pack, unpack) +import System.Console.Haskeline (defaultSettings, getPassword, runInputT) +import System.Console.StructuredCLI hiding (Commands) +import System.Environment (getArgs) +import StrongSwan.SQL hiding (Settings) + +import qualified Data.Attoparsec.Text as A +import qualified StrongSwan.SQL as SQL +usage :: IO () +usage = + putStrLn "Usage: strongswan-sql\n\t[--user|-u ]\n\t[--ask-password | -a]\n\t[--host|-h ]\n\t[--db | -d ]\n\t[--help | -?]" + +main :: IO () +main = do + args <- pack . unwords <$> getArgs + opt@Options{..} <- hoist BadArguments $ A.parseOnly (execStateT arguments def) args + password <- if _askPassword + then runInputT defaultSettings $ getPassword (Just '*') "Password: " + else return Nothing + if _requestedHelp + then usage + else if _badInput /= "" + then do + putStrLn $ "Bad arguments at or around " ++ unpack _badInput + usage + else do + let options' = maybe opt (\s -> opt & settings . dbPassword .~ s) password + db <- mkContext' options' + let state = AppState { _options = options', + _dbContext = db, + _ipsecSettings = def, + _flush = Nothing } + runCLI "strongswan SQL" def commands `evalStateT` state >>= hoist FatalError + where mkContext' Options{..} = SQL.mkContext _settings +modifySettings :: (SQL.Settings -> SQL.Settings) -> ArgsParser () +modifySettings = (settings %=) + +arguments :: ArgsParser () +arguments = do + void . A.many' $ + userOption <|> dbOption <|> withPasswordOption <|> hostOption <|> helpOption + remaining <- lift A.takeText + badInput .= remaining + +option0' :: Text -> Text -> (Options -> Options) -> ArgsParser () +option0' long short f = + lift (A.skipSpace *> (A.string long <|> A.string short)) *> modify f + +option1 :: Text -> Text -> (Text -> SQL.Settings -> SQL.Settings) -> ArgsParser () +option1 long short f = do + val <- lift $ A.skipSpace *> keyword *> A.skipSpace *> A.takeWhile (not . isSpace) + modifySettings $ f val + where keyword = A.string long <|> A.string short + +userOption :: ArgsParser () +userOption = option1 "--user" "-u" $ set dbUser . unpack + +dbOption :: ArgsParser () +dbOption = option1 "--db" "-d" $ set dbName . unpack + +hostOption :: ArgsParser () +hostOption = option1 "--host" "-h" $ set dbHost . unpack + +withPasswordOption :: ArgsParser () +withPasswordOption = option0' "--ask-password" "-a" $ set askPassword True + +helpOption :: ArgsParser () +helpOption = option0' "--help" "-?" $ set requestedHelp True + diff --git a/src/StrongSwan/SQL.hs b/src/StrongSwan/SQL.hs new file mode 100644 --- /dev/null +++ b/src/StrongSwan/SQL.hs @@ -0,0 +1,462 @@ +{-# 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, +-- * 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, + writeIKEConfig, + writePeerConfig, + writePeer2ChildConfig, + writeTrafficSelector, + lookupChild2TSConfig, + findChildSAConfig, + findChildSAConfigByName, + findIKEConfig, + findPeerConfig, + findPeerConfigByName, + findPeer2ChildConfig, + findTrafficSelector, + deleteChild2TSConfig, + deleteChildSAConfig, + deleteIKEConfig, + 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(..), + IKEConfig(..), + IPSecSettings(..), + PeerConfig(..), + Peer2ChildConfig(..), + Result(..), + SAAction(..), + SAMode(..), + Settings(..), + SQL.OK(..), + SQLRow, + TrafficSelector(..), + TrafficSelectorType(..), + TrafficSelectorKind(..) + ) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Lens ((^.), (.=), makeLenses, use) +import Control.Monad (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.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 + +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 } diff --git a/src/StrongSwan/SQL/Encoding.hs b/src/StrongSwan/SQL/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/StrongSwan/SQL/Encoding.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module StrongSwan.SQL.Encoding where + +import Control.Exception (throw) +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.Word (Word8) +import Numeric (showHex) +import StrongSwan.SQL.Types + +import qualified Data.ByteString as B +import qualified Database.MySQL.Base as SQL + +class SQLRow a where + toValues :: a -> [SQL.MySQLValue] + fromValues :: [SQL.MySQLValue] -> a + +class SQLValue a where + toSQL :: a -> SQL.MySQLValue + fromSQL :: SQL.MySQLValue -> a + +instance SQLValue (Value 'SQL.MySQLInt8U) where + toSQL (TinyInt x) = SQL.MySQLInt8U x + fromSQL (SQL.MySQLInt8U x) = TinyInt x + fromSQL (SQL.MySQLInt8 x) = TinyInt $ fromIntegral x + fromSQL v = throw $ InvalidValueForType "TinyInt" (show v) + +instance SQLValue (Value 'SQL.MySQLInt16U) where + toSQL (SmallInt x) = SQL.MySQLInt16U x + fromSQL (SQL.MySQLInt16U x) = SmallInt x + fromSQL v = throw $ InvalidValueForType "SmallInt" (show v) + + +instance SQLValue (Value 'SQL.MySQLInt32U) where + toSQL (IntWord32 x) = SQL.MySQLInt32U x + fromSQL (SQL.MySQLInt32U x) = IntWord32 x + fromSQL v = throw $ InvalidValueForType "IntWord32" (show v) + +instance SQLValue (Value 'SQL.MySQLBytes) where + toSQL (VarBinary bytes) = SQL.MySQLBytes bytes + fromSQL (SQL.MySQLBytes bytes) = VarBinary bytes + fromSQL v = throw $ InvalidValueForType "VarBinary" (show v) + +instance SQLValue (Value 'SQL.MySQLText) where + toSQL (VarChar bytes) = SQL.MySQLText bytes + toSQL NullChar = SQL.MySQLNull + fromSQL (SQL.MySQLText bytes) = VarChar bytes + fromSQL SQL.MySQLNull = NullChar + fromSQL v = throw $ InvalidValueForType "VarChar" (show v) + +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] + + 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) + +parseEmail :: ByteString -> (String, String) +parseEmail = second (drop 1) . span (/= '@') . unpack + +instance SQLRow IKEConfig where + toValues IKEConfig {..} = [ + toSQL $ toTinyInt _ikeReqCert, + toSQL $ toTinyInt _ikeForceEncap, + toSQL . toVarChar $ Just _ikeLocalAddress, + toSQL . toVarChar $ Just _ikeRemoteAddress] + fromValues (iD : + reqCert : + forceEncap : + localAddress : + remoteAddress : + []) = IKEConfig { + _ikeId = return . fromInt $ fromSQL iD, + _ikeReqCert = fromTinyInt $ fromSQL reqCert, + _ikeForceEncap = fromTinyInt $ fromSQL forceEncap, + _ikeLocalAddress = fromJust . fromVarChar $ fromSQL localAddress, + _ikeRemoteAddress = fromJust . fromVarChar $ fromSQL remoteAddress + } + fromValues xs = throw $ SQLValuesMismatch "IKEConfig" (show xs) + + +instance SQLRow ChildSAConfig where + toValues ChildSAConfig {..} = [ + toSQL . toVarChar $ Just _childSAName, + toSQL $ toInt _childSALifeTime, + toSQL $ toInt _childSARekeyTime, + toSQL $ toInt _childSAJitter, + toSQL $ toVarChar _childSAUpDown, + toSQL $ toTinyInt _childSAHostAccess, + toSQL $ toTinyInt _childSAMode, + toSQL $ toTinyInt _childSAStartAction, + toSQL $ toTinyInt _childSADPDAction, + toSQL $ toTinyInt _childSACloseAction, + toSQL $ toTinyInt _childSAIPCompression, + toSQL $ toInt _childSAReqID ] + fromValues (iD: + name : + lifeTime : + rekeyTime : + jitter : + upDown : + hostAccess : + mode : + startAction : + dpdAction : + closeAction : + ipCompression : + reqID : + []) = ChildSAConfig { + _childSAId = return . fromInt $ fromSQL iD, + _childSAName = fromJust . fromVarChar $ fromSQL name, + _childSALifeTime = fromInt $ fromSQL lifeTime, + _childSARekeyTime = fromInt $ fromSQL rekeyTime, + _childSAJitter = fromInt $ fromSQL jitter, + _childSAUpDown = fromVarChar $ fromSQL upDown, + _childSAHostAccess = fromTinyInt $ fromSQL hostAccess, + _childSAMode = fromTinyInt $ fromSQL mode, + _childSAStartAction = fromTinyInt $ fromSQL startAction, + _childSADPDAction = fromTinyInt $ fromSQL dpdAction, + _childSACloseAction = fromTinyInt $ fromSQL closeAction, + _childSAIPCompression = fromTinyInt $ fromSQL ipCompression, + _childSAReqID = fromInt $ fromSQL reqID + } + fromValues xs = throw $ SQLValuesMismatch "ChildSAConfig" (show xs) + +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 $ toTinyInt _peerCfgCertPolicy, + toSQL $ toTinyInt _peerCfgUniqueIds, + toSQL $ toTinyInt _peerCfgAuthMethod, + toSQL $ toTinyInt _peerCfgEAPType, + toSQL $ toSmallInt _peerCfgEAPVendor, + toSQL $ toTinyInt _peerCfgKeyingTries, + toSQL $ toInt _peerCfgRekeyTime, + toSQL $ toInt _peerCfgReauthTime, + toSQL $ toInt _peerCfgJitter, + toSQL $ toInt _peerCfgOverTime, + toSQL $ toTinyInt _peerCfgMobike, + toSQL $ toInt _peerCfgDPDDelay, + toSQL $ toVarChar _peerCfgVirtual, + toSQL $ toVarChar _peerCfgPool, + toSQL $ toTinyInt _peerCfgMediation, + toSQL $ toInt _peerCfgMediatedBy, + toSQL $ toInt _peerCfgPeerId ] + fromValues (iD : + name : + ikeVersion : + ikeConfig : + localId : + remoteId : + certPolicy : + uniqueIds : + authMethod : + eapType : + eapVendor : + keyingTries : + rekeyTime : + reauthTime : + jitter : + overTime : + mobike : + dpdDelay : + virtual : + pool : + mediation : + mediatedBy : + peerId : + []) = PeerConfig { + _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, + _peerCfgCertPolicy = fromTinyInt $ fromSQL certPolicy, + _peerCfgUniqueIds = fromTinyInt $ fromSQL uniqueIds, + _peerCfgAuthMethod = fromTinyInt $ fromSQL authMethod, + _peerCfgEAPType = fromTinyInt $ fromSQL eapType, + _peerCfgEAPVendor = fromSmallInt $ fromSQL eapVendor, + _peerCfgKeyingTries = fromTinyInt $ fromSQL keyingTries, + _peerCfgRekeyTime = fromInt $ fromSQL rekeyTime, + _peerCfgReauthTime = fromInt $ fromSQL reauthTime, + _peerCfgJitter = fromInt $ fromSQL jitter, + _peerCfgOverTime = fromInt $ fromSQL overTime, + _peerCfgMobike = fromTinyInt $ fromSQL mobike, + _peerCfgDPDDelay = fromInt $ fromSQL dpdDelay, + _peerCfgVirtual = fromVarChar $ fromSQL virtual, + _peerCfgPool = fromVarChar $ fromSQL pool, + _peerCfgMediation = fromTinyInt $ fromSQL mediation, + _peerCfgMediatedBy = fromInt $ fromSQL mediatedBy, + _peerCfgPeerId = fromInt $ fromSQL peerId + } + fromValues xs = throw $ SQLValuesMismatch "PeerConfig" (show xs) + +instance SQLRow Peer2ChildConfig where + toValues Peer2ChildConfig {..} = [ + toSQL $ toInt p2cPeerCfgId, + toSQL $ toInt p2cChildCfgId ] + + fromValues (peerId: childId: []) = + Peer2ChildConfig { + p2cPeerCfgId = fromInt $ fromSQL peerId, + p2cChildCfgId = fromInt $ fromSQL childId + } + fromValues xs = throw $ SQLValuesMismatch "Peer2ChildConfig" (show xs) + +instance SQLRow TrafficSelector where + toValues TrafficSelector {..} = [ + toSQL $ toTinyInt _tsType, + toSQL $ toSmallInt _tsProtocol, + toSQL $ toVarBinary _tsStartAddr, + toSQL $ toVarBinary _tsEndAddr, + toSQL $ toSmallInt _tsStartPort, + toSQL $ toSmallInt _tsEndPort ] + fromValues (iD : + type' : + protocol : + startAddr : + endAddr : + startPort : + endort : + []) = TrafficSelector { + _tsId = return . fromInt $ fromSQL iD, + _tsType = fromTinyInt $ fromSQL type', + _tsProtocol = fromSmallInt $ fromSQL protocol, + _tsStartAddr = fromVarBinary $ fromSQL startAddr, + _tsEndAddr = fromVarBinary $ fromSQL endAddr, + _tsStartPort = fromSmallInt $ fromSQL startPort, + _tsEndPort = fromSmallInt $ fromSQL endort + } + fromValues xs = throw $ SQLValuesMismatch "TrafficSelector" (show xs) + +instance SQLRow Child2TSConfig where + toValues Child2TSConfig {..} = [ + toSQL $ toInt c2tsChildCfgId, + toSQL $ toInt c2tsTrafficSelectorCfgId, + toSQL $ toTinyInt c2tsTrafficSelectorKind ] + + fromValues (childCfgId : + trafficSelectorCfgId : + trafficSelectorKind : + []) = Child2TSConfig { + c2tsChildCfgId = fromInt $ fromSQL childCfgId, + c2tsTrafficSelectorCfgId = fromInt $ fromSQL trafficSelectorCfgId, + c2tsTrafficSelectorKind = fromTinyInt $ fromSQL trafficSelectorKind + } + fromValues xs = throw $ SQLValuesMismatch "Child2TSConfig" (show xs) + +encodeHex :: ByteString -> String +encodeHex = B.foldr showHex "" + diff --git a/src/StrongSwan/SQL/Lenses.hs b/src/StrongSwan/SQL/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/StrongSwan/SQL/Lenses.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +module StrongSwan.SQL.Lenses where + +import Control.Lens (makeLenses) +import StrongSwan.SQL.Types + +makeLenses ''IKEConfig +makeLenses ''ChildSAConfig +makeLenses ''PeerConfig +makeLenses ''TrafficSelector +makeLenses ''IPSecSettings diff --git a/src/StrongSwan/SQL/Statements.hs b/src/StrongSwan/SQL/Statements.hs new file mode 100644 --- /dev/null +++ b/src/StrongSwan/SQL/Statements.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} + +module StrongSwan.SQL.Statements where + +import Control.Exception (fromException) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Fail (MonadFail) +import Control.Monad.Failable +import Database.MySQL.Base (MySQLConn) +import StrongSwan.SQL.Types + +import qualified Database.MySQL.Base as SQL + +prepareStatements :: (Failable m, MonadIO m, MonadFail m) => SQL.MySQLConn -> m PreparedStatements +prepareStatements conn = do + let ?conn = conn + [createChildSA, updateChildSA, findChildSA, deleteChildSA] <- + initializeWith createChildSATableStatement + [createChildSAStatement, + updateChildSAStatement, + findChildSAStatement, + deleteChildSAStatement] + + findChildSAByName <- prepare findChildSAByNameStatement + + [createIKE, updateIKE, findIKE, deleteIKE] <- + initializeWith createIKETableStatement + [createIKEStatement, + updateIKEStatement, + findIKEStatement, + deleteIKEStatement] + + [createPeer, updatePeer, findPeer, deletePeer] <- + initializeWith createPeerTableStatement + [createPeerStatement, + updatePeerStatement, + findPeerStatement, + deletePeerStatement] + + findPeerByName <- prepare findPeerByNameStatement + + [createP2C, updateP2C, findP2C, deleteP2C] <- + initializeWith createP2CTableStatement + [createP2CStatement, + updateP2CStatement, + findP2CStatement, + deleteP2CStatement] + + [createTS, updateTS, findTS, deleteTS] <- + initializeWith createTSTableStatement + [createTSStatement, + updateTSStatement, + findTSStatement, + deleteTSStatement] + + [createC2TS, updateC2TS, findC2TS, deleteC2TS] <- + initializeWith createC2TSTableStatement + [createC2TSStatement, + updateC2TSStatement, + findC2TSStatement, + deleteC2TSStatement] + + [createIPSec, findIPSec, deleteIPSec] <- + initializeWith createIPSecTableStatement + [createIPSecStatement, + findIPSecStatement, + 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 + } + +prepare :: (?conn :: MySQLConn, Failable m, MonadIO m) => SQL.Query -> m SQL.StmtID +prepare = failableIO . SQL.prepareStmt ?conn + +updateIKEStatement :: SQL.Query +updateIKEStatement = "UPDATE ike_configs SET certreq = ?, force_encap = ?, local = ?, remote = ? WHERE id = ?;" + +createIKETableStatement :: SQL.Query +createIKETableStatement = "CREATE TABLE `ike_configs` ( `id` int(10) unsigned NOT NULL auto_increment, `certreq` tinyint(3) unsigned NOT NULL default '1', `force_encap` tinyint(1) NOT NULL default '0', `local` varchar(128) collate utf8_unicode_ci NOT NULL, `remote` varchar(128) collate utf8_unicode_ci NOT NULL, PRIMARY KEY (`id`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createIKEStatement :: SQL.Query +createIKEStatement = "INSERT INTO ike_configs (certreq, force_encap, local, remote) VAlUES (?, ?, ?, ?);" + +findIKEStatement :: SQL.Query +findIKEStatement = "SELECT * FROM ike_configs WHERE id = ?;" + +deleteIKEStatement :: SQL.Query +deleteIKEStatement = "DELETE FROM ike_configs WHERE id = ?;" + +updateChildSAStatement :: SQL.Query +updateChildSAStatement = "UPDATE child_configs SET name = ?, lifetime = ?, rekeytime = ?, jitter = ?, updown = ?, hostaccess = ?, mode = ?, start_action = ?, dpd_action = ?, close_action = ?, ipcomp = ?, reqid = ? WHERE id = ?" + +createChildSATableStatement :: SQL.Query +createChildSATableStatement = "CREATE TABLE `child_configs` ( `id` int(10) unsigned NOT NULL auto_increment, `name` varchar(32) collate utf8_unicode_ci NOT NULL, `lifetime` mediumint(8) unsigned NOT NULL default '1500', `rekeytime` mediumint(8) unsigned NOT NULL default '1200', `jitter` mediumint(8) unsigned NOT NULL default '60', `updown` varchar(128) collate utf8_unicode_ci default NULL, `hostaccess` tinyint(1) unsigned NOT NULL default '0', `mode` tinyint(4) unsigned NOT NULL default '2', `start_action` tinyint(4) unsigned NOT NULL default '0', `dpd_action` tinyint(4) unsigned NOT NULL default '0', `close_action` tinyint(4) unsigned NOT NULL default '0', `ipcomp` tinyint(4) unsigned NOT NULL default '0', `reqid` mediumint(8) unsigned NOT NULL default '0', PRIMARY KEY (`id`), INDEX (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createChildSAStatement :: SQL.Query +createChildSAStatement = "INSERT INTO child_configs (name, lifetime, rekeytime, jitter, updown, hostaccess, mode, start_action, dpd_action, close_action, ipcomp, reqid) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" + +findChildSAByNameStatement :: SQL.Query +findChildSAByNameStatement = "SELECT * FROM child_configs WHERE name = ?;" + +findChildSAStatement :: SQL.Query +findChildSAStatement = "SELECT * FROM child_configs WHERE id = ?;" + +deleteChildSAStatement :: SQL.Query +deleteChildSAStatement = "DELETE FROM child_configs WHERE id = ?;" + +createPeerTableStatement :: SQL.Query +createPeerTableStatement = "CREATE TABLE `peer_configs` ( `id` int(10) unsigned NOT NULL auto_increment, `name` varchar(32) collate utf8_unicode_ci NOT NULL, `ike_version` tinyint(3) unsigned NOT NULL default '2', `ike_cfg` int(10) unsigned NOT NULL, `local_id` varchar(64) collate utf8_unicode_ci NOT NULL, `remote_id` varchar(64) collate utf8_unicode_ci NOT NULL, `cert_policy` tinyint(3) unsigned NOT NULL default '1', `uniqueid` tinyint(3) unsigned NOT NULL default '0', `auth_method` tinyint(3) unsigned NOT NULL default '1', `eap_type` tinyint(3) unsigned NOT NULL default '0', `eap_vendor` smallint(5) unsigned NOT NULL default '0', `keyingtries` tinyint(3) unsigned NOT NULL default '3', `rekeytime` mediumint(8) unsigned NOT NULL default '7200', `reauthtime` mediumint(8) unsigned NOT NULL default '0', `jitter` mediumint(8) unsigned NOT NULL default '180', `overtime` mediumint(8) unsigned NOT NULL default '300', `mobike` tinyint(1) NOT NULL default '1', `dpd_delay` mediumint(8) unsigned NOT NULL default '120', `virtual` varchar(40) default NULL, `pool` varchar(32) default NULL, `mediation` tinyint(1) NOT NULL default '0', `mediated_by` int(10) unsigned NOT NULL default '0', `peer_id` int(10) unsigned NOT NULL default '0', PRIMARY KEY (`id`), INDEX (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createPeerStatement :: SQL.Query +createPeerStatement = "INSERT INTO peer_configs (`name`, `ike_version`, `ike_cfg`, `local_id`, `remote_id`, `cert_policy`, `uniqueid`, `auth_method`, `eap_type`, `eap_vendor`, `keyingtries`, `rekeytime`, `reauthtime`, `jitter`, `overtime`, `mobike`, `dpd_delay`, `virtual`, `pool`, `mediation`, `mediated_by`, `peer_id` ) VALUES ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);" + +updatePeerStatement :: SQL.Query +updatePeerStatement = "UPDATE peer_configs SET `name` = ?, `ike_version` = ?, `ike_cfg` = ?, `local_id` = ?, `remote_id` = ?, `cert_policy` = ?, `uniqueid` = ?, `auth_method` = ?, `eap_type` = ?, `eap_vendor` = ?, `keyingtries` = ?, `rekeytime` = ?, `reauthtime` = ?, `jitter` = ?, `overtime` = ?, `mobike` = ?, `dpd_delay` = ?, `virtual` = ?, `pool` = ?, `mediation` = ?, `mediated_by` = ?, `peer_id` = ? WHERE `id` = ?;" + +findPeerStatement :: SQL.Query +findPeerStatement = "SELECT * from peer_configs WHERE id = ?;" + +findPeerByNameStatement :: SQL.Query +findPeerByNameStatement = "SELECT * from peer_configs WHERE name = ?;" + +deletePeerStatement :: SQL.Query +deletePeerStatement = "DELETE from peer_configs WHERE id = ?;" + +createP2CTableStatement :: SQL.Query +createP2CTableStatement = "CREATE TABLE `peer_config_child_config` (`peer_cfg` int(10) unsigned NOT NULL, `child_cfg` int(10) unsigned NOT NULL, PRIMARY KEY (`peer_cfg`, `child_cfg`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createP2CStatement :: SQL.Query +createP2CStatement = "INSERT INTO peer_config_child_config (peer_cfg, child_cfg) VALUES (?, ?);" + +updateP2CStatement :: SQL.Query +updateP2CStatement = "UPDATE peer_config_child_config SET peer_cfg = ?, child_cfg = ? WHERE peer_cfg = ? AND child_cfg = ?;" + +findP2CStatement :: SQL.Query +findP2CStatement = "SELECT * from peer_config_child_config WHERE peer_cfg = ? AND child_cfg = ?;" + +deleteP2CStatement :: SQL.Query +deleteP2CStatement = "DELETE from peer_config_child_config WHERE peer_cfg = ? AND child_cfg = ?"; + +createTSTableStatement :: SQL.Query +createTSTableStatement = "CREATE TABLE `traffic_selectors` (`id` int(10) unsigned NOT NULL auto_increment, `type` tinyint(3) unsigned NOT NULL default '7', `protocol` smallint(5) unsigned NOT NULL default '0', `start_addr` varbinary(16) default NULL, `end_addr` varbinary(16) default NULL, `start_port` smallint(5) unsigned NOT NULL default '0', `end_port` smallint(5) unsigned NOT NULL default '65535', PRIMARY KEY (`id`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createTSStatement :: SQL.Query +createTSStatement = "INSERT INTO traffic_selectors (type, protocol, start_addr, end_addr, start_port, end_port) VALUES ( ?, ?, ?, ?, ?, ?);" + +updateTSStatement :: SQL.Query +updateTSStatement = "UPDATE traffic_selectors SET type = ?, protocol = ?, start_addr = ?, end_addr = ?, start_port = ?, end_port = ? WHERE id = ?;" + +findTSStatement :: SQL.Query +findTSStatement = "SELECT * FROM traffic_selectors WHERE id = ?;" + +deleteTSStatement :: SQL.Query +deleteTSStatement = "DELETE FROM traffic_selectors WHERE id = ?"; + +createC2TSTableStatement :: SQL.Query +createC2TSTableStatement = "CREATE TABLE `child_config_traffic_selector` (`child_cfg` int(10) unsigned NOT NULL, `traffic_selector` int(10) unsigned NOT NULL, `kind` tinyint(3) unsigned NOT NULL, INDEX (`child_cfg`, `traffic_selector`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;" + +createC2TSStatement :: SQL.Query +createC2TSStatement = "INSERT INTO child_config_traffic_selector (child_cfg, traffic_selector, kind) VALUES (?, ?, ?);" + +updateC2TSStatement :: SQL.Query +updateC2TSStatement = "UPDATE child_config_traffic_selector SET child_cfg = ?, traffic_selector = ?, kind = ? WHERE child_cfg = ? AND traffic_selector = ?;" + +findC2TSStatement :: SQL.Query +findC2TSStatement = "SELECT * FROM child_config_traffic_selector WHERE child_cfg = ?;" + +deleteC2TSStatement :: SQL.Query +deleteC2TSStatement = "DELETE FROM child_config_traffic_selector WHERE child_cfg = ?;" + +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;" + +createIPSecStatement :: SQL.Query +createIPSecStatement = "INSERT INTO ipsec_configs (name, child_cfg, peer_cfg, ike_cfg, local_ts, remote_ts) 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 + -> [SQL.Query] + -> m [SQL.StmtID] +initializeWith createTableStatement operStatements = do + createTable <- prepare createTableStatement + -- create config table before any other operations on it. If it already exists.. whatever + (void . failableIO $ SQL.executeStmt ?conn createTable []) + `recover` \e -> + case fromException e of + Just (SQL.ERRException SQL.ERR{..}) | errCode == 1050 -> + -- ignore table already exists errors + return () + _ -> + failure e + + mapM prepare operStatements diff --git a/src/StrongSwan/SQL/Types.hs b/src/StrongSwan/SQL/Types.hs new file mode 100644 --- /dev/null +++ b/src/StrongSwan/SQL/Types.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} + +module StrongSwan.SQL.Types where + +import Control.Exception (Exception, throw) +import Data.ASN1.Types (ASN1) +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Default (Default(..)) +import Data.IP (IP(..), IPv4, IPv6, fromIPv4, toIPv4, fromIPv6b, toIPv6b) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Word (Word8, Word16, Word32) +import Network.Socket (PortNumber) + +import qualified Data.ByteString as B +import qualified Database.MySQL.Base as SQL + +data Error = UnknownCharacterEncoding Int + | UnknownSAMode Int + | UnknownSAAction Int + | UnknownCertPolicy Int + | UnknownAuthMethod Int + | UnknownEAPType Int + | UnknownTrafficSelectorType Int + | UnknownTrafficSelectorKind Int + | InvalidValueForType String String + | SQLValuesMismatch String String + | NotFound Text + | MultipleResults Text String + | FailedOperation Text + deriving (Typeable, Show) + +instance Exception Error + +data Result a = Result { + lastModifiedKey :: a, + response :: SQL.OK + } + +data MySQLCharacterEncoding = UTF8MB4 -- ^ utf8mb4_unicode_ci + | UTF8 -- ^ utf8_general_ci + | UCS2 -- ^ ucs2_general_ci + | UTF16 -- ^ utf16_general_ci + | UTF16LE -- ^ utf16le_general_ci + | UTF32 -- ^ utf32_general_ci + deriving Show + +instance Enum MySQLCharacterEncoding where + fromEnum UTF8MB4 = 224 + fromEnum UTF8 = 33 + fromEnum UCS2 = 35 + fromEnum UTF16 = 54 + fromEnum UTF16LE = 56 + fromEnum UTF32 = 60 + toEnum 224 = UTF8MB4 + toEnum 33 = UTF8 + toEnum 35 = UCS2 + toEnum 54 = UTF16 + toEnum 56 = UTF16LE + 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 Value (a :: k -> SQL.MySQLValue) where + TinyInt :: Word8 -> Value 'SQL.MySQLInt8U + SmallInt :: Word16 -> Value 'SQL.MySQLInt16U + IntWord32 :: Word32 -> Value 'SQL.MySQLInt32U + VarBinary :: ByteString -> Value 'SQL.MySQLBytes + VarChar :: Text -> Value 'SQL.MySQLText + NullChar :: Value 'SQL.MySQLText + +class TinyInt a where + toTinyInt :: a -> Value 'SQL.MySQLInt8U + fromTinyInt :: Value 'SQL.MySQLInt8U -> a + +instance TinyInt Bool where + toTinyInt False = TinyInt 0 + toTinyInt True = TinyInt 1 + + fromTinyInt (TinyInt 0) = False + fromTinyInt (TinyInt _) = True + +instance TinyInt Word8 where + toTinyInt = TinyInt + fromTinyInt (TinyInt x) = x + +toSQLEnum :: (Enum a) => a -> Value 'SQL.MySQLInt8U +toSQLEnum = TinyInt . fromIntegral . fromEnum + +fromSQLEnum :: (Enum a) => Value 'SQL.MySQLInt8U -> a +fromSQLEnum (TinyInt x) = toEnum $ fromIntegral x + +instance TinyInt SAAction where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt SAMode where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt CertPolicy where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt AuthMethod where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt EAPType where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt TrafficSelectorType where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +instance TinyInt TrafficSelectorKind where + toTinyInt = toSQLEnum + fromTinyInt = fromSQLEnum + +class SmallInt a where + toSmallInt :: a -> Value 'SQL.MySQLInt16U + fromSmallInt :: Value 'SQL.MySQLInt16U -> a + +instance SmallInt Word16 where + toSmallInt = SmallInt + fromSmallInt (SmallInt x) = x + +instance SmallInt PortNumber where + toSmallInt = SmallInt . fromIntegral + fromSmallInt (SmallInt x) = fromIntegral x + +class IntWord32 a where + toInt :: a -> Value 'SQL.MySQLInt32U + fromInt :: Value 'SQL.MySQLInt32U -> a + +instance (Integral n) => IntWord32 n where + toInt = IntWord32 . fromIntegral + fromInt (IntWord32 x) = fromIntegral x + +class VarChar a where + toVarChar :: Maybe a -> Value 'SQL.MySQLText + fromVarChar :: Value 'SQL.MySQLText -> Maybe a + +instance VarChar Text where + toVarChar Nothing = NullChar + toVarChar (Just text) = VarChar text + fromVarChar (VarChar text) = Just text + fromVarChar NullChar = Nothing + +class VarBinary a where + toVarBinary :: a -> Value 'SQL.MySQLBytes + fromVarBinary :: Value 'SQL.MySQLBytes -> a + +instance VarBinary String where + toVarBinary = VarBinary . pack + fromVarBinary (VarBinary bytes) = unpack bytes + +instance VarBinary ByteString where + toVarBinary = VarBinary + fromVarBinary (VarBinary bytes) = bytes + +instance VarBinary IPv4 where + toVarBinary = VarBinary . B.pack . fmap fromIntegral . fromIPv4 + fromVarBinary (VarBinary bytes) = toIPv4 . fmap fromIntegral $ B.unpack bytes + +instance VarBinary IPv6 where + toVarBinary = VarBinary . B.pack . fmap fromIntegral . fromIPv6b + fromVarBinary (VarBinary bytes) = toIPv6b . fmap fromIntegral $ B.unpack bytes + +instance VarBinary IP where + toVarBinary (IPv4 addr) = toVarBinary addr + toVarBinary (IPv6 addr) = toVarBinary addr + fromVarBinary value@(VarBinary bytes) + | B.length bytes == 4 = IPv4 $ fromVarBinary value + | otherwise = IPv6 $ fromVarBinary value + +data SAMode = Transport + | Tunnel + | Beet + | Pass + | Drop + deriving (Eq, Show) + +instance Enum SAMode where + fromEnum Transport = 1 + fromEnum Tunnel = 2 + fromEnum Beet = 3 + fromEnum Pass = 4 + fromEnum Drop = 5 + toEnum 1 = Transport + toEnum 2 = Tunnel + toEnum 3 = Beet + toEnum 4 = Pass + toEnum 5 = Drop + toEnum x = throw $ UnknownSAMode x + +data SAAction = None + | Route + | Restart + deriving (Eq, Show) + +instance Enum SAAction where + fromEnum None = 0 + fromEnum Route = 1 + fromEnum Restart = 2 + toEnum 0 = None + toEnum 1 = Route + toEnum 2 = Restart + toEnum x = throw $ UnknownSAAction x + +data CertPolicy = AlwaysSend + | SendIfAsked + | NeverSend + deriving (Eq, Show) + +instance Enum CertPolicy where + fromEnum AlwaysSend = 0 + fromEnum SendIfAsked = 1 + fromEnum NeverSend = 2 + toEnum 0 = AlwaysSend + toEnum 1 = SendIfAsked + toEnum 2 = NeverSend + toEnum x = throw $ UnknownCertPolicy x + +data AuthMethod = Any + | PubKey + | PSK + | EAP + | XAUTH + deriving (Eq, Show) + +instance Enum AuthMethod where + fromEnum Any = 0 + fromEnum PubKey = 1 + fromEnum PSK = 2 + fromEnum EAP = 3 + fromEnum XAUTH = 4 + + toEnum 0 = Any + toEnum 1 = PubKey + toEnum 2 = PSK + toEnum 3 = EAP + toEnum 4 = XAUTH + toEnum x = throw $ UnknownAuthMethod x + +data EAPType = EAPMD5 + | EAPGTC + | EAPTLS + | EAPSIM + | EAPTTLS + | EAPAKA + | EAPMSCHAPV2 + | EAPTNC + | EAPRADIUS + deriving (Eq, Show) + +instance Enum EAPType where + fromEnum EAPMD5 = 4 + fromEnum EAPGTC = 6 + fromEnum EAPTLS = 13 + fromEnum EAPSIM = 18 + fromEnum EAPTTLS = 21 + fromEnum EAPAKA = 23 + fromEnum EAPMSCHAPV2 = 26 + fromEnum EAPTNC = 38 + fromEnum EAPRADIUS = 253 + + toEnum 4 = EAPMD5 + toEnum 6 = EAPGTC + toEnum 13 = EAPTLS + toEnum 18 = EAPSIM + toEnum 21 = EAPTTLS + toEnum 23 = EAPAKA + toEnum 26 = EAPMSCHAPV2 + toEnum 38 = EAPTNC + toEnum 253 = EAPRADIUS + toEnum x = throw $ UnknownEAPType x + +data TrafficSelectorType = IPv4AddrRange + | IPv6AddrRange + deriving (Eq, Show) + +instance Enum TrafficSelectorType where + fromEnum IPv4AddrRange = 7 + fromEnum IPv6AddrRange = 8 + toEnum 7 = IPv4AddrRange + toEnum 8 = IPv6AddrRange + toEnum x = throw $ UnknownTrafficSelectorType x + +data TrafficSelectorKind = LocalTS + | RemoteTS + | LocalDynamicTS + | RemoteDynamicTS + deriving (Eq, Show) + +instance Enum TrafficSelectorKind where + fromEnum LocalTS = 0 + fromEnum RemoteTS = 1 + fromEnum LocalDynamicTS = 2 + fromEnum RemoteDynamicTS = 3 + toEnum 0 = LocalTS + toEnum 1 = RemoteTS + toEnum 2 = LocalDynamicTS + toEnum 3 = RemoteDynamicTS + toEnum x = throw $ UnknownTrafficSelectorKind x + +data IKEConfig = IKEConfig { + _ikeId :: Maybe Int, + _ikeReqCert :: Bool, + _ikeForceEncap :: Bool, + _ikeLocalAddress :: Text, + _ikeRemoteAddress :: Text + } deriving (Eq, Show) + +instance Default IKEConfig where + def = IKEConfig { + _ikeId = Nothing, + _ikeReqCert = True, + _ikeForceEncap = False, + _ikeLocalAddress = "0.0.0.0", + _ikeRemoteAddress = "0.0.0.0" + } + +data ChildSAConfig = ChildSAConfig { + _childSAId :: Maybe Int, + _childSAName :: Text, + _childSALifeTime :: Word32, + _childSARekeyTime :: Word32, + _childSAJitter :: Word32, + _childSAUpDown :: Maybe Text, + _childSAHostAccess :: Bool, + _childSAMode :: SAMode, + _childSAStartAction :: SAAction, + _childSADPDAction :: SAAction, + _childSACloseAction :: SAAction, + _childSAIPCompression :: Bool, + _childSAReqID :: Word32 + } deriving (Eq, Show) + +instance Default ChildSAConfig where + def = ChildSAConfig { + _childSAId = Nothing, + _childSAName = "", + _childSALifeTime = 1500, + _childSARekeyTime = 1200, + _childSAJitter = 60, + _childSAUpDown = Nothing, + _childSAHostAccess = False, + _childSAMode = Tunnel, + _childSAStartAction = None, + _childSADPDAction = None, + _childSACloseAction = None, + _childSAIPCompression = False, + _childSAReqID = 0 + } + +data PeerConfig = PeerConfig { + _peerCfgId :: Maybe Int, + _peerCfgName :: Text, + _peerCfgIKEVersion :: Word8, + _peerCfgIKEConfigId :: Int, + _peerCfgLocalId :: Text, + _peerCfgRemoteId :: Text, + _peerCfgCertPolicy :: CertPolicy, + _peerCfgUniqueIds :: Bool, + _peerCfgAuthMethod :: AuthMethod, + _peerCfgEAPType :: EAPType, + _peerCfgEAPVendor :: Word16, + _peerCfgKeyingTries :: Word8, + _peerCfgRekeyTime :: Word32, + _peerCfgReauthTime :: Word32, + _peerCfgJitter :: Word32, + _peerCfgOverTime :: Word32, + _peerCfgMobike :: Bool, + _peerCfgDPDDelay :: Word32, + _peerCfgVirtual :: Maybe Text, + _peerCfgPool :: Maybe Text, + _peerCfgMediation :: Bool, + _peerCfgMediatedBy :: Int, + _peerCfgPeerId :: Int + } deriving (Eq, Show) + +instance Default PeerConfig where + def = PeerConfig { + _peerCfgId = Nothing, + _peerCfgName = "", + _peerCfgIKEVersion = 2, + _peerCfgIKEConfigId = maxBound, + _peerCfgLocalId = "%any", + _peerCfgRemoteId = "%any", + _peerCfgCertPolicy = SendIfAsked, + _peerCfgUniqueIds = True, + _peerCfgAuthMethod = PubKey, + _peerCfgEAPType = EAPMSCHAPV2, + _peerCfgEAPVendor = 0, + _peerCfgKeyingTries = 3, + _peerCfgRekeyTime = 7200, + _peerCfgReauthTime = 0, + _peerCfgJitter = 180, + _peerCfgOverTime = 300, + _peerCfgMobike = True, + _peerCfgDPDDelay = 120, + _peerCfgVirtual = Nothing, + _peerCfgPool = Nothing, + _peerCfgMediation = False, + _peerCfgMediatedBy = 0, + _peerCfgPeerId = 0 + } + +data Peer2ChildConfig = Peer2ChildConfig { + p2cPeerCfgId :: Int, + p2cChildCfgId :: Int + } deriving Show + +data TrafficSelector = TrafficSelector { + _tsId :: Maybe Int, + _tsType :: TrafficSelectorType, + _tsProtocol :: Word16, + _tsStartAddr :: IP, + _tsEndAddr :: IP, + _tsStartPort :: PortNumber, + _tsEndPort :: PortNumber + } deriving (Eq, Show) + +instance Default TrafficSelector where + def = TrafficSelector { + _tsId = Nothing, + _tsType = IPv4AddrRange, + _tsProtocol = 0, + _tsStartAddr = "0.0.0.0", + _tsEndAddr = "0.0.0.0", + _tsStartPort = 0, + _tsEndPort = 65535 + } + +data Child2TSConfig = Child2TSConfig { + c2tsChildCfgId :: Int, + c2tsTrafficSelectorCfgId :: Int, + c2tsTrafficSelectorKind :: TrafficSelectorKind + } deriving Show + +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 + } deriving Show + +-- | 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 +-- these fields (see "StrongSwan.SQL.Lenses") +data IPSecSettings = IPSecSettings { + _getIPSecCfgName :: Text, + _getIKEConfig :: IKEConfig, + _getChildSAConfig :: ChildSAConfig, + _getPeerConfig :: PeerConfig, + _getLocalTrafficSelector :: TrafficSelector, + _getRemoteTrafficSelector :: TrafficSelector + } deriving (Eq, Show) + + +instance Default IPSecSettings where + def = IPSecSettings "" def def def def def diff --git a/strongswan-sql.cabal b/strongswan-sql.cabal new file mode 100644 --- /dev/null +++ b/strongswan-sql.cabal @@ -0,0 +1,123 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: df70c57c8e5221e054346a59c78abfe9477cb3ae1e175f69d1def6b29fe3f9da + +name: strongswan-sql +version: 1.0.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 +bug-reports: https://gitlab.com/codemonkeylabs/strongswan-sql/issues +author: Erick Gonzalez +maintainer: erick@codemonkeylabs.de +copyright: 2019 Erick Gonzalez +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/codemonkeylabs/strongswan-sql + +library + exposed-modules: + StrongSwan.SQL + other-modules: + StrongSwan.SQL.Encoding + StrongSwan.SQL.Lenses + StrongSwan.SQL.Statements + StrongSwan.SQL.Types + hs-source-dirs: + src + default-extensions: ImplicitParams RecordWildCards + ghc-options: -Wall + build-depends: + asn1-encoding >=0.9 && <1.0 + , asn1-types >=0.3 && <0.4 + , attoparsec >=0.13 && <0.14 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , data-default >=0.7 && <0.8 + , failable >=1.1 && <1.2 + , haskeline >=0.7 && <0.8 + , io-streams >=1.5 && <1.6 + , iproute >=1.7 && <1.8 + , lens >=4.17 && <4.18 + , mtl >=2.2 && <2.3 + , mysql-haskell >=0.8.4 && <0.8.5 + , network >=3.0 && <3.1 + , structured-cli >=2.5.0.3 && <2.6 + , text >=1.2 && <1.3 + , transformers >=0.4.2 && <0.6 + default-language: Haskell2010 + +executable strongswan-sql + main-is: Main.hs + other-modules: + CLI.Types + CLI.Commands + CLI.Commands.ChildSA + CLI.Commands.Common + CLI.Commands.PeerCfg + CLI.Commands.TrafficSelector + hs-source-dirs: + app + default-extensions: ImplicitParams RecordWildCards + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + asn1-encoding >=0.9 && <1.0 + , asn1-types >=0.3 && <0.4 + , attoparsec >=0.13 && <0.14 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , data-default >=0.7 && <0.8 + , failable >=1.1 && <1.2 + , haskeline >=0.7 && <0.8 + , io-streams >=1.5 && <1.6 + , iproute >=1.7 && <1.8 + , lens >=4.17 && <4.18 + , mtl >=2.2 && <2.3 + , mysql-haskell >=0.8.4 && <0.8.5 + , network >=3.0 && <3.1 + , strongswan-sql + , structured-cli >=2.5.0.3 && <2.6 + , text >=1.2 && <1.3 + , transformers >=0.4.2 && <0.6 + default-language: Haskell2010 + +test-suite strongswan-sql-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_strongswan_sql + hs-source-dirs: + test + default-extensions: ImplicitParams RecordWildCards + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + asn1-encoding >=0.9 && <1.0 + , asn1-types >=0.3 && <0.4 + , attoparsec >=0.13 && <0.14 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , data-default >=0.7 && <0.8 + , failable >=1.1 && <1.2 + , haskeline >=0.7 && <0.8 + , io-streams >=1.5 && <1.6 + , iproute >=1.7 && <1.8 + , lens >=4.17 && <4.18 + , mtl >=2.2 && <2.3 + , mysql-haskell >=0.8.4 && <0.8.5 + , network >=3.0 && <3.1 + , strongswan-sql + , structured-cli >=2.5.0.3 && <2.6 + , text >=1.2 && <1.3 + , transformers >=0.4.2 && <0.6 + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"