strongswan-sql 1.0.1.0 → 1.1.0.0

raw patch · 8 files changed

+250/−121 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• app/CLI/Commands.hs +23/−10
• app/CLI/Commands/Identity.hs +55/−32
• app/CLI/Commands/PeerCfg.hs +7/−7
• src/StrongSwan/SQL.hs +122/−45
• src/StrongSwan/SQL/Encoding.hs +21/−10
• src/StrongSwan/SQL/Statements.hs +2/−3
• src/StrongSwan/SQL/Types.hs +18/−12
• strongswan-sql.cabal +2/−2

@@ -34,28 +34,41 @@       cfgTrafficSelector getLocalTrafficSelector       showTrafficSelector       exitCmd+    command "identity" "Configure an identity" setIdentityCfg >+ do+      cfgIdentity identity+      exitCmd     exitCmd   param "connection" "<managed connection name>" string setConnection >+ do-    cfgChildSA-    cfgPeer-    command "local-traffic-selector" "Configure local traffic selector" newLevel >+ do-      cfgTrafficSelector getLocalTrafficSelector-      command "show" "Display local traffic selector's parameters" $+    command "child-sa" "Configure child SA parameters" newLevel >+ do+      cfgChildSA+      exitCmd+    command "peer" "Configure peer parameters" newLevel >+ do+      cfgPeer+      exitCmd+    command "local" "Local endpoint configuration" newLevel >+ do+      command "traffic-selector" "Configure local traffic selector" newLevel >+ do+        cfgTrafficSelector getLocalTrafficSelector+        command "show" "Display local traffic selector's parameters" $           showTrafficSelector' getLocalTrafficSelector+        exitCmd+      cfgIdentity (ipsecSettings . getLocalIdentity)       exitCmd-    command "remote-traffic-selector" "Configure remote traffic selector" newLevel >+ do-      cfgTrafficSelector getRemoteTrafficSelector-      command "show" "Display remote traffic selector's parameters" $+    command "remote" "Remote endpoint configuration" newLevel >+ do+      command "traffic-selector" "Configure remote traffic selector" newLevel >+ do+        cfgTrafficSelector getRemoteTrafficSelector+        command "show" "Display remote traffic selector's parameters" $           showTrafficSelector' getRemoteTrafficSelector+        exitCmd+      cfgIdentity (ipsecSettings . getRemoteIdentity)       exitCmd     showConnection+    cfgSecret (ipsecSettings . getLocalIdentity ) (ipsecSettings . getRemoteIdentity)     command "remove" "Wipes out this connection from the DB" $ do       db       <- use dbContext       ipsecCfg <- use ipsecSettings       void . runMaybeT $ deleteIPSecSettings ipsecCfg db-      return NoAction+      return $ LevelUp 1     exitCmd-  cfgIdentity   where setConnection name = do           db <- use dbContext           result <- runMaybeT $ findIPSecSettings name db

