From ef607f550b455c8aa03d651d102ed9c00e014ed8 Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Sun, 24 Jun 2012 16:09:30 +0200
Subject: [PATCH] Add debug support (controlled by debug constant in
 Network.Xmpp.Monad)

---
 source/Data/Conduit/TLS.hs   | 27 +++++++++++++++++----------
 source/Network/Xmpp/Monad.hs | 29 +++++++++++++++++++++++++----
 source/Network/Xmpp/TLS.hs   |  4 ++--
 3 files changed, 44 insertions(+), 16 deletions(-)

diff --git a/source/Data/Conduit/TLS.hs b/source/Data/Conduit/TLS.hs
index 4673353..7cb2df2 100644
--- a/source/Data/Conduit/TLS.hs
+++ b/source/Data/Conduit/TLS.hs
@@ -8,7 +8,7 @@ module Data.Conduit.TLS
        )
        where
 
-import Control.Monad(liftM)
+import Control.Monad(liftM, when)
 import Control.Monad.IO.Class
 
 import Crypto.Random
@@ -22,29 +22,36 @@ import Network.TLS.Extra as TLSExtra
 
 import System.IO(Handle)
 
-tlsinit
-  :: (MonadIO m, MonadIO m1) =>
-     TLSParams
+tlsinit :: (MonadIO m, MonadIO m1) =>
+        Bool
+     -> TLSParams
      -> Handle -> m ( Source m1 BS.ByteString
                     , Sink BS.ByteString m1 ()
                     , BS.ByteString -> IO ()
                     , TLSCtx Handle
                     )
-tlsinit tlsParams handle = do
+tlsinit debug tlsParams handle = do
+    when debug . liftIO $ putStrLn "Debug mode enabled"
     gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source?
     clientContext <- client tlsParams gen handle
     handshake clientContext
     let src = sourceState
                clientContext
-               (\con -> StateOpen con `liftM` recvData con)
+               (\con -> do
+                     dt <- recvData con
+                     when debug (liftIO $ BS.putStrLn dt)
+                     return $ StateOpen con dt)
     let snk = sinkState
          clientContext
-         (\con bs -> sendData con (BL.fromChunks [bs])
-                     >> return (StateProcessing  con))
+         (\con bs -> do
+                       sendData con (BL.fromChunks [bs])
+                       when debug (liftIO $ BS.putStrLn bs)
+                       return (StateProcessing  con))
          (\_ -> return ())
     return ( src
            , snk
-           , \s -> sendData clientContext $ BL.fromChunks [s]
+           , \s -> do
+               when debug (liftIO $ BS.putStrLn s)
+               sendData clientContext $ BL.fromChunks [s]
            , clientContext
            )
-
diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs
index c642861..342d44a 100644
--- a/source/Network/Xmpp/Monad.hs
+++ b/source/Network/Xmpp/Monad.hs
@@ -33,6 +33,12 @@ import           Text.XML.Stream.Elements
 import           Text.XML.Stream.Parse as XP
 import           Text.XML.Unresolved(InvalidEventStream(..))
 
+-- Enable/disable debug output
+-- This will dump all incoming and outgoing network taffic to the console,
+-- prefixed with "in: " and "out: " respectively
+debug :: Bool
+debug = False
+
 pushElement :: Element -> XmppConMonad Bool
 pushElement x = do
     sink <- gets sConPushBS
@@ -94,7 +100,7 @@ pullStanza = do
         Right r -> return r
 
 -- Performs the given IO operation, catches any errors and re-throws everything
--- except the `ResourceVanished' error.
+-- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead
 catchPush :: IO () -> IO Bool
 catchPush p = Ex.catch
     (p >> return True)
@@ -135,12 +141,18 @@ xmppRawConnect host hostname = do
         con <- connectTo host (PortNumber 5222)
         hSetBuffering con NoBuffering
         return con
-    let raw = sourceHandle con
+    let raw = if debug
+                then sourceHandle con $= debugConduit
+                else sourceHandle con
     src <- liftIO . bufferSource $ raw $= XP.parseBytes def
     let st = XmppConnection
             { sConSrc          = src
             , sRawSrc          = raw
-            , sConPushBS       = (catchPush . BS.hPut con)
+            , sConPushBS       = if debug
+                                   then \d -> do
+                                       BS.putStrLn (BS.append "out: " d)
+                                       catchPush $ BS.hPut con d
+                                   else catchPush . BS.hPut con
             , sConHandle       = (Just con)
             , sFeatures        = (SF Nothing [] [])
             , sConnectionState = XmppConnectionPlain
@@ -211,4 +223,13 @@ xmppCloseStreams = do
         case result of
             Left StreamStreamEnd -> return (elems, True)
             Left _ -> return (elems, False)
-            Right elem -> collectElems (elem:elems)
\ No newline at end of file
+            Right elem -> collectElems (elem:elems)
+
+debugConduit :: MonadIO m => Pipe BS.ByteString BS.ByteString m ()
+debugConduit = forever $ do
+    s <- await
+    case s of
+        Just s ->  do
+            liftIO $ BS.putStrLn (BS.append "in: " s)
+            yield s
+        Nothing -> return ()
diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs
index f16787e..cdf151c 100644
--- a/source/Network/Xmpp/TLS.hs
+++ b/source/Network/Xmpp/TLS.hs
@@ -62,7 +62,7 @@ startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
             -- TODO: find something more suitable
         e -> lift . Ex.throwIO . StreamXMLError $
             "Unexpected element: " ++ ppElement e
-    (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle
+    (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit debug params handle
     lift $ modify ( \x -> x
                   { sRawSrc = raw
 --                , sConSrc =  -- Note: this momentarily leaves us in an
@@ -72,4 +72,4 @@ startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
                   })
     either (lift . Ex.throwIO) return =<< lift xmppRestartStream
     modify (\s -> s{sConnectionState = XmppConnectionSecured})
-    return ()
\ No newline at end of file
+    return ()