diff --git a/src/StrongSwan/SQL.hs b/src/StrongSwan/SQL.hs --- a/src/StrongSwan/SQL.hs +++ b/src/StrongSwan/SQL.hs @@ -66,6 +66,14 @@ -- * __Traffic Selectors__: These are independent values linked to a Child SA by means of a -- 'Child2TSConfig' type. -- +-- The manual API consists mainly of one @writeXXX@, @findXXX@, @lookupXXX@ and a @deleteXXX@ +-- function for each object to be stored as an SQL row in its respective table. The @writeXXX@ +-- functions trigger an insertion or an update of the given row in the SQL database depending +-- on whether the given object owns a key already or not (usually an ID). The search functions +-- (@findXXX@ and @lookupXXX@) perform a search in the DB for the given key. The difference is +-- that a @findXXX@ will trigger a 'failure' in the 'Failable' context with a 'NotFound' error +-- and that the @lookupXXX@ functions simply return 'Nothing' if a key doesn't exist in the DB +-- (they can of course trigger other errors in the Failable context) writeChild2TSConfig, writeChildSAConfig, @@ -88,6 +96,14 @@ findSharedSecret, findSSIdentity, findTrafficSelector, + lookupChildSAConfig, + lookupIdentity, + lookupIdentityBySelf, + lookupIKEConfig, + lookupPeerConfig, + lookupPeer2ChildConfig, + lookupSharedSecret, + lookupTrafficSelector, deleteChild2TSConfig, deleteChildSAConfig, deleteIdentity, @@ -114,6 +130,7 @@ CertPolicy(..), Context, EAPType(..), + Error(..), Identity(..), IKEConfig(..), IPSecSettings(..), @@ -237,10 +254,9 @@ 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 +justOne :: (Failable m, Show a) => Text -> [a] -> m (Maybe a) +justOne tag xs@(_:_:_) = failure . MultipleResults tag $ show xs +justOne _ xs = return $ listToMaybe xs -- | 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 @@ -303,17 +319,26 @@ lens .= ident' return ident' +notFound :: (Failable m, MonadIO m) => Text -> Maybe a -> m a +notFound txt = maybe (failure $ NotFound txt) return + -- | 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 +findIPSecSettings name context = notFound ("IPSecSettings" <> name) =<< lookupIPSecSettings name context + +-- | Lookup an IPsec connection configuration by its unique name. Returns @Nothing@ if the connection +-- is not found. Other errors are reported according to the Failable context the function +-- is called on ('MaybeT', 'ExceptT', 'IO', etc). +lookupIPSecSettings :: (Failable m, MonadIO m) => Text -> Context -> m (Maybe IPSecSettings) +lookupIPSecSettings name context = runMaybeT $ do + xs <- MaybeT . 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 + mkIPSecSettings xs where mkIPSecSettings [cfgName, childCfgId, peerId, ikeCfgId, lTSId, rTSId, lId, rId] = do let ?context = context childCfg <- findChildSAConfig' $ sql2Int childCfgId @@ -449,6 +474,10 @@ findChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m ChildSAConfig findChildSAConfig iD context = + notFound ("ChildSA" <> Text.pack (show iD)) =<< lookupChildSAConfig iD context + +lookupChildSAConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe ChildSAConfig) +lookupChildSAConfig iD context = justOne ("Child SA " <> Text.pack (show iD)) =<< retrieveRows findChildSAStmt [toSQL $ toInt iD] context @@ -474,6 +503,10 @@ findIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m IKEConfig findIKEConfig iD context = + notFound ("IKEConfig " <> Text.pack (show iD)) =<< lookupIKEConfig iD context + +lookupIKEConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe IKEConfig) +lookupIKEConfig iD context = justOne ("IKEConfig " <> Text.pack (show iD)) =<< retrieveRows findIKEStmt [toSQL $ toInt iD] context @@ -502,6 +535,10 @@ findPeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m PeerConfig findPeerConfig iD context = + notFound ("PeerConfig " <> Text.pack (show iD)) =<< lookupPeerConfig iD context + +lookupPeerConfig :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe PeerConfig) +lookupPeerConfig iD context = justOne ("PeerConfig " <> Text.pack (show iD)) =<< retrieveRows findPeerStmt [toSQL $ toInt iD] context @@ -528,6 +565,10 @@ findPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m Peer2ChildConfig findPeer2ChildConfig peerId childId context = + notFound ("Peer2Child " <> Text.pack (show peerId)) =<< lookupPeer2ChildConfig peerId childId context + +lookupPeer2ChildConfig :: (Failable m, MonadIO m) => Int -> Int -> Context -> m (Maybe Peer2ChildConfig) +lookupPeer2ChildConfig peerId childId context = justOne ("Peer2Child " <> Text.pack (show peerId) <> " - " <> Text.pack (show childId)) =<< retrieveRows findP2CStmt (toSQL.toInt <$> [peerId, childId]) context @@ -560,6 +601,10 @@ findTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m TrafficSelector findTrafficSelector iD context = + notFound ("TrafficSelector " <> Text.pack (show iD)) =<< lookupTrafficSelector iD context + +lookupTrafficSelector :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe TrafficSelector) +lookupTrafficSelector iD context = justOne ("TrafficSelector " <> Text.pack (show iD)) =<< retrieveRows findTSStmt [toSQL $ toInt iD] context @@ -603,6 +648,10 @@ findIdentity :: (Failable m, MonadIO m) => Int -> Context -> m Identity findIdentity iD context = + notFound ("findIdentity" <> Text.pack (show iD)) =<< lookupIdentity iD context + +lookupIdentity :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe Identity) +lookupIdentity iD context = justOne ("findIdentity" <> Text.pack (show iD)) =<< retrieveRows findIdentityStmt [toSQL $ toInt iD] context @@ -611,6 +660,10 @@ findIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m Identity findIdentityBySelf identity context = + notFound ("findIdentityBySelf" <> Text.pack (show identity)) =<< lookupIdentityBySelf identity context + +lookupIdentityBySelf :: (Failable m, MonadIO m) => Identity -> Context -> m (Maybe Identity) +lookupIdentityBySelf identity context = justOne ("findIdentityBySelf" <> Text.pack (show identity)) =<< retrieveRows findIdentityBySelfStmt (toValues identity) context @@ -636,6 +689,10 @@ findSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m SharedSecret findSharedSecret iD context = + notFound ("SharedSecret" <> Text.pack (show iD)) =<< lookupSharedSecret iD context + +lookupSharedSecret :: (Failable m, MonadIO m) => Int -> Context -> m (Maybe SharedSecret) +lookupSharedSecret iD context = justOne ("SharedSecret" <> Text.pack (show iD)) =<< retrieveRows findSharedSecretStmt [toSQL . toInt $ iD] context diff --git a/strongswan-sql.cabal b/strongswan-sql.cabal --- a/strongswan-sql.cabal +++ b/strongswan-sql.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6f32d30a00fb61271491341c0c55cdade3033598fbb9b665676f78315947f5ae +-- hash: cd5f9b6d39a470e19052b77e99316e5bbbf3309eed049403673cca5170192a8f name: strongswan-sql -version: 1.2.0.0 +version: 1.2.1.0 synopsis: Interface library for strongSwan SQL backend description: Interface library and companion CLI tool to configure strongSwan IPsec over MySQL backend category: Console, Library, Network APIs, SQL