@@ -1,14 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, RankNTypes #-}  module CLI.Commands.Identity where -import Control.Lens                        ((.=), use)-import Control.Monad                       (void)+import Control.Lens                        (Lens', (.=), use)+import Control.Monad                       (void, when) import Control.Monad.Trans.Maybe           (MaybeT(..), runMaybeT) import CLI.Commands.Common import CLI.Types import Data.Default                        (def)-import Data.Maybe                          (fromMaybe)+import Data.Maybe                          (fromMaybe, isNothing) import Control.Monad.State.Strict          (StateT, lift) import StrongSwan.SQL import System.Console.StructuredCLI hiding (Commands)@@ -16,48 +16,71 @@ secretType' :: (Monad m) => Validator m SharedSecretType secretType' = return . fromName -cfgIdentity :: Commands ()-cfgIdentity =+cfgIdentity :: Lens' AppState Identity -> Commands ()+cfgIdentity lens =   command "identity" "Identity configuration" newLevel >+ do-    command "any" "Matches any ID" (setIdentity $ AnyID Nothing) >+ do-      identityCmds-    param "ipv4" "<IPv4 address>" ipV4Address (setIdentity . IPv4AddrID Nothing) >+ do-      identityCmds-    param "ipv4" "<IPv6 address>" ipV6Address (setIdentity . IPv6AddrID Nothing) >+ do-      identityCmds+    command "any" "Matches any ID" (setIdentity lens $ AnyID Nothing)                 >+ identityCmds lens+    param "name" "<FQDN>" string (setIdentity lens . NameID Nothing)                  >+ identityCmds lens+    param "ipv4" "<IPv4 address>" ipV4Address (setIdentity lens . IPv4AddrID Nothing) >+ identityCmds lens+    param "ipv6" "<IPv6 address>" ipV6Address (setIdentity lens . IPv6AddrID Nothing) >+ identityCmds lens+    command "exit" "Exit identity configuration" (return $ LevelUp 2) -cfgSecret :: Commands ()-cfgSecret =+setIdentityCfg :: StateT AppState IO Action+setIdentityCfg = do+  flush .= Just flushIdentity+  return NewLevel++cfgSecret :: Lens' AppState Identity -> Lens' AppState Identity -> Commands ()+cfgSecret lensA lensB =   param "shared-secret" "<shared secret>" bytes setSecret >+ do     param "type" "<psk|eap|rsa|pin>" secretType' $ \sType -> do-      db    <- use dbContext-      ident <- use identity+      db     <- use dbContext+      ident1 <- use lensA+      ident2 <- use lensB       str   <- use secretStr       let secret = def { _ssData = str, _ssType = sType }-      ident' <- lift $ addSecret ident secret db-      identity .= ident'+      Result {..} <- lift $ writeSharedSecret secret db+      let secret' = secret { _ssId = Just lastModifiedKey }+      ident1' <- lift $ addSecret ident1 secret' db+      ident2' <- lift $ addSecret ident2 secret' db+      lensA .= ident1'+      lensB .= ident2'       return NoAction+    exitCmd         where setSecret str = do                 secretStr .= str                 return NewLevel -setIdentity :: Identity -> StateT AppState IO Action-setIdentity ident = do-  db <- use dbContext-  result <- runMaybeT $ findIdentityBySelf ident db-  identity .= fromMaybe ident result+flushIdentity :: StateT AppState IO Action+flushIdentity = do+  db    <- use dbContext+  ident <- use identity+  void . lift $ writeIdentity ident db+  return NoAction++setIdentity :: Lens' AppState Identity -> Identity -> StateT AppState IO Action+setIdentity lens ident = do+  db      <- use dbContext+  result  <- runMaybeT $ findIdentityBySelf ident db+  lens .= fromMaybe ident result+  when (isNothing result) newIdentity   return NewLevel+    where newIdentity =+            void . runMaybeT $ do+              fn <- MaybeT $ use flush+              lift fn -removeIdent :: Commands ()-removeIdent =+removeIdent :: Lens' AppState Identity -> Commands ()+removeIdent lens =   command "remove" "delete identity from DB and all associated secrets, etc" $ do     db <- use dbContext-    ident <- use identity+    ident <- use lens     void . runMaybeT $ removeIdentity ident db-    return NoAction+    lens .= def+    return $ LevelUp 2 -identityCmds :: Commands ()-identityCmds = do-  removeIdent-  cfgSecret-  exitCmd+identityCmds :: Lens' AppState Identity -> Commands ()+identityCmds lens = do+  removeIdent lens+  command "exit" "Exit identity configuration" (return $ LevelUp 3)+

@@ -63,19 +63,19 @@ cfgIKEConfigId :: Commands () cfgIKEConfigId =     param "ike-config-id" "<IKE configuration ID>" integer $ \val -> do-      ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= val+      ipsecSettings . getPeerConfig . peerCfgIKEConfigId .= Just val       flushIt  cfgLocalId :: Commands () cfgLocalId =-    param "local-identity-id" "<local identity>" string $ \str -> do-      ipsecSettings . getPeerConfig . peerCfgLocalId .= str+    param "local-identity-id" "<local identity>" integer $ \val -> do+      ipsecSettings . getPeerConfig . peerCfgLocalId .= Just val       flushIt  cfgRemoteId :: Commands () cfgRemoteId =-    param "remote-identity-id" "<remote identity>" string $ \str -> do-      ipsecSettings . getPeerConfig . peerCfgRemoteId .= str+    param "remote-identity-id" "<remote identity>" integer $ \val -> do+      ipsecSettings . getPeerConfig . peerCfgRemoteId .= Just val       flushIt  cfgCertPolicy :: Commands ()@@ -209,8 +209,8 @@     putStrLn $ "==================================";     putStrLn $ "IKE version:     " ++ show _peerCfgIKEVersion     putStrLn $ "IKE config ID:   " ++ show _peerCfgIKEConfigId-    putStrLn $ "Local identity:  " ++ unpack _peerCfgLocalId-    putStrLn $ "Remote identity: " ++ unpack _peerCfgRemoteId+    putStrLn $ "Local identity:  " ++ show _peerCfgLocalId+    putStrLn $ "Remote identity: " ++ show _peerCfgRemoteId     putStrLn $ "Cert. policy:    " ++ nameOf _peerCfgCertPolicy     putStrLn $ "Unique Ids:      " ++ nameOf _peerCfgUniqueIds     putStrLn $ "Auth method:     " ++ nameOf _peerCfgAuthMethod

