Merge pull request #264 from abbradar/master

Make runTLS{Client,Server}StartTLS general

network-conduit-tls/Data/Conduit/Network/TLS.hs

@@ -7,6 +7,7 @@
 module Data.Conduit.Network.TLS
     ( -- * Common
       ApplicationStartTLS
+    , GeneralApplicationStartTLS
       -- * Server
     , TLSConfig
     , tlsConfigBS
@@ -50,6 +51,7 @@ import Network.Socket.ByteString (sendAll)
 import Control.Exception (bracket)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Base (liftBase)
 import qualified Network.TLS.Extra as TLSExtra
 import Network.Socket (Socket)
 import qualified Data.ByteString as S
@@ -163,7 +165,9 @@ runTCPServerTLS TLSConfig{..} app = do
             app (tlsAppData ctx addr mlocal)
             TLS.bye ctx
 
-type ApplicationStartTLS = (AppData, (AppData -> IO ()) -> IO ()) -> IO ()
+type GeneralApplicationStartTLS m a = (AppData, (AppData -> m ()) -> m ()) -> m a
+
+type ApplicationStartTLS = GeneralApplicationStartTLS IO ()
 
 -- | Like 'runTCPServerTLS', but monad can be any instance of 'MonadBaseControl' 'IO'.
 --
@@ -187,17 +191,17 @@ runGeneralTCPServerTLS config app = liftBaseWith $ \run ->
 --    unless (abortTLS) $ startTls $ appDataTls -> do
 --      doSomethingSSL appDataTls
 --  @
-runTCPServerStartTLS :: TLSConfig -> ApplicationStartTLS -> IO ()
+runTCPServerStartTLS :: MonadBaseControl IO m => TLSConfig -> GeneralApplicationStartTLS m () -> m ()
 runTCPServerStartTLS TLSConfig{..} app = do
-    creds <- readCreds tlsCertData
+    creds <- liftBase $ readCreds tlsCertData
 
-    runTCPServerWithHandle settings (wrapApp creds)
+    liftBaseWith $ \run -> runTCPServerWithHandle settings (wrapApp creds run)
 
     where
       -- convert tls settings to regular conduit network ones
       settings = serverSettings tlsPort tlsHost  -- (const $ return () ) tlsNeedLocalAddr
 
-      wrapApp creds = clearapp
+      wrapApp creds run = clearapp
         where clearapp socket addr mlocal = let
                 -- setup app data for the clear part of the connection
                 clearData = AppData
@@ -214,11 +218,11 @@ runTCPServerStartTLS TLSConfig{..} app = do
                   }
                 -- wrap up the current connection with TLS
                 startTls = \app' -> do
-                  ctx <- serverHandshake socket creds
+                  ctx <- liftBase $ serverHandshake socket creds
                   app' (tlsAppData ctx addr mlocal)
-                  TLS.bye ctx
+                  liftBase $ TLS.bye ctx
                 in
-                 app (clearData, startTls)
+                 void $ run $ app (clearData, startTls)
 
 -- | Create an @AppData@ from an existing tls @Context@ value. This is a lower level function, allowing you to create a connection in any way you want.
 --
@@ -331,12 +335,12 @@ tlsClientConfig port host = TLSClientConfig
 -- | Run an application with the given configuration.
 --
 -- Since 1.0.2
-runTLSClient :: (MonadIO m, MonadBaseControl IO m)
+runTLSClient :: (MonadBaseControl IO m)
              => TLSClientConfig
              -> (AppData -> m a)
              -> m a
 runTLSClient TLSClientConfig {..} app = do
-    context <- maybe (liftIO NC.initConnectionContext) return tlsClientConnectionContext
+    context <- maybe (liftBase NC.initConnectionContext) return tlsClientConnectionContext
     let params = NC.ConnectionParams
             { NC.connectionHostname = S8.unpack tlsClientHost
             , NC.connectionPort = fromIntegral tlsClientPort
@@ -367,21 +371,20 @@ runTLSClient TLSClientConfig {..} app = do
 --   but provide also a call back to trigger a StartTLS handshake on the connection
 --
 -- Since 1.0.2
-runTLSClientStartTLS :: TLSClientConfig
-                     -> ApplicationStartTLS
-                     -> IO ()
+runTLSClientStartTLS :: (MonadBaseControl IO m)
+                     => TLSClientConfig
+                     -> GeneralApplicationStartTLS m a
+                     -> m a
 runTLSClientStartTLS TLSClientConfig {..} app = do
-    context <- maybe (liftIO NC.initConnectionContext) return tlsClientConnectionContext
+    context <- maybe (liftBase NC.initConnectionContext) return tlsClientConnectionContext
     let params = NC.ConnectionParams
             { NC.connectionHostname = S8.unpack tlsClientHost
             , NC.connectionPort = fromIntegral tlsClientPort
             , NC.connectionUseSecure = Nothing
             , NC.connectionUseSocks = tlsClientSockSettings
             }
-    control $ \run -> bracket
-        (NC.connectTo context params)
-        NC.connectionClose
-        (\conn -> run $ app (
+    liftBaseOp (bracket (NC.connectTo context params) NC.connectionClose)
+        (\conn -> app (
             AppData
             { appRead' = NC.connectionGetChunk conn
             , appWrite' = NC.connectionPut conn
@@ -395,7 +398,7 @@ runTLSClientStartTLS TLSClientConfig {..} app = do
 #endif
             }
             , \app' -> do
-                 NC.connectionSetSecure context conn tlsClientTLSSettings
+                 liftBase $ NC.connectionSetSecure context conn tlsClientTLSSettings
                  app' AppData
                    { appRead' = NC.connectionGetChunk conn
                    , appWrite' = NC.connectionPut conn

network-conduit-tls/network-conduit-tls.cabal

@@ -22,6 +22,7 @@ library
                     , conduit         >= 1.1
                     , network
                     , transformers
+                    , transformers-base
                     , cprng-aes
                     , connection
                     , monad-control