module Network.XMPP.XMPPMonad
( XMPP
, runXMPP
, sendStanza
, addHandler
, waitForStanza
, quit
, StanzaPredicate
, StanzaHandler
, Control.Monad.State.liftIO
)
where
import Control.Monad.State
import Network.XMPP.XMLParse
import Network.XMPP.XMPPConnection hiding ( sendStanza )
import qualified Network.XMPP.XMPPConnection as XMPPConnection
import Network.XMPP.MyDebug
type StanzaPredicate = (XMLElem -> Bool)
type StanzaHandlerPart a = (XMLElem -> XMPP a)
type StanzaHandler = (XMLElem -> XMPP ())
data XMPP a =
XMPP { xmppFn :: XMPPConnection c =>
(c -> XMPPState -> IO (XMPPState, XMPPRes a)) }
type XMPPState =
[(StanzaPredicate,
StanzaHandler,
Bool)]
data XMPPRes a = XMPPJust a
| WaitingFor StanzaPredicate (StanzaHandlerPart a) Bool
instance Monad XMPP where
f >>= g = XMPP $
\c state ->
do
(state', result) <- xmppFn f c state
case result of
XMPPJust a ->
xmppFn (g a) c state'
WaitingFor pred mangler keep ->
return $ (state',
WaitingFor pred
(\stanza -> (mangler stanza) >>= g) keep)
return a = XMPP $ \_ state -> return (state, XMPPJust a)
getState :: XMPP XMPPState
getState = XMPP $ \_ state -> return (state, XMPPJust state)
putState :: XMPPState -> XMPP ()
putState state = XMPP $ \_ _ -> return (state, XMPPJust ())
modifyState :: (XMPPState -> XMPPState) -> XMPP ()
modifyState fn = XMPP $ \_ state -> return (fn state, XMPPJust ())
instance MonadIO XMPP where
liftIO iofn = XMPP $ \c state -> do
iores <- iofn
return (state, XMPPJust iores)
initialState :: XMPPState
initialState = []
runXMPP :: XMPPConnection c => c -> XMPP () -> IO ()
runXMPP c x = runXMPP' initialState c [x] []
where runXMPP' :: XMPPConnection c => XMPPState -> c -> [XMPP ()] -> [XMLElem] -> IO ()
runXMPP' [] c [] _ =
return ()
runXMPP' s c (x:xs) stanzas =
do
(s', result) <- xmppFn x c s
let s'' = (case result of
XMPPJust () ->
s'
WaitingFor pred mangler keep ->
(pred,mangler,keep):s'
)
runXMPP' s'' c xs stanzas
runXMPP' s c [] (stanza:stanzas) =
runXMPP' s c [actOnStanza stanza] stanzas
runXMPP' s c [] [] =
do
myDebug $ show (length s) ++ " handlers left"
newStanzas <- getStanzas c
myDebug $ show (length newStanzas) ++ " new stanzas"
runXMPP' s c [] newStanzas
sendStanza :: XMLElem -> XMPP ()
sendStanza stanza =
XMPP $ \c state -> do
XMPPConnection.sendStanza c stanza
return (state, XMPPJust ())
addHandler :: StanzaPredicate
-> StanzaHandler
-> Bool
-> XMPP ()
addHandler pred handler keep =
modifyState ((pred, handler, keep):)
waitForStanza :: StanzaPredicate -> XMPP XMLElem
waitForStanza pred =
XMPP $ \c state -> return (state, WaitingFor pred return False)
quit :: XMPP ()
quit =
putState []
actOnStanza :: XMLElem -> XMPP ()
actOnStanza stanza =
do
table <- getState
liftIO $ myDebug $ "checking " ++ show (length table) ++ " active handlers"
case findHandler table stanza of
Just (table', handler) ->
do
putState table'
liftIO $ myDebug $ show (length table') ++ " handlers left"
handler stanza
Nothing ->
return ()
findHandler :: [(StanzaPredicate, StanzaHandler, Bool)] -> XMLElem ->
Maybe ([(StanzaPredicate, StanzaHandler, Bool)], StanzaHandler)
findHandler ((pred, handler, keep):table) stanza =
case pred stanza of
True ->
let table' = if keep
then
((pred, handler, keep):table)
else
table
in return (table', handler)
False ->
do
(table', handler') <- findHandler table stanza
return ((pred, handler, keep):table', handler')
findHandler [] _ = Nothing