diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index 953cc2b..62f7175 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -22,6 +22,11 @@ import Text.Printf import Network.Xmpp import Network.Xmpp.IM +import System.Log.Formatter +import System.Log.Logger +import System.Log.Handler hiding (setLevel) +import System.Log.Handler.Simple +import System.IO (stderr) -- Server and authentication details. host = "localhost" @@ -41,6 +46,11 @@ autoAccept session = forever $ do main :: IO () main = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + handler <- streamHandler stderr DEBUG >>= \h -> + return $ setFormatter h (simpleLogFormatter "$time - $loggername: $prio: $msg") + updateGlobalLogger "Pontarius.Xmpp" (addHandler handler) + sess <- simpleConnect host port diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0a77516..7007be0 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -52,6 +52,7 @@ Library , xml-picklers >=0.2.2 , data-default >=0.2 , stringprep >=0.1.3 + , hslogger >=1.1.0 Exposed-modules: Network.Xmpp , Network.Xmpp.IM , Network.Xmpp.Basic diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index 4e0d31f..942ba8a 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -15,12 +15,14 @@ import qualified GHC.IO.Exception as GIE import Control.Monad.State.Strict import Data.ByteString as BS +import Data.ByteString.Char8 as BSC8 import Data.Conduit import Data.Conduit.Binary as CB import Data.Conduit.Internal as DCI import qualified Data.Conduit.List as CL import Data.IORef import Data.Text(Text) +import qualified Data.Text as T import Data.XML.Pickle import Data.XML.Types @@ -35,6 +37,9 @@ import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) +import System.Log.Logger +import Data.ByteString.Base64 + -- Enable/disable debug output -- This will dump all incoming and outgoing network taffic to the console, -- prefixed with "in: " and "out: " respectively @@ -145,21 +150,25 @@ xmppNoConnection = Connection_ -- updates the XmppConMonad Connection_ state. connectTcpRaw :: HostName -> PortID -> Text -> IO Connection connectTcpRaw host port hostname = do + let PortNumber portNumber = port + debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ + (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." h <- connectTo host port + debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource (sourceHandle h $= XP.parseBytes def) + let eSource = DCI.ResumableSource ((sourceHandle h $= logConduit) $= XP.parseBytes def) (return ()) - let hand = Hand { cSend = if debug - then \d -> do - BS.putStrLn (BS.append "out: " d) - catchPush $ BS.hPut h d - else catchPush . BS.hPut h - , cRecv = if debug then - \n -> do - bs <- BS.hGetSome h n - BS.putStrLn bs - return bs - else BS.hGetSome h + let hand = Hand { cSend = \d -> do + let d64 = encode d + debugM "Pontarius.Xmpp" $ "Sending TCP data: " ++ + (BSC8.unpack d64) ++ "." + catchPush $ BS.hPut h d + , cRecv = \n -> do + d <- BS.hGetSome h n + let d64 = encode d + debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ + (BSC8.unpack d64) ++ "." + return d , cFlush = hFlush h , cClose = hClose h } @@ -178,6 +187,13 @@ connectTcpRaw host port hostname = do , sFrom = Nothing } mkConnection con + where + logConduit :: Conduit ByteString IO ByteString + logConduit = CL.mapM $ \d -> do + let d64 = encode d + debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ + "." + return d -- Closes the connection and updates the XmppConMonad Connection_ state.