@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TemplateHaskell     #-} {- | Module: StrongSwan.SQL Description: Interface Library for strongSwan (My)SQL backend@@ -133,11 +134,11 @@                         ) where  import Control.Concurrent.MVar      (MVar, newMVar, withMVar)-import Control.Lens                 ((^.), (.=), makeLenses, use)+import Control.Lens                 (Lens', (^.), (.=), makeLenses, use) import Control.Monad                (mapM_, void, when) import Control.Monad.IO.Class       (MonadIO) import Control.Monad.Trans.Maybe    (MaybeT(..), runMaybeT)-import Control.Monad.State.Strict   (MonadTrans, StateT, execStateT, get, lift)+import Control.Monad.State.Strict   (StateT, execStateT, get, lift) import Data.ByteString.Char8        (pack, unpack) import Data.Default                 (Default(..)) import Data.Maybe                   (catMaybes, isNothing, isJust, fromJust, listToMaybe)@@ -253,17 +254,25 @@ writeIPSecSettings' = do   unlinkConfig -  use getIKEConfig >>= inContext writeIKEConfig >>= setId (getIKEConfig . ikeId)+  use getIKEConfig >>= lift . writeIKEConfig' >>= setId (getIKEConfig . ikeId)   name             <- use getIPSecCfgName   ikeCfgId         <- use (getIKEConfig . ikeId) -  getPeerConfig . peerCfgIKEConfigId .= fromJust ikeCfgId+  localIdent  <- saveIdent getLocalIdentity+  remoteIdent <- saveIdent getRemoteIdentity -  use getChildSAConfig         >>= inContext writeChildSAConfig   >>= setId (getChildSAConfig. childSAId)-  use getPeerConfig            >>= inContext writePeerConfig      >>= setId (getPeerConfig . peerCfgId)-  use getLocalTrafficSelector  >>= inContext writeTrafficSelector >>= setId (getLocalTrafficSelector . tsId)-  use getRemoteTrafficSelector >>= inContext writeTrafficSelector >>= setId (getRemoteTrafficSelector . tsId)+  let localId  = getIdentityId localIdent+      remoteId = getIdentityId remoteIdent +  getPeerConfig . peerCfgIKEConfigId .= ikeCfgId+  getPeerConfig . peerCfgLocalId     .= localId+  getPeerConfig . peerCfgRemoteId    .= remoteId++  use getChildSAConfig         >>= lift . writeChildSAConfig'   >>= setId (getChildSAConfig. childSAId)+  use getPeerConfig            >>= lift . writePeerConfig'      >>= setId (getPeerConfig . peerCfgId)+  use getLocalTrafficSelector  >>= lift . writeTrafficSelector' >>= setId (getLocalTrafficSelector . tsId)+  use getRemoteTrafficSelector >>= lift . writeTrafficSelector' >>= setId (getRemoteTrafficSelector . tsId)+   ipsec <- get    SQL.OK {..} <-@@ -274,11 +283,26 @@                                        ipsec ^. getPeerConfig . peerCfgId,                                        ipsec ^. getIKEConfig . ikeId,                                        ipsec ^. getLocalTrafficSelector . tsId,-                                       ipsec ^. getRemoteTrafficSelector . tsId])+                                       ipsec ^. getRemoteTrafficSelector . tsId,+                                       localId,+                                       remoteId])   when (okAffectedRows /= 1) $ lift . failure $ FailedOperation ("createIPSec " <> name)   linkConfig     where setId lens Result {..} = lens .= Just lastModifiedKey +saveIdent :: (Failable m, MonadIO m, ?context::Context)+                  => Lens' IPSecSettings Identity+                  -> StateT IPSecSettings m Identity+saveIdent lens = do+  ident <- use lens+  result <- runMaybeT $ findIdentityBySelf' ident+  maybe (newIdentity ident) return result+    where newIdentity ident = do+            Result {..} <- lift $ writeIdentity' ident+            let ident' = setIdentityId ident lastModifiedKey+            lens .= ident'+            return ident'+ -- | Search for an IPsec connection configuration by its unique name. Take note of the 'Failable' context, -- which means that unless it is desired that this function throws an asynchronous exception upon not finding -- a configuration, you probably want to run this inside a monadic transformer such as 'MaybeT' or 'ExceptT'@@ -290,18 +314,23 @@               SQL.queryStmt conn_ findIPSecStmt [toSQL . toVarChar $ Just name]           listToMaybe <$> Stream.toList stream   maybe (failure . NotFound $ "IPSecSettings " <> name) mkIPSecSettings xs-    where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId] = do-            childCfg <- findChildSAConfig (sql2Int childCfgId) context-            peerCfg  <- findPeerConfig (sql2Int peerId) context-            ikeCfg   <- findIKEConfig (sql2Int ikeCfgId) context-            lTS      <- findTrafficSelector (sql2Int lTSId) context-            rTS      <- findTrafficSelector (sql2Int rTSId) context+    where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId, lId, rId] = do+            let ?context = context+            childCfg <- findChildSAConfig'   $ sql2Int childCfgId+            peerCfg  <- findPeerConfig'      $ sql2Int peerId+            ikeCfg   <- findIKEConfig'       $ sql2Int ikeCfgId+            lTS      <- findTrafficSelector' $ sql2Int lTSId+            rTS      <- findTrafficSelector' $ sql2Int rTSId+            localId  <- findIdentity'        $ sql2Int lId+            remoteId <- findIdentity'        $ sql2Int rId             return IPSecSettings { _getIPSecCfgName          = fromJust . fromVarChar $ fromSQL cfgName,                                    _getChildSAConfig         = childCfg,                                    _getPeerConfig            = peerCfg,                                    _getIKEConfig             = ikeCfg,                                    _getLocalTrafficSelector  = lTS,-                                   _getRemoteTrafficSelector = rTS }+                                   _getRemoteTrafficSelector = rTS,+                                   _getLocalIdentity         = localId,+                                   _getRemoteIdentity        = remoteId }           mkIPSecSettings vs =             failure $ SQLValuesMismatch ("IPSecSettings " ++ Text.unpack name) (show vs)           sql2Int = fromInt . fromSQL@@ -320,31 +349,25 @@         addTrafficSelector childCfgId lTS LocalTS         addTrafficSelector childCfgId rTS RemoteTS         peerId  <- MaybeT . use $ getPeerConfig . peerCfgId-        lift $ inContext writePeer2ChildConfig Peer2ChildConfig {-                                                   p2cPeerCfgId  = peerId,-                                                   p2cChildCfgId = childCfgId-                                               }+        writePeer2ChildConfig' Peer2ChildConfig {p2cPeerCfgId  = peerId, p2cChildCfgId = childCfgId }             where addTrafficSelector childId TrafficSelector {..} kind                     | isJust _tsId =-                        void . lift $ inContext writeChild2TSConfig+                        void $ writeChild2TSConfig'                           Child2TSConfig { c2tsChildCfgId           = childId,                                            c2tsTrafficSelectorCfgId = fromJust _tsId,                                            c2tsTrafficSelectorKind  = kind }                     | otherwise =                         return () -inContext :: (?context::Context, Failable m, MonadTrans t) => (a -> Context -> m b) -> a -> t m b-inContext f x = lift $ f x ?context- unlinkConfig :: (Failable m, MonadIO m, ?context::Context) => StateT IPSecSettings m () unlinkConfig = do     void . runMaybeT $ do         childCfgId <- MaybeT . use $ getChildSAConfig . childSAId-        void . lift $ inContext deleteChild2TSConfig childCfgId-        void . lift $ inContext deleteChildSAConfig childCfgId+        void $ deleteChild2TSConfig' childCfgId+        void $ deleteChildSAConfig' childCfgId         peerId  <- MaybeT . use $ getPeerConfig . peerCfgId-        void . lift $ inContext (deletePeer2ChildConfig peerId) childCfgId-        lift $ inContext deletePeerConfig peerId+        void $ deletePeer2ChildConfig' peerId childCfgId+        void $ deletePeerConfig' peerId      use getLocalTrafficSelector  >>= removeTrafficSelector     use getRemoteTrafficSelector >>= removeTrafficSelector@@ -353,7 +376,7 @@      void . runMaybeT $ do         ikeCfgId <- MaybeT . use $ getIKEConfig . ikeId-        lift $ inContext deleteIKEConfig ikeCfgId+        deleteIKEConfig' ikeCfgId      void . lift . failableIO . withMVar ?context $       \Context_{prepared_ = PreparedStatements{..}, ..} ->@@ -367,7 +390,7 @@       where removeTrafficSelector sel =               void . runMaybeT $ do                 tsCfgId <- MaybeT . return $ _tsId sel-                lift $ inContext deleteTrafficSelector tsCfgId+                deleteTrafficSelector' tsCfgId  -- | Adds a shared secret to a given identity. If the identity doesn't exist it will get created. -- If the identity already exists and it already has a secret of the same type, it will be overwritten.@@ -418,6 +441,9 @@     where writeChildSAConfig'' context@Context_ { prepared_ = PreparedStatements {..}} =             writeRow context updateChildSAStmt createChildSAStmt _childSAId cfg +writeChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => ChildSAConfig -> m (Result Int)+writeChildSAConfig' = flip writeChildSAConfig ?context+ findChildSAConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [ChildSAConfig] findChildSAConfigByName name = retrieveRows findChildSAByNameStmt [toSQL . toVarChar $ Just name] @@ -426,33 +452,51 @@   justOne ("Child SA " <> Text.pack (show iD)) =<<     retrieveRows findChildSAStmt [toSQL $ toInt iD] context +findChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m ChildSAConfig+findChildSAConfig' = flip findChildSAConfig ?context+ deleteChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)-deleteChildSAConfig iD = withContext deleteChildSAConfig'-    where deleteChildSAConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deleteChildSAConfig iD = withContext deleteChildSAConfig''+    where deleteChildSAConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteChildSAStmt [toSQL $ toInt iD]             return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteChildSAConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)+deleteChildSAConfig' = flip deleteChildSAConfig ?context+ writeIKEConfig :: (Failable m, MonadIO m) => IKEConfig -> Context -> m (Result Int) writeIKEConfig cfg = withContext writeIKEConfig''     where writeIKEConfig'' context@Context_ { prepared_ = PreparedStatements {..}, ..} =             writeRow context updateIKEStmt createIKEStmt _ikeId cfg +writeIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => IKEConfig -> m (Result Int)+writeIKEConfig' = flip writeIKEConfig ?context+ findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig findIKEConfig iD context =   justOne ("IKEConfig " <> Text.pack (show iD)) =<<     retrieveRows findIKEStmt [toSQL $ toInt iD] context +findIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m IKEConfig+findIKEConfig' = flip findIKEConfig ?context+ deleteIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)-deleteIKEConfig iD = withContext deleteIKEConfig'-    where deleteIKEConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deleteIKEConfig iD = withContext deleteIKEConfig''+    where deleteIKEConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteIKEStmt [toSQL $ toInt iD]             return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteIKEConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)+deleteIKEConfig' = flip deleteIKEConfig ?context+ writePeerConfig :: (Failable m, MonadIO m) => PeerConfig -> Context -> m (Result Int) writePeerConfig cfg = withContext writePeerConfig''     where writePeerConfig'' context@Context_ { prepared_ = PreparedStatements {..} } =             writeRow context updatePeerStmt createPeerStmt _peerCfgId cfg +writePeerConfig' :: (Failable m, MonadIO m, ?context::Context) => PeerConfig -> m (Result Int)+writePeerConfig' = flip writePeerConfig ?context+ findPeerConfigByName :: (Failable m, MonadIO m) => Text -> Context -> m [PeerConfig] findPeerConfigByName name = retrieveRows findPeerByNameStmt [toSQL . toVarChar $ Just name] @@ -461,46 +505,67 @@   justOne ("PeerConfig " <> Text.pack (show iD)) =<<     retrieveRows findPeerStmt [toSQL $ toInt iD] context +findPeerConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m PeerConfig+findPeerConfig' = flip findPeerConfig ?context+ deletePeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)-deletePeerConfig iD = withContext deletePeerConfig'-    where deletePeerConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deletePeerConfig iD = withContext deletePeerConfig''+    where deletePeerConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deletePeerStmt [toSQL $ toInt iD]             return Result { lastModifiedKey = okLastInsertID, response = ok } +deletePeerConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)+deletePeerConfig' = flip deletePeerConfig ?context+ writePeer2ChildConfig :: (Failable m, MonadIO m) => Peer2ChildConfig -> Context -> m (Result (Int, Int)) writePeer2ChildConfig cfg@Peer2ChildConfig {..} = withContext writeP2CConfig     where writeP2CConfig Context_ { prepared_ = PreparedStatements {..}, .. } = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ createP2CStmt $ toValues cfg             return Result { lastModifiedKey = (p2cPeerCfgId, p2cChildCfgId), response = ok } +writePeer2ChildConfig' :: (Failable m, MonadIO m, ?context::Context) => Peer2ChildConfig -> m (Result (Int, Int))+writePeer2ChildConfig' = flip writePeer2ChildConfig ?context+ findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig findPeer2ChildConfig peerId childId context =   justOne ("Peer2Child " <> Text.pack (show peerId) <> " - " <> Text.pack (show childId)) =<<     retrieveRows findP2CStmt (toSQL.toInt <$> [peerId, childId]) context  deletePeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Result (Int, Int))-deletePeer2ChildConfig peerId childId  = withContext deletePeer2ChildConfig'-    where deletePeer2ChildConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deletePeer2ChildConfig peerId childId  = withContext deletePeer2ChildConfig''+    where deletePeer2ChildConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteP2CStmt $                                 toSQL . toInt <$> [peerId, childId]             return Result { lastModifiedKey = (peerId, childId) , response = ok } +deletePeer2ChildConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> Int -> m (Result (Int, Int))+deletePeer2ChildConfig' peerId = flip (deletePeer2ChildConfig peerId) ?context+ writeTrafficSelector :: (Failable m, MonadIO m) => TrafficSelector -> Context -> m (Result Int) writeTrafficSelector ts = withContext writeTS     where writeTS context@Context_ { prepared_ = PreparedStatements {..}, .. } =             writeRow context updateTSStmt createTSStmt _tsId ts +writeTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => TrafficSelector -> m (Result Int)+writeTrafficSelector' = flip writeTrafficSelector ?context+ deleteTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)-deleteTrafficSelector iD = withContext deleteTrafficSelector'-    where deleteTrafficSelector' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deleteTrafficSelector iD = withContext deleteTrafficSelector''+    where deleteTrafficSelector'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteTSStmt [toSQL $ toInt iD]             return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)+deleteTrafficSelector' = flip deleteTrafficSelector ?context+ findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector findTrafficSelector iD context =   justOne ("TrafficSelector " <> Text.pack (show iD)) =<<     retrieveRows findTSStmt [toSQL $ toInt iD] context +findTrafficSelector' :: (Failable m, MonadIO m, ?context::Context) => Int -> m TrafficSelector+findTrafficSelector' = flip findTrafficSelector ?context+ writeChild2TSConfig :: (Failable m, MonadIO m) => Child2TSConfig -> Context -> m (Result (Int, Int)) writeChild2TSConfig cfg@Child2TSConfig {..} = withContext writeChild2TSConfig''     where writeChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, .. } = do@@ -513,24 +578,36 @@           sqlValues = toValues cfg           selector  = toSQL . toInt <$> [c2tsChildCfgId, c2tsTrafficSelectorCfgId] +writeChild2TSConfig' :: (Failable m, MonadIO m, ?context::Context) => Child2TSConfig -> m (Result (Int, Int))+writeChild2TSConfig' = flip writeChild2TSConfig ?context+ lookupChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m [Child2TSConfig] lookupChild2TSConfig iD = retrieveRows findC2TSStmt [toSQL $ toInt iD]  deleteChild2TSConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Result Int)-deleteChild2TSConfig iD = withContext deleteChild2TSConfig'-    where deleteChild2TSConfig' Context_ { prepared_ = PreparedStatements {..}, ..} = do+deleteChild2TSConfig iD = withContext deleteChild2TSConfig''+    where deleteChild2TSConfig'' Context_ { prepared_ = PreparedStatements {..}, ..} = do             ok@SQL.OK {..} <- SQL.executeStmt conn_ deleteC2TSStmt [toSQL $ toInt iD]             return Result { lastModifiedKey = okLastInsertID, response = ok } +deleteChild2TSConfig' :: (Failable m, MonadIO m, ?context::Context) => Int -> m (Result Int)+deleteChild2TSConfig' = flip deleteChild2TSConfig ?context+ writeIdentity :: (Failable m, MonadIO m) => Identity -> Context -> m (Result Int) writeIdentity identity = withContext writeIdentity''     where writeIdentity'' context@Context_ { prepared_ = PreparedStatements {..}, ..} =             writeRow context updateIdentityStmt createIdentityStmt getIdentityId identity +writeIdentity' :: (Failable m, MonadIO m, ?context::Context) => Identity -> m (Result Int)+writeIdentity' = flip writeIdentity ?context+ findIdentity :: (Failable m, MonadIO m) => Int -> Context -> m Identity findIdentity iD context =   justOne ("findIdentity" <> Text.pack (show iD)) =<<     retrieveRows findIdentityStmt [toSQL $ toInt iD] context++findIdentity' :: (Failable m, MonadIO m, ?context::Context ) => Int -> m Identity+findIdentity' = flip findIdentity ?context  findIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m Identity findIdentityBySelf identity context =

