~singpolyma/network-protocol-xmpp

6831ae340ee131b78985f3846cc151d6e2cd87aa — John Millikin 13 years ago 99f5f44
Replace 'hGetChar' with 'hGetBytes'.
3 files changed, 20 insertions(+), 28 deletions(-)

M Network/Protocol/XMPP/Handle.hs
M Network/Protocol/XMPP/Monad.hs
M Network/Protocol/XMPP/XML.hs
M Network/Protocol/XMPP/Handle.hs => Network/Protocol/XMPP/Handle.hs +11 -15
@@ 18,13 18,13 @@ module Network.Protocol.XMPP.Handle
	( Handle (..)
	, startTLS
	, hPutBytes
	, hGetChar
	, hGetBytes
	) where

import Control.Monad (when)
import qualified Control.Monad.Error as E
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Lazy as B
import qualified Data.Text.Lazy as T
import qualified System.IO as IO
import qualified Network.Protocol.TLS.GNU as TLS


@@ 56,16 56,12 @@ hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO ()
hPutBytes (PlainHandle h)  = liftIO . B.hPut h
hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes

hGetChar :: Handle -> ErrorT T.Text IO Char
hGetChar (PlainHandle h) = liftIO $ IO.hGetChar h
hGetChar (SecureHandle h s) = do
	bytes <- liftTLS s $ do
		pending <- TLS.checkPending
		when (pending == 0) $ do
			liftIO $ IO.hWaitForInput h (- 1)
			return ()
		
		TLS.getBytes 1
	case B.unpack bytes of
		(c:_) -> return c
		_ -> E.throwError "hGetChar: not enough bytes"
hGetBytes :: Handle -> Integer -> ErrorT T.Text IO B.ByteString
hGetBytes (PlainHandle h) n = liftIO $  B.hGet h $ fromInteger n
hGetBytes (SecureHandle h s) n = liftTLS s $ do
	pending <- TLS.checkPending
	when (pending == 0) $ do
		liftIO $ IO.hWaitForInput h (- 1)
		return ()
	
	TLS.getBytes n

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +5 -9
@@ 26,7 26,6 @@ module Network.Protocol.XMPP.Monad
	, getContext
	
	, readEvents
	, getChar
	, getTree
	, getStanza
	


@@ 34,7 33,6 @@ module Network.Protocol.XMPP.Monad
	, putTree
	, putStanza
	) where
import Prelude hiding (getChar)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R


@@ 111,17 109,11 @@ liftTLS io = do
		Left err -> E.throwError $ TransportError err
		Right x -> return x


putBytes :: B.ByteString -> XMPP ()
putBytes bytes = do
	h <- getHandle
	liftTLS $ H.hPutBytes h bytes

getChar :: XMPP Char
getChar = do
	h <- getHandle
	liftTLS $ H.hGetChar h

putTree :: DOM.XmlTree -> XMPP ()
putTree t = do
	let root = XN.mkRoot [] [t]


@@ 136,7 128,11 @@ putStanza = putTree . S.stanzaToTree
readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
readEvents done = do
	Context h _ p <- getContext
	X.readEvents done (liftTLS $ H.hGetChar h) p
	let nextChar = do
		-- TODO: read in larger increments
		bytes <- liftTLS $ H.hGetBytes h 1
		return $ B.unpack bytes
	X.readEvents done nextChar p

getTree :: XMPP DOM.XmlTree
getTree = X.eventsToTree `fmap` readEvents endOfTree where

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +4 -4
@@ 33,11 33,11 @@ import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.LibXML.SAX as SAX

readEvents :: MonadIO m => (Integer -> SAX.Event -> Bool) -> m Char -> SAX.Parser -> m [SAX.Event]
readEvents done getChar parser = readEvents' 0 [] where
readEvents :: MonadIO m => (Integer -> SAX.Event -> Bool) -> m String -> SAX.Parser -> m [SAX.Event]
readEvents done getChars parser = readEvents' 0 [] where
	nextEvents = do
		char <- getChar
		liftIO $ SAX.parse parser [char] False
		chars <- getChars
		liftIO $ SAX.parse parser chars False
	
	readEvents' depth acc = do
		events <- nextEvents