module Network.XMPP.TCPConnection
( TCPConnection
, openStream
, getStreamStart
)
where
import Network.XMPP.XMLParse
import Network.XMPP.XMPPConnection
import Network.XMPP.MyDebug
import Network
import System.IO
import Data.IORef
import Control.Monad
import Codec.Binary.UTF8.String
import ADNS
data TCPConnection = TCPConnection Handle (IORef String)
openStream :: String -> IO TCPConnection
openStream server =
do
svcs <- getSvcServer server
h <- connectStream svcs
hPutStr h $ xmlToString False $
XML "stream:stream"
[("to",server),
("xmlns","jabber:client"),
("xmlns:stream","http://etherx.jabber.org/streams")]
[]
buffer <- newIORef ""
return $ TCPConnection h buffer
getSvcServer :: String -> IO [(String, PortID)]
getSvcServer domain =
initResolver [] $ \resolver -> do
a <- querySRV resolver ("_xmpp-client._tcp." ++ domain)
return $ (maybe [] id a) ++ [(domain, PortNumber $ toEnum 5222)]
connectStream :: [(String, PortID)] -> IO Handle
connectStream [] = error "can't connect: no suitable servers found"
connectStream (x:xs) =
catch (connectStream' x) (\e -> connectStream xs)
connectStream' :: (String, PortID) -> IO Handle
connectStream' (host, port) = do
s <- connectTo host port
hSetBuffering s NoBuffering
return s
getStreamStart :: TCPConnection -> IO XMLElem
getStreamStart c =
parseBuffered c xmppStreamStart
instance XMPPConnection TCPConnection where
getStanzas c = parseBuffered c deepTags
sendStanza (TCPConnection h _) x =
let str = xmlToString True x in
do
myDebug $ "sent '" ++ str ++ "'"
hPutStr h (encodeString str)
closeConnection (TCPConnection h _) =
hClose h
parseBuffered :: TCPConnection -> Parser a -> IO a
parseBuffered c@(TCPConnection h bufvar) parser = do
buffer <- readIORef bufvar
input' <- getString h
let input = decodeString input'
myDebug $ "got '" ++ buffer ++ input ++ "'"
case parse (getRest parser) "" (buffer++input) of
Right (result, rest) ->
do
writeIORef bufvar rest
return result
Left e ->
do
myDebug $ "An error? Hopefully doesn't matter.\n"++(show e)
parseBuffered c parser
getString :: Handle -> IO String
getString h =
do
hWaitForInput h (1)
getEverything
where getEverything =
do
r <- hReady h
if r
then liftM2 (:) (hGetChar h) getEverything
else return []