@@ -1,20 +1,25 @@ {-# LANGUAGE DataKinds            #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}  module StrongSwan.SQL.Encoding where  import Control.Exception        (throw)+import Control.Lens             (over, each) import Data.ASN1.BinaryEncoding (DER(..)) import Data.ASN1.Encoding       (encodeASN1', decodeASN1') import Data.Bifunctor           (second) import Data.ByteString.Char8    (ByteString, unpack) import Data.Maybe               (fromJust)+import Data.Text                (Text) import Data.Word                (Word8) import Numeric                  (showHex) import StrongSwan.SQL.Types+import Text.Read                (readMaybe)  import qualified Data.ByteString     as B+import qualified Data.Text           as T import qualified Database.MySQL.Base as SQL  class SQLRow a where@@ -58,10 +63,10 @@ fromId = return . fromInt . fromSQL  instance SQLRow Identity where-    toValues (AnyID _)                = [toSQL $ toTinyInt (0::Word8),  toSQL $ toVarBinary "%any"]+    toValues (AnyID _)                = [toSQL $ toTinyInt (0::Word8),  toSQL $ toVarBinary ("%any" :: String)]     toValues (IPv4AddrID _ v4)        = [toSQL $ toTinyInt (1::Word8),  toSQL $ toVarBinary v4]     toValues (NameID _ str)           = [toSQL $ toTinyInt (2::Word8),  toSQL $ toVarBinary str]-    toValues (EmailID _ local domain) = [toSQL $ toTinyInt (3::Word8),  toSQL $ toVarBinary (local ++ '@':domain)]+    toValues (EmailID _ local domain) = [toSQL $ toTinyInt (3::Word8),  toSQL $ toVarBinary (local <> "@" <> domain)]     toValues (IPv6AddrID _ v6)        = [toSQL $ toTinyInt (5::Word8),  toSQL $ toVarBinary v6]     toValues (ASN1ID _ elements)      = [toSQL $ toTinyInt (9::Word8),  toSQL $ toVarBinary (encodeASN1' DER elements)]     toValues (OpaqueID _ bytes)       = [toSQL $ toTinyInt (11::Word8), toSQL $ toVarBinary bytes]@@ -74,8 +79,8 @@     fromValues [iD, SQL.MySQLInt8U 9, v] = ASN1ID     (fromId iD) . either throw id . decodeASN1' DER . fromVarBinary $ fromSQL v     fromValues v                         = throw $ SQLValuesMismatch "Identity" (show v) -parseEmail :: ByteString -> (String, String)-parseEmail = second (drop 1) . span (/= '@') . unpack+parseEmail :: ByteString -> (Text, Text)+parseEmail str = over each T.pack . second (drop 1) $ span (/= '@') $ unpack str  instance SQLRow IKEConfig where     toValues IKEConfig {..} = [@@ -142,13 +147,19 @@                       }     fromValues xs = throw $ SQLValuesMismatch "ChildSAConfig" (show xs) +iDToVarChar :: Maybe Int -> SQL.MySQLValue+iDToVarChar = toSQL . toVarChar . (>>= return . T.pack . show)++varCharToId :: SQL.MySQLValue -> Maybe Int+varCharToId = (readMaybe . T.unpack =<<) . fromVarChar . fromSQL+ instance SQLRow PeerConfig where     toValues PeerConfig {..} = [         toSQL . toVarChar  $ Just _peerCfgName,         toSQL $ toTinyInt  _peerCfgIKEVersion,-        toSQL $ toInt      _peerCfgIKEConfigId,-        toSQL . toVarChar  $ Just _peerCfgLocalId,-        toSQL . toVarChar  $ Just _peerCfgRemoteId,+        toSQL . toInt      $ fromJust _peerCfgIKEConfigId,+        iDToVarChar _peerCfgLocalId,+        iDToVarChar _peerCfgRemoteId,         toSQL $ toTinyInt  _peerCfgCertPolicy,         toSQL $ toTinyInt  _peerCfgUniqueIds,         toSQL $ toTinyInt  _peerCfgAuthMethod,@@ -193,9 +204,9 @@                            _peerCfgId          =  return . fromInt $ fromSQL iD,                            _peerCfgName        =  fromJust . fromVarChar $ fromSQL name,                            _peerCfgIKEVersion  =  fromTinyInt $ fromSQL ikeVersion,-                           _peerCfgIKEConfigId =  fromInt $ fromSQL ikeConfig,-                           _peerCfgLocalId     =  fromJust  . fromVarChar $ fromSQL localId,-                           _peerCfgRemoteId    =  fromJust  . fromVarChar $ fromSQL remoteId,+                           _peerCfgIKEConfigId =  return . fromInt $ fromSQL ikeConfig,+                           _peerCfgLocalId     =  varCharToId localId,+                           _peerCfgRemoteId    =  varCharToId remoteId,                            _peerCfgCertPolicy  =  fromTinyInt  $ fromSQL certPolicy,                            _peerCfgUniqueIds   =  fromTinyInt  $ fromSQL uniqueIds,                            _peerCfgAuthMethod  =  fromTinyInt  $ fromSQL authMethod,

@@ -282,17 +282,16 @@ deleteSSIdentityStatement = "DELETE FROM shared_secret_identity WHERE shared_secret = ? AND identity = ?;"  createIPSecTableStatement :: SQL.Query-createIPSecTableStatement = "CREATE TABLE `ipsec_configs` (`name` varchar(64) NOT NULL, `child_cfg` int(10) unsigned NOT NULL, `peer_cfg` int(10) unsigned NOT NULL, `ike_cfg` int(10) unsigned NOT NULL, `local_ts` int(10) unsigned NOT NULL, `remote_ts` int(10) unsigned NOT NULL, PRIMARY KEY (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;"+createIPSecTableStatement = "CREATE TABLE `ipsec_configs` (`name` varchar(64) NOT NULL, `child_cfg` int(10) unsigned NOT NULL, `peer_cfg` int(10) unsigned NOT NULL, `ike_cfg` int(10) unsigned NOT NULL, `local_ts` int(10) unsigned NOT NULL, `remote_ts` int(10) unsigned NOT NULL, `local_id` int(10) unsigned NOT NULL, `remote_id` int(10) unsigned NOT NULL, PRIMARY KEY (`name`)) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci;"  createIPSecStatement :: SQL.Query-createIPSecStatement = "INSERT INTO ipsec_configs (name, child_cfg, peer_cfg, ike_cfg, local_ts, remote_ts) VALUES (?, ?, ?, ?, ?, ?);"+createIPSecStatement = "INSERT INTO ipsec_configs (name, child_cfg, peer_cfg, ike_cfg, local_ts, remote_ts, local_id, remote_id) VALUES (?, ?, ?, ?, ?, ?, ?, ?);"  findIPSecStatement :: SQL.Query findIPSecStatement = "SELECT * FROM ipsec_configs WHERE name = ?;"  deleteIPSecStatement :: SQL.Query deleteIPSecStatement = "DELETE FROM ipsec_configs WHERE name = ?;"-  initializeWith :: (Failable m, MonadIO m, ?conn::SQL.MySQLConn)                 => SQL.Query

@@ -19,6 +19,7 @@ import Network.Socket           (PortNumber)  import qualified Data.ByteString     as B+import qualified Data.Text           as T import qualified Database.MySQL.Base as SQL  data Error = UnknownCharacterEncoding Int@@ -69,12 +70,12 @@  data Identity = AnyID (Maybe Int)                 -- Matches any ID (/%any/)               | IPv4AddrID (Maybe Int) IPv4       -- IPv4 Address-              | NameID (Maybe Int) String         -- Fully qualified Domain Name-              | EmailID (Maybe Int) String String -- ^ RFC 822 Email Address /mailbox/@/domain/+              | NameID (Maybe Int) Text           -- Fully qualified Domain Name+              | EmailID (Maybe Int) Text Text -- ^ RFC 822 Email Address /mailbox/@/domain/               | IPv6AddrID (Maybe Int) IPv6       -- IPv6 Address               | ASN1ID (Maybe Int) [ASN1]         -- DER encoded ASN.1 distinguished name               | OpaqueID (Maybe Int) ByteString   -- Opaque octet string as ID-              deriving Show+              deriving (Eq, Show)  getIdentityId :: Identity -> Maybe Int getIdentityId (AnyID iD)        = iD@@ -196,6 +197,10 @@     toVarBinary = VarBinary . pack     fromVarBinary (VarBinary bytes) = unpack bytes +instance VarBinary Text where+    toVarBinary = VarBinary . pack . T.unpack+    fromVarBinary (VarBinary bytes) = T.pack $ unpack bytes+ instance VarBinary ByteString where     toVarBinary = VarBinary     fromVarBinary (VarBinary bytes) = bytes@@ -416,9 +421,9 @@                       _peerCfgId          :: Maybe Int,                       _peerCfgName        :: Text,                       _peerCfgIKEVersion  :: Word8,-                      _peerCfgIKEConfigId :: Int,-                      _peerCfgLocalId     :: Text,-                      _peerCfgRemoteId    :: Text,+                      _peerCfgIKEConfigId :: Maybe Int,+                      _peerCfgLocalId     :: Maybe Int,+                      _peerCfgRemoteId    :: Maybe Int,                       _peerCfgCertPolicy  :: CertPolicy,                       _peerCfgUniqueIds   :: Bool,                       _peerCfgAuthMethod  :: AuthMethod,@@ -443,9 +448,9 @@             _peerCfgId          = Nothing,             _peerCfgName        = "",             _peerCfgIKEVersion  = 2,-            _peerCfgIKEConfigId = maxBound,-            _peerCfgLocalId     = "%any",-            _peerCfgRemoteId    = "%any",+            _peerCfgIKEConfigId = Nothing,+            _peerCfgLocalId     = Nothing,+            _peerCfgRemoteId    = Nothing,             _peerCfgCertPolicy  = SendIfAsked,             _peerCfgUniqueIds   = True,             _peerCfgAuthMethod  = PubKey,@@ -565,9 +570,10 @@                         _getChildSAConfig         :: ChildSAConfig,                         _getPeerConfig            :: PeerConfig,                         _getLocalTrafficSelector  :: TrafficSelector,-                        _getRemoteTrafficSelector :: TrafficSelector+                        _getRemoteTrafficSelector :: TrafficSelector,+                        _getLocalIdentity         :: Identity,+                        _getRemoteIdentity        :: Identity                       } deriving (Eq, Show) - instance Default IPSecSettings where-    def = IPSecSettings "" def def def def def+    def = IPSecSettings "" def def def def def def def

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 60f2148a71514af362ac55216959613c573fd36159eb6446d93d1a2bf439a397+-- hash: 8e901b023b4ac4274a0d123daf925a7dbcda18addb33e2bf88f710374ce1813d  name:           strongswan-sql-version:        1.0.1.0+version:        1.1.0.0 synopsis:       Interface library for strongSwan SQL backend description:    Interface library and companion CLI tool to configure strongSwan IPsec over MySQL backend category:       Console, Library, Network APIs, SQL