Browse Source

Enable proof-of-concept logging by use of hslogger

Started to use hslogger in `EchoClient' and `connectTcpRaw'. Pontarius
XMPP now shows all binary data going in and out at the `debug' level.
Also modified the TCP conduit byte source to log the incoming data.
master
Jon Kristensen 13 years ago
parent
commit
03af489423
  1. 10
      examples/EchoClient.hs
  2. 1
      pontarius-xmpp.cabal
  3. 38
      source/Network/Xmpp/Connection.hs

10
examples/EchoClient.hs

@ -22,6 +22,11 @@ import Text.Printf
import Network.Xmpp import Network.Xmpp
import Network.Xmpp.IM 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. -- Server and authentication details.
host = "localhost" host = "localhost"
@ -41,6 +46,11 @@ autoAccept session = forever $ do
main :: IO () main :: IO ()
main = do 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 sess <- simpleConnect
host host
port port

1
pontarius-xmpp.cabal

@ -52,6 +52,7 @@ Library
, xml-picklers >=0.2.2 , xml-picklers >=0.2.2
, data-default >=0.2 , data-default >=0.2
, stringprep >=0.1.3 , stringprep >=0.1.3
, hslogger >=1.1.0
Exposed-modules: Network.Xmpp Exposed-modules: Network.Xmpp
, Network.Xmpp.IM , Network.Xmpp.IM
, Network.Xmpp.Basic , Network.Xmpp.Basic

38
source/Network/Xmpp/Connection.hs

@ -15,12 +15,14 @@ import qualified GHC.IO.Exception as GIE
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.ByteString as BS import Data.ByteString as BS
import Data.ByteString.Char8 as BSC8
import Data.Conduit import Data.Conduit
import Data.Conduit.Binary as CB import Data.Conduit.Binary as CB
import Data.Conduit.Internal as DCI import Data.Conduit.Internal as DCI
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.IORef import Data.IORef
import Data.Text(Text) import Data.Text(Text)
import qualified Data.Text as T
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
@ -35,6 +37,9 @@ import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..)) import Text.XML.Unresolved(InvalidEventStream(..))
import System.Log.Logger
import Data.ByteString.Base64
-- Enable/disable debug output -- Enable/disable debug output
-- This will dump all incoming and outgoing network taffic to the console, -- This will dump all incoming and outgoing network taffic to the console,
-- prefixed with "in: " and "out: " respectively -- prefixed with "in: " and "out: " respectively
@ -145,21 +150,25 @@ xmppNoConnection = Connection_
-- updates the XmppConMonad Connection_ state. -- updates the XmppConMonad Connection_ state.
connectTcpRaw :: HostName -> PortID -> Text -> IO Connection connectTcpRaw :: HostName -> PortID -> Text -> IO Connection
connectTcpRaw host port hostname = do 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 h <- connectTo host port
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle."
hSetBuffering h NoBuffering hSetBuffering h NoBuffering
let eSource = DCI.ResumableSource (sourceHandle h $= XP.parseBytes def) let eSource = DCI.ResumableSource ((sourceHandle h $= logConduit) $= XP.parseBytes def)
(return ()) (return ())
let hand = Hand { cSend = if debug let hand = Hand { cSend = \d -> do
then \d -> do let d64 = encode d
BS.putStrLn (BS.append "out: " d) debugM "Pontarius.Xmpp" $ "Sending TCP data: " ++
(BSC8.unpack d64) ++ "."
catchPush $ BS.hPut h d catchPush $ BS.hPut h d
else catchPush . BS.hPut h , cRecv = \n -> do
, cRecv = if debug then d <- BS.hGetSome h n
\n -> do let d64 = encode d
bs <- BS.hGetSome h n debugM "Pontarius.Xmpp" $ "Received TCP data: " ++
BS.putStrLn bs (BSC8.unpack d64) ++ "."
return bs return d
else BS.hGetSome h
, cFlush = hFlush h , cFlush = hFlush h
, cClose = hClose h , cClose = hClose h
} }
@ -178,6 +187,13 @@ connectTcpRaw host port hostname = do
, sFrom = Nothing , sFrom = Nothing
} }
mkConnection con 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. -- Closes the connection and updates the XmppConMonad Connection_ state.

Loading…
Cancel
Save