Dmitry & others,
Attached is a diff implementing TLS support for haskell-xmpp, and
correcting a build failure.
The support is rough but it seems to work so far.
-- John
diff -durN -x '*~' -x Test.hs orig/haskell-xmpp-1.0/haskell-xmpp.cabal haskell-xmpp-1.0/haskell-xmpp.cabal
--- orig/haskell-xmpp-1.0/haskell-xmpp.cabal 2011-01-15 16:50:14.000000000 -0600
+++ haskell-xmpp-1.0/haskell-xmpp.cabal 2012-04-16 21:03:49.125224872 -0500
@@ -32,7 +32,7 @@
library
Hs-Source-Dirs: ./src
- Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.20.2, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string
+ Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.20.2 && < 1.21, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string, gnutls, bytestring
Exposed-modules: Network.XMPP
, Network.XMPP.Sasl
, Network.XMPP.Core
diff -durN -x '*~' -x Test.hs orig/haskell-xmpp-1.0/src/Network/XMPP/Concurrent.hs haskell-xmpp-1.0/src/Network/XMPP/Concurrent.hs
--- orig/haskell-xmpp-1.0/src/Network/XMPP/Concurrent.hs 2011-01-15 16:50:14.000000000 -0600
+++ haskell-xmpp-1.0/src/Network/XMPP/Concurrent.hs 2012-04-16 21:46:04.405285127 -0500
@@ -36,6 +36,8 @@
import Network.XMPP.XEP.Version
import Network.XMPP.IM.Presence
import Network.XMPP.Utils
+import qualified Network.Protocol.TLS.GNU as TLS
+import qualified Data.ByteString.Lazy.Char8 as BC8
import System.IO
@@ -54,7 +56,7 @@
liftIO $ forkIO $ runReaderT a (Thread in' out')
s <- get
liftIO $ forkIO $ loopWrite s out'
- liftIO $ forkIO $ connPersist (handle s)
+ liftIO $ forkIO $ connPersist (transport s)
loopRead in'
where
loopRead in' = loop $
@@ -105,10 +107,20 @@
else do
waitFor f
-connPersist :: Handle -> IO ()
-connPersist h = do
+connPersist :: Transport -> IO ()
+connPersist (HandleTransport h) = do
hPutStr h " "
putStrLn "<space added>"
threadDelay 30000000
- connPersist h
-
+ connPersist (HandleTransport h)
+connPersist (TLSTransport t) = do
+ r <- TLS.runTLS t $ do
+ TLS.putBytes (BC8.pack " ")
+ case r of
+ Left x -> fail (show x)
+ Right _ -> return ()
+ putStrLn "<space added>"
+ threadDelay 30000000
+ connPersist (TLSTransport t)
+
+
diff -durN -x '*~' -x Test.hs orig/haskell-xmpp-1.0/src/Network/XMPP/Core.hs haskell-xmpp-1.0/src/Network/XMPP/Core.hs
--- orig/haskell-xmpp-1.0/src/Network/XMPP/Core.hs 2011-01-15 16:50:14.000000000 -0600
+++ haskell-xmpp-1.0/src/Network/XMPP/Core.hs 2012-04-16 21:33:28.101267152 -0500
@@ -26,6 +26,9 @@
import Network.XMPP.JID
import Network.XMPP.IQ
import Network.XMPP.Utils
+import Text.XML.HaXml.Xtract.Parse (xtract)
+import qualified Network.Protocol.TLS.GNU as TLS
+
-- | Open connection to specified server and return `Stream' coming from it
initiateStream :: Handle
@@ -50,7 +53,48 @@
debug "Stream started"
--debug $ "Observing: " ++ render (P.content m)
- m <- xtractM "/stream:features/mechanisms/mechanism/-"
+
+ -- First, we read stream:features
+ sf_ <- xtractM "/stream:features"
+ let sf = case sf_ of
+ [] -> error "Did not get stream:features"
+ [x] -> x
+ x -> error "Got many stream:features"
+
+ -- Now, we look for starttls.
+ newsf <- case xtract id "/stream:features/starttls" sf of
+ [] -> do debug "Did not see starttls in features"
+ return sf
+ x -> do debug $ "Saw starttls: " ++ show x
+ out $ toContent $ ptag "starttls"
+ [xmlns "urn:ietf:params:xml:ns:xmpp-tls"]
+ []
+ nm <- nextM
+ case xtract id "/proceed" nm of
+ [] -> fail "Did not get proceed after starttls"
+ _ -> return ()
+ debug $ "Starting TLS"
+ session <- liftIO $ TLS.runClient (TLS.handleTransport h) $ do
+ TLS.setPriority [TLS.X509]
+ TLS.setCredentials =<< TLS.certificateCredentials
+ TLS.handshake
+ TLS.getSession
+ case session of
+ Left x -> fail (show x)
+ Right x -> do
+ debug $ "Got TLS session"
+ resetStreamTLS h x
+ debug $ "Stream reset"
+ out $ toContent $ stream Client server
+ startM
+ tlssf_ <- xtractM "/stream:features"
+ debug $ "Got new features"
+ return $ case tlssf_ of
+ [] -> error "Did not get stream:features"
+ [x] -> x
+ x -> error "Got many stream:features"
+
+ let m = xtract id "/stream:features/mechanisms/mechanism/-" newsf
let mechs = map getText m
debug $ "Mechanisms: " ++ show mechs
diff -durN -x '*~' -x Test.hs orig/haskell-xmpp-1.0/src/Network/XMPP/Stream.hs haskell-xmpp-1.0/src/Network/XMPP/Stream.hs
--- orig/haskell-xmpp-1.0/src/Network/XMPP/Stream.hs 2011-01-15 16:50:14.000000000 -0600
+++ haskell-xmpp-1.0/src/Network/XMPP/Stream.hs 2012-04-16 21:50:42.369291734 -0500
@@ -24,6 +24,7 @@
, withNewStream
, withStream
, resetStreamHandle
+ , resetStreamTLS
, getText
, getText_
, loopWithPlugins
@@ -49,18 +50,29 @@
import Network.XMPP.Types
import Network.XMPP.UTF8
+import qualified Network.Protocol.TLS.GNU as TLS
+import System.IO.Unsafe(unsafeInterleaveIO)
+import qualified Data.ByteString.Lazy.Char8 as BC8
+
-- For a definition of 'Stream' see Network.XMPP.Types.
-- In the beginning, all Stream buffers are empty, and by default it is bound to stdin.
-- Functions like 'openStreamTo' or 'openStreamViaProxyTo' could override this.
newStream :: Stream
-newStream = Stream { handle=stdin, idx=0, lexemes=[] }
+newStream = Stream { transport=HandleTransport stdin, idx=0, lexemes=[] }
-- Main 'workhorses' for Stream are 'out', 'nextM', 'peekM' and 'selectM':
-- | Sends message into Stream
out :: XmppMessage -> XmppStateT ()
-out xmpp = do h <- gets handle
- liftIO $ hPutXmpp h xmpp
+out xmpp = do h <- gets transport
+ case h of
+ HandleTransport h -> liftIO $ hPutXmpp h xmpp
+ TLSTransport t -> do let str = renderXmpp xmpp
+ liftIO $ putStrLn $ "TLS Sending: " ++ str
+ r <- liftIO $ TLS.runTLS t $ TLS.putBytes (BC8.pack . toUTF8 $ str)
+ case r of
+ Left x -> fail (show x)
+ Right _ -> return ()
-- | Selects next messages from stream
nextM :: XmppStateT XmppMessage
@@ -125,8 +137,49 @@
-- | Replaces contents of the Stream with the contents
-- coming from given handle.
resetStreamHandle h =
- do c <- liftIO $ hGetContents h
- modify (\stream -> stream { handle=h , lexemes = xmlLex "stream" (fromUTF8 c) })
+ do c <- liftIO $ hGetContentsNoClose h
+ modify (\stream -> stream { transport=HandleTransport h , lexemes = xmlLex "stream" (fromUTF8 c) })
+
+-- This is inefficient, but the moment we get to TLS, we ditch it.
+hGetContentsNoClose h =
+ unsafeInterleaveIO $ do
+ c <- hGetChar h
+ next <- hGetContentsNoClose h
+ return (c:next)
+
+
+-- | Replaces contents of the Stream with the contents
+-- coming from the TLS stream.
+resetStreamTLS h t =
+ do c <- liftIO $ getTLSStream t
+ modify (\stream -> stream { transport=TLSTransport t , lexemes = xmlLex "stream" (fromUTF8 c) })
+ where getTLSStream :: TLS.Session -> IO String
+ getTLSStream s = unsafeInterleaveIO (runner s)
+ waitForData =
+ do -- liftIO $ putStrLn "before first checkpending"
+ pending <- TLS.checkPending
+ if pending == 0
+ {-
+ then do liftIO $ putStrLn "pending was 0"
+ liftIO (hWaitForInput h (- 1) >> return ())
+ liftIO $ putStrLn "after wait"
+ waitForData -}
+ then return 1
+ else return pending
+ runner :: TLS.Session -> IO String
+ runner s =
+ do r <- TLS.runTLS s $ do
+ -- liftIO $ putStrLn "before waitForData"
+ pendingBytes <- waitForData
+ -- liftIO $ putStrLn "before getBytes"
+ lazy <- TLS.getBytes pendingBytes
+ -- liftIO $ putStrLn $ "got bytes"
+ return $ BC8.unpack lazy
+ case r of
+ Left x -> fail (show x)
+ Right y -> do remainder <- getTLSStream s
+ return (y ++ remainder)
+
-------------------------------
-- Basic plugin support
diff -durN -x '*~' -x Test.hs orig/haskell-xmpp-1.0/src/Network/XMPP/Types.hs haskell-xmpp-1.0/src/Network/XMPP/Types.hs
--- orig/haskell-xmpp-1.0/src/Network/XMPP/Types.hs 2011-01-15 16:50:14.000000000 -0600
+++ haskell-xmpp-1.0/src/Network/XMPP/Types.hs 2012-04-16 21:38:57.201274975 -0500
@@ -12,6 +12,7 @@
module Network.XMPP.Types
( XmppMessage
, XmppStateT
+ , Transport(..)
, Stream(..)
, StreamType(..)
, Stanza(..)
@@ -29,14 +30,17 @@
import Text.PrettyPrint.HughesPJ (render, hcat)
import qualified Text.XML.HaXml.Pretty as P (content)
+import qualified Network.Protocol.TLS.GNU as TLS
import Network.XMPP.JID
-- | XMPP message in the parsed form
type XmppMessage = Content Posn
+data Transport = HandleTransport Handle | TLSTransport TLS.Session
+
-- | XMPP stream, used as a state in XmppStateT state transformer
-data Stream = Stream { handle::Handle
+data Stream = Stream { transport :: Transport
-- ^ IO handle to the underlying file or socket
, idx :: !Int
-- ^ id of the next message (if needed)
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
