|
|
|
@ -1,6 +1,7 @@ |
|
|
|
{-# OPTIONS_HADDOCK hide #-} |
|
|
|
{-# OPTIONS_HADDOCK hide #-} |
|
|
|
|
|
|
|
|
|
|
|
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} |
|
|
|
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
|
|
|
|
|
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
|
|
|
|
|
|
|
|
@ -354,8 +355,8 @@ pushOpenElement e = do |
|
|
|
-- `b' value. |
|
|
|
-- `b' value. |
|
|
|
runEventsSink :: Sink Event IO b -> StateT Stream IO (Either XmppFailure b) |
|
|
|
runEventsSink :: Sink Event IO b -> StateT Stream IO (Either XmppFailure b) |
|
|
|
runEventsSink snk = do -- TODO: Wrap exceptions? |
|
|
|
runEventsSink snk = do -- TODO: Wrap exceptions? |
|
|
|
source <- gets streamEventSource |
|
|
|
src <- gets streamEventSource |
|
|
|
(src', r) <- lift $ source $$++ snk |
|
|
|
(src', r) <- lift $ src $$++ snk |
|
|
|
modify (\s -> s{streamEventSource = src'}) |
|
|
|
modify (\s -> s{streamEventSource = src'}) |
|
|
|
return $ Right r |
|
|
|
return $ Right r |
|
|
|
|
|
|
|
|
|
|
|
@ -446,19 +447,10 @@ connectTcp host port hostname config = ErrorT $ do |
|
|
|
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." |
|
|
|
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." |
|
|
|
hSetBuffering h NoBuffering |
|
|
|
hSetBuffering h NoBuffering |
|
|
|
let eSource = DCI.ResumableSource |
|
|
|
let eSource = DCI.ResumableSource |
|
|
|
((sourceHandle h $= logConduit) $= XP.parseBytes def) |
|
|
|
(sourceHandle h $= logConduit $= XP.parseBytes def) |
|
|
|
(return ()) |
|
|
|
(return ()) |
|
|
|
let hand = StreamHandle { streamSend = \d -> do |
|
|
|
let hand = StreamHandle { streamSend = catchPush . BS.hPut h |
|
|
|
debugM "Pontarius.Xmpp" $ |
|
|
|
, streamReceive = BS.hGetSome h |
|
|
|
"Sending TCP data: " ++ (BSC8.unpack d) |
|
|
|
|
|
|
|
++ "." |
|
|
|
|
|
|
|
catchPush $ BS.hPut h d |
|
|
|
|
|
|
|
, streamReceive = \n -> do |
|
|
|
|
|
|
|
d <- BS.hGetSome h n |
|
|
|
|
|
|
|
debugM "Pontarius.Xmpp" $ |
|
|
|
|
|
|
|
"Received TCP data: " ++ |
|
|
|
|
|
|
|
(BSC8.unpack d) ++ "." |
|
|
|
|
|
|
|
return d |
|
|
|
|
|
|
|
, streamFlush = hFlush h |
|
|
|
, streamFlush = hFlush h |
|
|
|
, streamClose = hClose h |
|
|
|
, streamClose = hClose h |
|
|
|
} |
|
|
|
} |
|
|
|
@ -479,8 +471,7 @@ connectTcp host port hostname config = ErrorT $ do |
|
|
|
where |
|
|
|
where |
|
|
|
logConduit :: Conduit ByteString IO ByteString |
|
|
|
logConduit :: Conduit ByteString IO ByteString |
|
|
|
logConduit = CL.mapM $ \d -> do |
|
|
|
logConduit = CL.mapM $ \d -> do |
|
|
|
let d64 = encode d |
|
|
|
debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ |
|
|
|
debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ |
|
|
|
|
|
|
|
"." |
|
|
|
"." |
|
|
|
return d |
|
|
|
return d |
|
|
|
|
|
|
|
|
|
|
|
|