module Network.XMPP.Stream
(
out
, startM
, nextM
, withNextM
, selectM
, xtractM
, textractM
, withSelectM
, withNewStream
, withStream
, resetStreamHandle
, getText
, getText_
, loopWithPlugins
, Plugin(..)
, getNextId
, lookupAttr
, newStream
) where
import Control.Monad.State
import Foreign hiding (new)
import System.IO
import Text.ParserCombinators.Poly.State (onFail)
import Text.XML.HaXml.Lex (xmlLex)
import Text.XML.HaXml.Parse
import Text.XML.HaXml.Posn (noPos)
import Text.XML.HaXml.Types
import qualified Text.XML.HaXml.Pretty as P (content)
import Text.XML.HaXml.Xtract.Parse (xtract)
import Network.XMPP.Print
import Network.XMPP.Utils
import Network.XMPP.Types
import Network.XMPP.UTF8
newStream :: Stream
newStream = Stream { handle=stdin, idx=0, lexemes=[] }
out :: XmppMessage -> XmppStateT ()
out xmpp = do h <- gets handle
liftIO $ hPutXmpp h xmpp
nextM :: XmppStateT XmppMessage
nextM =
do ls <- gets lexemes
let (elem, rest) = xmlParseWith element ls
case elem of
(Left err) -> error $ "Failed to parse next element: " ++ show err
(Right e) -> do let msg = CElem e noPos
debug $ "nextM: Got element: " ++ show (P.content msg)
modify (\stream -> stream { lexemes = rest } )
return msg
selectM :: (XmppMessage -> Bool) -> XmppStateT XmppMessage
selectM p =
do m <- nextM
if p m then return m
else error "Failed to select message"
xtractM :: String -> XmppStateT [XmppMessage]
xtractM q =
do m <- selectM (not . null . (xtract id q))
return $ xtract id q m
textractM :: String -> XmppStateT String
textractM q = do res <- xtractM q
return $ case res of
[] -> ""
x -> getText_ x
withM acc f = do m <- acc; return (f m)
withNextM = withM nextM
withSelectM p = withM (selectM p)
startM :: XmppStateT [Attribute]
startM =
do ls <- gets lexemes
let (starter, rest) = xmlParseWith streamStart ls
case starter of
Left e -> error e
Right (ElemTag "stream:stream" attrs) -> do modify (\stream -> stream { lexemes=rest })
return attrs
Right x -> error $ "Unexpected element at the beginning of XMPP stream!"
where
streamStart = do ( processinginstruction >> return () ) `onFail` return ()
elemOpenTag
withNewStream :: XmppStateT a -> IO (a, Stream)
withNewStream f =
do let stream = newStream
f `runStateT` stream
withStream :: Stream -> XmppStateT a -> IO (a, Stream)
withStream s f = f `runStateT` s
resetStreamHandle h =
do c <- liftIO $ hGetContents h
modify (\stream -> stream { handle=h , lexemes = xmlLex "stream" (fromUTF8 c) })
data Plugin = Plugin { trigger::String, body::(XmppMessage -> XmppStateT ()) }
loopWithPlugins :: [Plugin] -> XmppStateT ()
loopWithPlugins ps =
let loop = do m <- nextM
sequence_ [ (body p) m | p <- ps, not (null (xtract id (trigger p) m)) ]
loop
in loop
getNextId :: XmppStateT Int
getNextId =
do i <- gets idx
modify (\stream -> stream { idx = i+1 })
return i
lookupAttr k lst =
do x <- lookup k lst
case x of
AttValue [Left str] -> Just str
AttValue _ -> Nothing