Move Data.Conduit.Tls functions to the Network.Xmpp.Tls module

pontarius-xmpp.cabal

@@ -57,8 +57,7 @@ Library
   Exposed-modules: Network.Xmpp
                  , Network.Xmpp.Internal
                  , Network.Xmpp.IM
-  Other-modules: Data.Conduit.Tls
+  Other-modules: Network.Xmpp.Concurrent
-               , Network.Xmpp.Concurrent
                , Network.Xmpp.Concurrent.Types
                , Network.Xmpp.Concurrent.Basic
                , Network.Xmpp.Concurrent.IQ

source/Data/Conduit/Tls.hs

@@ -1,81 +0,0 @@
-{-# Language NoMonomorphismRestriction #-}
-{-# OPTIONS_HADDOCK hide #-}
-module Data.Conduit.Tls
-       ( tlsinit
---       , conduitStdout
-       , module TLS
-       , module TLSExtra
-       )
-       where
-
-import           Control.Monad
-import           Control.Monad (liftM, when)
-import           Control.Monad.IO.Class
-
-import           Crypto.Random
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import           Data.Conduit
-import qualified Data.Conduit.Binary as CB
-import Data.IORef
-
-import           Network.TLS as TLS
-import           Crypto.Random.API
-import           Network.TLS.Extra as TLSExtra
-
-import           System.IO (Handle)
-
-client params gen backend  = do
-    contextNew backend params gen
-
-defaultParams = defaultParamsClient
-
-tlsinit :: (MonadIO m, MonadIO m1) =>
-        Bool
-     -> TLSParams
-     -> Backend
-     -> m ( Source m1 BS.ByteString
-          , Sink BS.ByteString m1 ()
-          , BS.ByteString -> IO ()
-          , Int -> m1 BS.ByteString
-          , Context
-          )
-tlsinit debug tlsParams backend = do
-    when debug . liftIO $ putStrLn "TLS with debug mode enabled"
-    gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source?
-    con <- client tlsParams gen backend
-    handshake con
-    let src = forever $ do
-            dt <- liftIO $ recvData con
-            when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)
-            yield dt
-    let snk = do
-            d <- await
-            case d of
-                Nothing -> return ()
-                Just x -> do
-                       sendData con (BL.fromChunks [x])
-                       when debug (liftIO $ putStr "out: " >>  BS.putStrLn x)
-                       snk
-    read <- liftIO $ mkReadBuffer (recvData con)
-    return ( src
-           , snk
-           , \s -> do
-               when debug (liftIO $ BS.putStrLn s)
-               sendData con $ BL.fromChunks [s]
-           , liftIO . read
-           , con
-           )
-
-mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
-mkReadBuffer read = do
-    buffer <- newIORef BS.empty
-    let read' n = do
-            nc <- readIORef buffer
-            bs <- if BS.null nc then read
-                                else return nc
-            let (result, rest) = BS.splitAt n bs
-            writeIORef buffer rest
-            return result
-    return read'

source/Network/Xmpp/Tls.hs

@@ -13,7 +13,6 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import           Data.Conduit
 import qualified Data.Conduit.Binary as CB
-import           Data.Conduit.Tls as TLS
 import           Data.Typeable
 import           Data.XML.Types
 
@@ -22,6 +21,11 @@ import           Network.Xmpp.Types
 
 import           Control.Concurrent.STM.TMVar
 
+import Data.IORef
+import Crypto.Random.API
+import Network.TLS
+import Network.TLS.Extra
+
 mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
                         , backendRecv = streamReceive con
                         , backendFlush = streamFlush con
@@ -61,20 +65,20 @@ cutBytes n = do
 starttlsE :: Element
 starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
 
-exampleParams :: TLS.TLSParams
+exampleParams :: TLSParams
-exampleParams = TLS.defaultParamsClient
+exampleParams = defaultParamsClient
-    { pConnectVersion    = TLS.TLS10
+    { pConnectVersion    = TLS10
-    , pAllowedVersions   = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
+    , pAllowedVersions   = [SSL3, TLS10, TLS11]
-    , pCiphers           = [TLS.cipher_AES128_SHA1]
+    , pCiphers           = [cipher_AES128_SHA1]
-    , pCompressions      = [TLS.nullCompression]
+    , pCompressions      = [nullCompression]
     , pUseSecureRenegotiation = False -- No renegotiation
     , onCertificatesRecv = \_certificate ->
-          return TLS.CertificateUsageAccept
+          return CertificateUsageAccept
     }
 
 -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
 -- restarts the stream.
-startTls :: TLS.TLSParams -> TMVar Stream -> IO (Either XmppFailure ())
+startTls :: TLSParams -> TMVar Stream -> IO (Either XmppFailure ())
 startTls params con = Ex.handle (return . Left . TlsError)
                       . flip withStream con
                       . runErrorT $ do
@@ -92,7 +96,7 @@ startTls params con = Ex.handle (return . Left . TlsError)
         Left e -> return $ Left e
         Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right ()
         Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure
-    (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con)
+    (raw, _snk, psh, read, ctx) <- lift $ tlsinit debug params (mkBackend con)
     let newHand = StreamHandle { streamSend = catchPush . psh
                                    , streamReceive = read
                                    , streamFlush = contextFlush ctx
@@ -102,3 +106,57 @@ startTls params con = Ex.handle (return . Left . TlsError)
     either (lift . Ex.throwIO) return =<< lift restartStream
     modify (\s -> s{streamState = Secured})
     return ()
+
+client params gen backend  = do
+    contextNew backend params gen
+
+defaultParams = defaultParamsClient
+
+tlsinit :: (MonadIO m, MonadIO m1) =>
+        Bool
+     -> TLSParams
+     -> Backend
+     -> m ( Source m1 BS.ByteString
+          , Sink BS.ByteString m1 ()
+          , BS.ByteString -> IO ()
+          , Int -> m1 BS.ByteString
+          , Context
+          )
+tlsinit debug tlsParams backend = do
+    when debug . liftIO $ putStrLn "TLS with debug mode enabled"
+    gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source?
+    con <- client tlsParams gen backend
+    handshake con
+    let src = forever $ do
+            dt <- liftIO $ recvData con
+            when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)
+            yield dt
+    let snk = do
+            d <- await
+            case d of
+                Nothing -> return ()
+                Just x -> do
+                       sendData con (BL.fromChunks [x])
+                       when debug (liftIO $ putStr "out: " >>  BS.putStrLn x)
+                       snk
+    read <- liftIO $ mkReadBuffer (recvData con)
+    return ( src
+           , snk
+           , \s -> do
+               when debug (liftIO $ BS.putStrLn s)
+               sendData con $ BL.fromChunks [s]
+           , liftIO . read
+           , con
+           )
+
+mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
+mkReadBuffer read = do
+    buffer <- newIORef BS.empty
+    let read' n = do
+            nc <- readIORef buffer
+            bs <- if BS.null nc then read
+                                else return nc
+            let (result, rest) = BS.splitAt n bs
+            writeIORef buffer rest
+            return result
+    return read'