Browse Source
Conflicts: LICENSE src/Network/XMPP.hs src/Network/XMPP/SASL.hs src/Network/XMPP/Session.hs src/Network/XMPP/Stream.hs src/Network/XMPP/TLS.hs src/Network/XMPP/Types.hsmaster
Philipp Balzarek
14 years ago
28 changed files with 1923 additions and 1624 deletions
@ -0,0 +1,3 @@
@@ -0,0 +1,3 @@
|
||||
[submodule "xml-types-pickle"] |
||||
path = xml-types-pickle |
||||
url = git@github.com:Philonous/xml-types-pickle.git |
||||
@ -0,0 +1,48 @@
@@ -0,0 +1,48 @@
|
||||
{-# Language NoMonomorphismRestriction #-} |
||||
module Data.Conduit.TLS |
||||
( tlsinit |
||||
-- , conduitStdout |
||||
, module TLS |
||||
, module TLSExtra |
||||
) |
||||
where |
||||
|
||||
import Control.Applicative |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Resource |
||||
|
||||
import Crypto.Random |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import Data.Conduit |
||||
|
||||
import Network.TLS as TLS |
||||
import Network.TLS.Extra as TLSExtra |
||||
|
||||
import System.IO(Handle) |
||||
|
||||
tlsinit |
||||
:: (MonadIO m, MonadIO m1, MonadResource m1) => |
||||
TLSParams |
||||
-> Handle -> m ( Source m1 BS.ByteString |
||||
, Sink BS.ByteString m1 () |
||||
, BS.ByteString -> IO ()) |
||||
tlsinit tlsParams handle = do |
||||
gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? |
||||
clientContext <- client tlsParams gen handle |
||||
handshake clientContext |
||||
let src = sourceIO |
||||
(return clientContext) |
||||
(bye) |
||||
(\con -> IOOpen <$> recvData con) |
||||
let snk = sinkIO |
||||
(return clientContext) |
||||
(\_ -> return ()) |
||||
(\con bs -> sendData con (BL.fromChunks [bs]) |
||||
>> return IOProcessing ) |
||||
(\_ -> return ()) |
||||
return ( src |
||||
, snk |
||||
, \s -> sendData clientContext $ BL.fromChunks [s] ) |
||||
|
||||
@ -0,0 +1,55 @@
@@ -0,0 +1,55 @@
|
||||
{-# LANGUAGE PackageImports, OverloadedStrings #-} |
||||
module Example where |
||||
|
||||
import Data.Text as T |
||||
|
||||
import Network.XMPP |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
|
||||
philonous :: JID |
||||
philonous = read "uart14@species64739.dyndns.org" |
||||
|
||||
attXmpp :: STM a -> XMPPThread a |
||||
attXmpp = liftIO . atomically |
||||
|
||||
autoAccept :: XMPPThread () |
||||
autoAccept = forever $ do |
||||
st <- pullPresence |
||||
case st of |
||||
Presence from _ idq (Just Subscribe) _ _ _ _ -> |
||||
sendS . SPresence $ |
||||
Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] |
||||
_ -> return () |
||||
|
||||
mirror :: XMPPThread () |
||||
mirror = forever $ do |
||||
st <- pullMessage |
||||
case st of |
||||
Message (Just from) _ idq tp subject (Just bd) thr _ -> |
||||
sendS . SMessage $ |
||||
Message Nothing from idq tp subject |
||||
(Just $ "you wrote: " `T.append` bd) thr [] |
||||
_ -> return () |
||||
|
||||
|
||||
main :: IO () |
||||
main = do |
||||
sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do |
||||
-- singleThreaded $ xmppStartTLS exampleParams |
||||
singleThreaded $ xmppSASL "pwd" |
||||
xmppThreadedBind (Just "botsi") |
||||
-- singleThreaded $ xmppBind (Just "botsi") |
||||
singleThreaded $ xmppSession |
||||
forkXMPP autoAccept |
||||
forkXMPP mirror |
||||
sendS . SPresence $ Presence Nothing Nothing Nothing Nothing |
||||
(Just Available) Nothing Nothing [] |
||||
sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing |
||||
(Just "bla") Nothing [] |
||||
liftIO . forever $ threadDelay 1000000 |
||||
return () |
||||
return () |
||||
|
||||
@ -0,0 +1,34 @@
@@ -0,0 +1,34 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Bind where |
||||
|
||||
import Data.Text as Text |
||||
|
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Concurrent |
||||
|
||||
bindP :: PU [Node] b -> PU [Node] b |
||||
bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c |
||||
|
||||
bindBody :: Maybe Text -> Element |
||||
bindBody rsrc = (pickleElem |
||||
(bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) |
||||
rsrc |
||||
) |
||||
|
||||
jidP :: PU [Node] JID |
||||
jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) |
||||
|
||||
xmppThreadedBind :: Maybe Text -> XMPPThread Text |
||||
xmppThreadedBind rsrc = do |
||||
answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) |
||||
let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling |
||||
let (JID _n _d (Just r)) = unpickleElem jidP b |
||||
return r |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,18 @@
@@ -0,0 +1,18 @@
|
||||
module Network.XMPP.Concurrent |
||||
( module Network.XMPP.Concurrent.Types |
||||
, module Network.XMPP.Concurrent.Monad |
||||
, module Network.XMPP.Concurrent.Threads |
||||
, module Network.XMPP.Concurrent.IQ |
||||
) where |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
import Network.XMPP.Concurrent.Monad |
||||
import Network.XMPP.Concurrent.Threads |
||||
import Network.XMPP.Concurrent.IQ |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,59 @@
@@ -0,0 +1,59 @@
|
||||
module Network.XMPP.Concurrent.IQ where |
||||
|
||||
import Control.Concurrent.STM |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Reader |
||||
|
||||
import Data.XML.Types |
||||
import qualified Data.Map as Map |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
import Network.XMPP.Concurrent.Monad |
||||
import Network.XMPP.Types |
||||
|
||||
-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound |
||||
-- IQ with a matching ID that has type @result@ or @error@ |
||||
sendIQ :: Maybe JID -- ^ Recipient (to) |
||||
-> IQRequestType -- ^ IQ type (Get or Set) |
||||
-> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) |
||||
-> Element -- ^ The iq body (there has to be exactly one) |
||||
-> XMPPThread (TMVar IQResponse) |
||||
sendIQ to tp lang body = do -- TODO: add timeout |
||||
newId <- liftIO =<< asks idGenerator |
||||
handlers <- asks iqHandlers |
||||
ref <- liftIO . atomically $ do |
||||
resRef <- newEmptyTMVar |
||||
(byNS, byId) <- readTVar handlers |
||||
writeTVar handlers (byNS, Map.insert newId resRef byId) |
||||
-- TODO: Check for id collisions (shouldn't happen?) |
||||
return resRef |
||||
sendS . IQRequestS $ IQRequest newId Nothing to lang tp body |
||||
return ref |
||||
|
||||
-- | like 'sendIQ', but waits for the answer IQ |
||||
sendIQ' :: Maybe JID |
||||
-> IQRequestType |
||||
-> Maybe LangTag |
||||
-> Element |
||||
-> XMPPThread IQResponse |
||||
sendIQ' to tp lang body = do |
||||
ref <- sendIQ to tp lang body |
||||
liftIO . atomically $ takeTMVar ref |
||||
|
||||
answerIQ :: (IQRequest, TVar Bool) |
||||
-> Either StanzaError (Maybe Element) |
||||
-> XMPPThread Bool |
||||
answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do |
||||
out <- asks outCh |
||||
let response = case answer of |
||||
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) |
||||
Right res -> IQResultS $ IQResult iqid Nothing from lang res |
||||
liftIO . atomically $ do |
||||
sent <- readTVar sentRef |
||||
case sent of |
||||
False -> do |
||||
writeTVar sentRef True |
||||
|
||||
writeTChan out response |
||||
return True |
||||
True -> return False |
||||
@ -0,0 +1,161 @@
@@ -0,0 +1,161 @@
|
||||
module Network.XMPP.Concurrent.Monad where |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Reader |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Text(Text) |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
|
||||
-- | Register a new IQ listener. IQ requests matching the type and namespace will |
||||
-- be put in the channel. |
||||
listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) |
||||
-> Text -- ^ namespace of the child element |
||||
-> XMPPThread (Bool, TChan (IQRequest, TVar Bool)) |
||||
listenIQChan tp ns = do |
||||
handlers <- asks iqHandlers |
||||
liftIO . atomically $ do |
||||
(byNS, byID) <- readTVar handlers |
||||
iqCh <- newTChan |
||||
let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) |
||||
(tp,ns) iqCh byNS |
||||
writeTVar handlers (byNS', byID) |
||||
return $ case present of |
||||
Nothing -> (True, iqCh) |
||||
Just iqCh' -> (False, iqCh') |
||||
|
||||
-- | get the inbound stanza channel, duplicates from master if necessary |
||||
-- please note that once duplicated it will keep filling up, call |
||||
-- 'dropMessageChan' to allow it to be garbage collected |
||||
getMessageChan :: XMPPThread (TChan (Either MessageError Message)) |
||||
getMessageChan = do |
||||
mChR <- asks messagesRef |
||||
mCh <- liftIO $ readIORef mChR |
||||
case mCh of |
||||
Nothing -> do |
||||
shadow <- asks mShadow |
||||
mCh' <- liftIO $ atomically $ dupTChan shadow |
||||
liftIO $ writeIORef mChR (Just mCh') |
||||
return mCh' |
||||
Just mCh' -> return mCh' |
||||
|
||||
-- | see 'getMessageChan' |
||||
getPresenceChan :: XMPPThread (TChan (Either PresenceError Presence)) |
||||
getPresenceChan = do |
||||
pChR <- asks presenceRef |
||||
pCh <- liftIO $ readIORef pChR |
||||
case pCh of |
||||
Nothing -> do |
||||
shadow <- asks pShadow |
||||
pCh' <- liftIO $ atomically $ dupTChan shadow |
||||
liftIO $ writeIORef pChR (Just pCh') |
||||
return pCh' |
||||
Just pCh' -> return pCh' |
||||
|
||||
-- | Drop the local end of the inbound stanza channel |
||||
-- from our context so it can be GC-ed |
||||
dropMessageChan :: XMPPThread () |
||||
dropMessageChan = do |
||||
r <- asks messagesRef |
||||
liftIO $ writeIORef r Nothing |
||||
|
||||
-- | see 'dropMessageChan' |
||||
dropPresenceChan :: XMPPThread () |
||||
dropPresenceChan = do |
||||
r <- asks presenceRef |
||||
liftIO $ writeIORef r Nothing |
||||
|
||||
-- | Read an element from the inbound stanza channel, acquiring a copy |
||||
-- of the channel as necessary |
||||
pullMessage :: XMPPThread (Either MessageError Message) |
||||
pullMessage = do |
||||
c <- getMessageChan |
||||
liftIO $ atomically $ readTChan c |
||||
|
||||
-- | Read an element from the inbound stanza channel, acquiring a copy |
||||
-- of the channel as necessary |
||||
pullPresence :: XMPPThread (Either PresenceError Presence) |
||||
pullPresence = do |
||||
c <- getPresenceChan |
||||
liftIO $ atomically $ readTChan c |
||||
|
||||
-- | Send a stanza to the server |
||||
sendS :: Stanza -> XMPPThread () |
||||
sendS a = do |
||||
out <- asks outCh |
||||
liftIO . atomically $ writeTChan out a |
||||
return () |
||||
|
||||
-- | Fork a new thread |
||||
forkXMPP :: XMPPThread () -> XMPPThread ThreadId |
||||
forkXMPP a = do |
||||
thread <- ask |
||||
mCH' <- liftIO $ newIORef Nothing |
||||
pCH' <- liftIO $ newIORef Nothing |
||||
liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' |
||||
,presenceRef = pCH' |
||||
}) |
||||
|
||||
filterMessages :: (MessageError -> Bool) |
||||
-> (Message -> Bool) |
||||
-> XMPPThread (Either MessageError Message) |
||||
filterMessages f g = do |
||||
s <- pullMessage |
||||
case s of |
||||
Left e | f e -> return $ Left e |
||||
| otherwise -> filterMessages f g |
||||
Right m | g m -> return $ Right m |
||||
| otherwise -> filterMessages f g |
||||
|
||||
waitForMessage :: (Message -> Bool) -> XMPPThread Message |
||||
waitForMessage f = do |
||||
s <- pullMessage |
||||
case s of |
||||
Left _ -> waitForMessage f |
||||
Right m | f m -> return m |
||||
| otherwise -> waitForMessage f |
||||
|
||||
waitForMessageError :: (MessageError -> Bool) -> XMPPThread MessageError |
||||
waitForMessageError f = do |
||||
s <- pullMessage |
||||
case s of |
||||
Right _ -> waitForMessageError f |
||||
Left m | f m -> return m |
||||
| otherwise -> waitForMessageError f |
||||
|
||||
waitForPresence :: (Presence -> Bool) -> XMPPThread Presence |
||||
waitForPresence f = do |
||||
s <- pullPresence |
||||
case s of |
||||
Left _ -> waitForPresence f |
||||
Right m | f m -> return m |
||||
| otherwise -> waitForPresence f |
||||
|
||||
-- | Run an XMPPMonad action in isolation. |
||||
-- Reader and writer workers will be temporarily stopped |
||||
-- and resumed with the new session details once the action returns. |
||||
-- The Action will run in the reader thread. |
||||
withConnection :: XMPPConMonad () -> XMPPThread () |
||||
withConnection a = do |
||||
writeLock <- asks writeRef |
||||
rdr <- asks readerThread |
||||
_ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the |
||||
-- one returned by a |
||||
liftIO . throwTo rdr . ReaderSignal $ do |
||||
a |
||||
out <- gets sConPushBS |
||||
liftIO . atomically $ putTMVar writeLock out |
||||
return () |
||||
|
||||
sendPresence :: Presence -> XMPPThread () |
||||
sendPresence = sendS . PresenceS |
||||
|
||||
sendMessage :: Message -> XMPPThread () |
||||
sendMessage = sendS . MessageS |
||||
@ -0,0 +1,159 @@
@@ -0,0 +1,159 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
module Network.XMPP.Concurrent.Threads where |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
import Control.Applicative((<$>),(<*>)) |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import qualified Control.Exception.Lifted as Ex |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Reader |
||||
import Control.Monad.Trans.Resource |
||||
import Control.Monad.Trans.State |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import Data.Conduit |
||||
import qualified Data.Conduit.List as CL |
||||
import Data.Default (def) |
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Maybe |
||||
import qualified Data.Text as Text |
||||
|
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Marshal |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Concurrent.Types |
||||
|
||||
import Text.XML.Stream.Elements |
||||
import qualified Text.XML.Stream.Render as XR |
||||
|
||||
readWorker :: TChan (Either MessageError Message) |
||||
-> TChan (Either PresenceError Presence) |
||||
-> TVar IQHandlers |
||||
-> XMPPConState |
||||
-> ResourceT IO () |
||||
readWorker messageC presenceC handlers s = Ex.catch |
||||
(forever . flip runStateT s $ do |
||||
sta <- pull |
||||
liftIO .atomically $ do |
||||
case sta of |
||||
MessageS m -> do writeTChan messageC $ Right m |
||||
_ <- readTChan messageC -- Sic! |
||||
return () |
||||
-- this may seem ridiculous, but to prevent |
||||
-- the channel from filling up we immedtiately remove the |
||||
-- Stanza we just put in. It will still be |
||||
-- available in duplicates. |
||||
MessageErrorS m -> do writeTChan messageC $ Left m |
||||
_ <- readTChan messageC |
||||
return () |
||||
PresenceS p -> do |
||||
writeTChan presenceC $ Right p |
||||
_ <- readTChan presenceC |
||||
return () |
||||
PresenceErrorS p -> do |
||||
writeTChan presenceC $ Left p |
||||
_ <- readTChan presenceC |
||||
return () |
||||
|
||||
IQRequestS i -> handleIQRequest handlers i |
||||
IQResultS i -> handleIQResponse handlers (Right i) |
||||
IQErrorS i -> handleIQResponse handlers (Left i) |
||||
) |
||||
( \(ReaderSignal a) -> do |
||||
((),s') <- runStateT a s |
||||
readWorker messageC presenceC handlers s' |
||||
) |
||||
|
||||
handleIQRequest handlers iq = do |
||||
(byNS, _) <- readTVar handlers |
||||
let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) |
||||
case Map.lookup (iqRequestType iq, iqNS) byNS of |
||||
Nothing -> return () -- TODO: send error stanza |
||||
Just ch -> do |
||||
sent <- newTVar False |
||||
writeTChan ch (iq, sent) |
||||
|
||||
handleIQResponse handlers iq = do |
||||
(byNS, byID) <- readTVar handlers |
||||
case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of |
||||
(Nothing, _) -> return () -- we are not supposed |
||||
-- to send an error |
||||
(Just tmvar, byID') -> do |
||||
_ <- tryPutTMVar tmvar iq -- don't block |
||||
writeTVar handlers (byNS, byID') |
||||
where |
||||
iqID (Left err) = iqErrorID err |
||||
iqID (Right iq) = iqResultID iq |
||||
|
||||
writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () |
||||
writeWorker stCh writeR = forever $ do |
||||
(write, next) <- atomically $ (,) <$> |
||||
takeTMVar writeR <*> |
||||
readTChan stCh |
||||
outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) |
||||
$= XR.renderBytes def $$ CL.consume |
||||
_ <- forM outBS write |
||||
atomically $ putTMVar writeR write |
||||
|
||||
-- Two streams: input and output. Threads read from input stream and write to output stream. |
||||
-- | Runs thread in XmppState monad |
||||
-- returns channel of incoming and outgoing stances, respectively |
||||
-- and an Action to stop the Threads and close the connection |
||||
startThreads |
||||
:: XMPPConMonad ( TChan (Either MessageError Message) |
||||
, TChan (Either PresenceError Presence) |
||||
, TVar IQHandlers |
||||
, TChan Stanza, IO () |
||||
, TMVar (BS.ByteString -> IO ()) |
||||
, ThreadId |
||||
) |
||||
|
||||
startThreads = do |
||||
writeLock <- liftIO . newTMVarIO =<< gets sConPushBS |
||||
messageC <- liftIO newTChanIO |
||||
presenceC <- liftIO newTChanIO |
||||
iqC <- liftIO newTChanIO |
||||
outC <- liftIO newTChanIO |
||||
handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) |
||||
lw <- liftIO . forkIO $ writeWorker outC writeLock |
||||
cp <- liftIO . forkIO $ connPersist writeLock |
||||
s <- get |
||||
rd <- lift . resourceForkIO $ readWorker messageC presenceC handlers s |
||||
return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) |
||||
where |
||||
killConnection writeLock threads = liftIO $ do |
||||
_ <- atomically $ takeTMVar writeLock -- Should we put it back? |
||||
_ <- forM threads killThread |
||||
return() |
||||
|
||||
|
||||
-- | Start worker threads and run action. The supplied action will run |
||||
-- in the calling thread. use 'forkXMPP' to start another thread. |
||||
runThreaded :: XMPPThread a |
||||
-> XMPPConMonad a |
||||
runThreaded a = do |
||||
(mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads |
||||
workermCh <- liftIO . newIORef $ Nothing |
||||
workerpCh <- liftIO . newIORef $ Nothing |
||||
idRef <- liftIO $ newTVarIO 1 |
||||
let getId = atomically $ do |
||||
curId <- readTVar idRef |
||||
writeTVar idRef (curId + 1 :: Integer) |
||||
return . read. show $ curId |
||||
liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) |
||||
|
||||
-- | Sends a blank space every 30 seconds to keep the connection alive |
||||
connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () |
||||
connPersist lock = forever $ do |
||||
pushBS <- atomically $ takeTMVar lock |
||||
pushBS " " |
||||
atomically $ putTMVar lock pushBS |
||||
-- putStrLn "<space added>" |
||||
threadDelay 30000000 |
||||
@ -0,0 +1,48 @@
@@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-} |
||||
|
||||
module Network.XMPP.Concurrent.Types where |
||||
|
||||
import qualified Control.Exception.Lifted as Ex |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad.Trans.Reader |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Text(Text) |
||||
import Data.Typeable |
||||
|
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
|
||||
type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) |
||||
, Map.Map StanzaId (TMVar IQResponse) |
||||
) |
||||
|
||||
data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either |
||||
MessageError |
||||
Message |
||||
))) |
||||
, presenceRef :: IORef (Maybe (TChan (Either |
||||
PresenceError |
||||
Presence |
||||
))) |
||||
, mShadow :: TChan (Either MessageError |
||||
Message) -- the original chan |
||||
, pShadow :: TChan (Either PresenceError |
||||
Presence) -- the original chan |
||||
, outCh :: TChan Stanza |
||||
, iqHandlers :: TVar IQHandlers |
||||
, writeRef :: TMVar (BS.ByteString -> IO () ) |
||||
, readerThread :: ThreadId |
||||
, idGenerator :: IO StanzaId |
||||
} |
||||
|
||||
type XMPPThread a = ReaderT Thread IO a |
||||
|
||||
|
||||
data ReaderSignal = ReaderSignal (XMPPConMonad ()) deriving Typeable |
||||
instance Show ReaderSignal where show _ = "<ReaderSignal>" |
||||
instance Ex.Exception ReaderSignal |
||||
@ -0,0 +1,195 @@
@@ -0,0 +1,195 @@
|
||||
{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} |
||||
|
||||
module Network.XMPP.Marshal where |
||||
|
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
stanzaSel :: Stanza -> Int |
||||
stanzaSel (IQRequestS _) = 0 |
||||
stanzaSel (IQResultS _) = 1 |
||||
stanzaSel (IQErrorS _) = 2 |
||||
stanzaSel (MessageS _) = 3 |
||||
stanzaSel (MessageErrorS _) = 4 |
||||
stanzaSel (PresenceS _) = 5 |
||||
stanzaSel (PresenceErrorS _) = 6 |
||||
|
||||
stanzaP :: PU [Node] Stanza |
||||
stanzaP = xpAlt stanzaSel |
||||
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest |
||||
, xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult |
||||
, xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError |
||||
, xpWrap MessageS (\(MessageS x) -> x) xpMessage |
||||
, xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError |
||||
, xpWrap PresenceS (\(PresenceS x) -> x) xpPresence |
||||
, xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError |
||||
] |
||||
|
||||
xmlLang :: Name |
||||
xmlLang = Name "lang" Nothing (Just "xml") |
||||
|
||||
xpLangTag :: PU [Attribute] (Maybe LangTag) |
||||
xpLangTag = xpAttrImplied xmlLang xpPrim |
||||
|
||||
xpMessage :: PU [Node] (Message) |
||||
xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) |
||||
-> Message qid from to lang tp sub thr body ext) |
||||
(\(Message qid from to lang tp sub thr body ext) |
||||
-> ((tp, qid, from, to, lang), (sub, body, thr, ext))) |
||||
$ |
||||
xpElem "{jabber:client}message" |
||||
(xp5Tuple |
||||
(xpDefault Normal $ xpAttr "type" xpPrim) |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
-- TODO: NS? |
||||
) |
||||
(xp4Tuple |
||||
(xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId) |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
|
||||
xpPresence :: PU [Node] Presence |
||||
xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext)) |
||||
-> Presence qid from to lang tp shw stat prio ext) |
||||
(\(Presence qid from to lang tp shw stat prio ext) |
||||
-> ((qid, from, to, lang, tp), (shw, stat, prio, ext))) |
||||
$ |
||||
xpElem "{jabber:client}presence" |
||||
(xp5Tuple |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
(xpAttrImplied "type" xpPrim) |
||||
) |
||||
(xp4Tuple |
||||
(xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim) |
||||
(xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim) |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpIQRequest :: PU [Node] IQRequest |
||||
xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body) |
||||
-> IQRequest qid from to lang tp body) |
||||
(\(IQRequest qid from to lang tp body) |
||||
-> ((qid, from, to, lang, tp), body)) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttr "type" xpPrim)) |
||||
) |
||||
(xpElemVerbatim) |
||||
|
||||
xpIQResult :: PU [Node] IQResult |
||||
xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body) |
||||
-> IQResult qid from to lang body) |
||||
(\(IQResult qid from to lang body) |
||||
-> ((qid, from, to, lang, ()), body)) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttrFixed "type" "result")) |
||||
) |
||||
(xpOption xpElemVerbatim) |
||||
|
||||
---------------------------------------------------------- |
||||
-- Errors |
||||
---------------------------------------------------------- |
||||
|
||||
xpErrorCondition :: PU [Node] StanzaErrorCondition |
||||
xpErrorCondition = xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) $ |
||||
xpElemByNamespace |
||||
"urn:ietf:params:xml:ns:xmpp-stanzas" xpPrim |
||||
xpUnit |
||||
xpUnit |
||||
|
||||
xpStanzaError :: PU [Node] StanzaError |
||||
xpStanzaError = xpWrap |
||||
(\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) |
||||
(\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) $ |
||||
xpElem "{jabber:client}error" |
||||
(xpAttr "type" xpPrim) |
||||
(xp3Tuple |
||||
xpErrorCondition |
||||
(xpOption $ xpElem "{jabber:client}text" |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
(xpContent xpId) |
||||
) |
||||
(xpOption xpElemVerbatim) |
||||
) |
||||
|
||||
xpMessageError :: PU [Node] (MessageError) |
||||
xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext)) |
||||
-> MessageError qid from to lang err ext) |
||||
(\(MessageError qid from to lang err ext) |
||||
-> (((), qid, from, to, lang), (err, ext))) |
||||
$ |
||||
xpElem "{jabber:client}message" |
||||
(xp5Tuple |
||||
(xpAttrFixed "type" "error") |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
-- TODO: NS? |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpPresenceError :: PU [Node] PresenceError |
||||
xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext)) |
||||
-> PresenceError qid from to lang err ext) |
||||
(\(PresenceError qid from to lang err ext) |
||||
-> ((qid, from, to, lang, ()), (err, ext))) |
||||
$ |
||||
xpElem "{jabber:client}presence" |
||||
(xp5Tuple |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
(xpAttrFixed "type" "error") |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpIQError :: PU [Node] IQError |
||||
xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) |
||||
-> IQError qid from to lang err body) |
||||
(\(IQError qid from to lang err body) |
||||
-> ((qid, from, to, lang, ()), (err, body))) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttrFixed "type" "error")) |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpOption xpElemVerbatim) |
||||
) |
||||
|
||||
@ -0,0 +1,36 @@
@@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE RecordWildCards #-} |
||||
module Network.XMPP.Message where |
||||
|
||||
import Data.Text(Text) |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
message :: Message |
||||
message = Message { messageID = Nothing |
||||
, messageFrom = Nothing |
||||
, messageTo = Nothing |
||||
, messageLangTag = Nothing |
||||
, messageType = Normal |
||||
, messageSubject = Nothing |
||||
, messageThread = Nothing |
||||
, messageBody = Nothing |
||||
, messagePayload = [] |
||||
} |
||||
|
||||
simpleMessage :: JID -> Text -> Message |
||||
simpleMessage to txt = message { messageTo = Just to |
||||
, messageBody = Just txt |
||||
} |
||||
|
||||
answerMessage :: Message -> Text -> [Element] -> Maybe Message |
||||
answerMessage Message{messageFrom = Just frm, ..} txt payload = |
||||
Just $ Message{ messageFrom = messageTo |
||||
, messageID = Nothing |
||||
, messageTo = Just frm |
||||
, messageBody = Just txt |
||||
, messagePayload = payload |
||||
, .. |
||||
} |
||||
answerMessage _ _ _ = Nothing |
||||
|
||||
@ -0,0 +1,83 @@
@@ -0,0 +1,83 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Monad where |
||||
|
||||
import Control.Applicative((<$>)) |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Resource |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.ByteString as BS |
||||
import Data.Conduit |
||||
import Data.Conduit.Binary as CB |
||||
import Data.Conduit.List as CL |
||||
import Data.Text(Text) |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Marshal |
||||
import Network.XMPP.Pickle |
||||
|
||||
import System.IO |
||||
|
||||
import Text.XML.Stream.Elements |
||||
import Text.XML.Stream.Parse as XP |
||||
import Text.XML.Stream.Render as XR |
||||
|
||||
|
||||
pushN :: Element -> XMPPConMonad () |
||||
pushN x = do |
||||
sink <- gets sConPush |
||||
lift . sink $ elementToEvents x |
||||
|
||||
push :: Stanza -> XMPPConMonad () |
||||
push = pushN . pickleElem stanzaP |
||||
|
||||
pushOpen :: Element -> XMPPConMonad () |
||||
pushOpen e = do |
||||
sink <- gets sConPush |
||||
lift . sink $ openElementToEvents e |
||||
return () |
||||
|
||||
pulls :: Sink Event (ResourceT IO) b -> XMPPConMonad b |
||||
pulls snk = do |
||||
source <- gets sConSrc |
||||
(src', r) <- lift $ source $$+ snk |
||||
modify $ (\s -> s {sConSrc = src'}) |
||||
return r |
||||
|
||||
pullE :: XMPPConMonad Element |
||||
pullE = pulls elementFromEvents |
||||
|
||||
pullPickle :: PU [Node] a -> XMPPConMonad a |
||||
pullPickle p = unpickleElem p <$> pullE |
||||
|
||||
pull :: XMPPConMonad Stanza |
||||
pull = pullPickle stanzaP |
||||
|
||||
xmppFromHandle :: Handle |
||||
-> Text |
||||
-> Text |
||||
-> Maybe Text |
||||
-> XMPPConMonad a |
||||
-> IO (a, XMPPConState) |
||||
xmppFromHandle handle hostname username res f = runResourceT $ do |
||||
liftIO $ hSetBuffering handle NoBuffering |
||||
let raw = CB.sourceHandle handle |
||||
let src = raw $= XP.parseBytes def |
||||
let st = XMPPConState |
||||
src |
||||
(raw) |
||||
(\xs -> CL.sourceList xs |
||||
$$ XR.renderBytes def =$ CB.sinkHandle handle) |
||||
(BS.hPut handle) |
||||
(Just handle) |
||||
(SF Nothing [] []) |
||||
False |
||||
hostname |
||||
username |
||||
res |
||||
runStateT f st |
||||
|
||||
@ -0,0 +1,64 @@
@@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE TupleSections #-} |
||||
|
||||
-- Marshalling between XML and Native Types |
||||
|
||||
|
||||
module Network.XMPP.Pickle where |
||||
|
||||
import Data.XML.Types |
||||
import Data.XML.Pickle |
||||
|
||||
|
||||
mbToBool :: Maybe t -> Bool |
||||
mbToBool (Just _) = True |
||||
mbToBool _ = False |
||||
|
||||
xpElemEmpty :: Name -> PU [Node] () |
||||
xpElemEmpty name = xpWrap (\((),()) -> ()) |
||||
(\() -> ((),())) $ |
||||
xpElem name xpUnit xpUnit |
||||
|
||||
-- xpElemExists :: Name -> PU [Node] Bool |
||||
-- xpElemExists name = xpWrap (\x -> mbToBool x) |
||||
-- (\x -> if x then Just () else Nothing) $ |
||||
-- xpOption (xpElemEmpty name) |
||||
|
||||
|
||||
xpNodeElem :: PU [Node] a -> PU Element a |
||||
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> |
||||
case y of |
||||
NodeElement e -> [e] |
||||
_ -> [] |
||||
, unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of |
||||
Left l -> Left l |
||||
Right (a,(_,c)) -> Right (a,(Nothing,c)) |
||||
} |
||||
|
||||
ignoreAttrs :: PU t ((), b) -> PU t b |
||||
ignoreAttrs = xpWrap snd ((),) |
||||
|
||||
mbl :: Maybe [a] -> [a] |
||||
mbl (Just l) = l |
||||
mbl Nothing = [] |
||||
|
||||
lmb :: [t] -> Maybe [t] |
||||
lmb [] = Nothing |
||||
lmb x = Just x |
||||
|
||||
right :: Either [Char] t -> t |
||||
right (Left l) = error l |
||||
right (Right r) = r |
||||
|
||||
|
||||
unpickleElem :: PU [Node] c -> Element -> c |
||||
unpickleElem p x = case unpickle (xpNodeElem p) x of |
||||
Left l -> error $ l ++ "\n saw: " ++ show x |
||||
Right r -> r |
||||
|
||||
pickleElem :: PU [Node] a -> a -> Element |
||||
pickleElem p = pickle $ xpNodeElem p |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,78 @@
@@ -0,0 +1,78 @@
|
||||
module Network.XMPP.Presence where |
||||
|
||||
import Data.Text(Text) |
||||
import Network.XMPP.Types |
||||
|
||||
|
||||
presence :: Presence |
||||
presence = Presence { presenceID = Nothing |
||||
, presenceFrom = Nothing |
||||
, presenceTo = Nothing |
||||
, presenceLangTag = Nothing |
||||
, presenceType = Nothing |
||||
, presenceShowType = Nothing |
||||
, presenceStatus = Nothing |
||||
, presencePriority = Nothing |
||||
, presencePayload = [] |
||||
} |
||||
|
||||
presenceSubscribe :: JID -> Presence |
||||
presenceSubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribe |
||||
} |
||||
|
||||
-- | Is presence a subscription request |
||||
isPresenceSubscribe :: Presence -> Bool |
||||
isPresenceSubscribe pres = presenceType pres == (Just Subscribe) |
||||
|
||||
-- | Approve a subscripton of an entity |
||||
presenceSubscribed :: JID -> Presence |
||||
presenceSubscribed to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribed |
||||
} |
||||
|
||||
-- | Is presence a subscription approval |
||||
isPresenceSubscribed :: Presence -> Bool |
||||
isPresenceSubscribed pres = presenceType pres == (Just Subscribed) |
||||
|
||||
-- | End a subscription with an entity |
||||
presenceUnsubscribe :: JID -> Presence |
||||
presenceUnsubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Unsubscribed |
||||
} |
||||
|
||||
-- | Is presence an unsubscription request |
||||
isPresenceUnsubscribe :: Presence -> Bool |
||||
isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) |
||||
|
||||
-- | Signals to the server that the client is available for communication |
||||
presenceOnline :: Presence |
||||
presenceOnline = presence |
||||
|
||||
-- | Signals to the server that the client is no longer available for communication. |
||||
presenceOffline :: Presence |
||||
presenceOffline = presence {presenceType = Just Unavailable} |
||||
|
||||
status |
||||
:: Maybe Text -- ^ Status message |
||||
-> Maybe ShowType -- ^ Status Type |
||||
-> Maybe Int -- ^ Priority |
||||
-> Presence |
||||
status txt showType prio = presence { presenceShowType = showType |
||||
, presencePriority = prio |
||||
, presenceStatus = txt |
||||
} |
||||
|
||||
-- | Sets the current availability status. This implicitly sets the clients |
||||
-- status online |
||||
presenceAvail :: ShowType -> Presence |
||||
presenceAvail showType = status Nothing (Just showType) Nothing |
||||
|
||||
-- | Sets the current status message. This implicitly sets the clients |
||||
-- status online |
||||
presenceMessage :: Text -> Presence |
||||
presenceMessage txt = status (Just txt) Nothing Nothing |
||||
|
||||
-- | Adds a recipient to a presence notification |
||||
presTo :: Presence -> JID -> Presence |
||||
presTo pres to = pres{presenceTo = Just to} |
||||
@ -1,372 +1,35 @@
@@ -1,372 +1,35 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Session where |
||||
|
||||
-- TODO: Predicates on callbacks? |
||||
-- TODO: . vs $ |
||||
-- TODO: type XMPP = XMPPT IO? + runXMPP |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types(Element) |
||||
|
||||
|
||||
{-# LANGUAGE ExistentialQuantification #-} |
||||
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
|
||||
|
||||
module Network.XMPP.Session ( |
||||
XMPPT (runXMPPT) |
||||
, hookStreamsOpenedEvent |
||||
, hookDisconnectedEvent |
||||
, destroy |
||||
, openStreams |
||||
, create |
||||
, DisconnectReason |
||||
) where |
||||
|
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Utilities |
||||
|
||||
import Control.Concurrent (Chan, forkIO, forkOS, newChan, readChan, writeChan) |
||||
import Control.Monad.IO.Class (MonadIO, liftIO) |
||||
import Data.Certificate.X509 (X509) |
||||
import Data.Dynamic (Dynamic) |
||||
-- import Control.Monad.Reader (MonadReader, ReaderT, ask) |
||||
import Control.Monad.State.Lazy (MonadState, StateT, get, put, execStateT) |
||||
sessionXML :: Element |
||||
sessionXML = pickleElem |
||||
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) |
||||
() |
||||
|
||||
import qualified Control.Exception as CE |
||||
import qualified Network as N |
||||
import System.IO (BufferMode, BufferMode(NoBuffering)) |
||||
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) |
||||
import Codec.Binary.UTF8.String |
||||
|
||||
|
||||
|
||||
create :: MonadIO m => XMPPT m () -> m () |
||||
sessionIQ :: Stanza |
||||
sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" |
||||
, iqRequestFrom = Nothing |
||||
, iqRequestTo = Nothing |
||||
, iqRequestLangTag = Nothing |
||||
, iqRequestType = Set |
||||
, iqRequestPayload = sessionXML |
||||
} |
||||
|
||||
create main = do |
||||
chan <- liftIO $ newChan |
||||
idGen <- liftIO $ idGenerator "" |
||||
execStateT (runXMPPT init) (State chan idGen []) |
||||
xmppSession :: XMPPConMonad () |
||||
xmppSession = do |
||||
push $ sessionIQ |
||||
answer <- pull |
||||
let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer |
||||
return () |
||||
where |
||||
init = do |
||||
main |
||||
stateLoop |
||||
|
||||
|
||||
-- Internal events - events to be processed within Pontarius. |
||||
|
||||
-- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show) |
||||
|
||||
|
||||
instance Show (InternalEvent m) where |
||||
show _ = "InternalEvent" |
||||
|
||||
-- | |
||||
-- Events that may be emitted from Pontarius. |
||||
|
||||
data Event = -- ConnectedEvent (Either IntFailureReason Resource) |
||||
{-|-} OpenedStreamsEvent (Maybe OpenStreamsFailureReason) |
||||
-- | TLSSecuredEvent (Maybe TLSSecuringFailureReason) |
||||
-- | AuthenticatedEvent (Either AuthenticationFailureReason Resource) |
||||
| DisconnectedEvent DisconnectReason |
||||
-- | MessageEvent (Either MessageError Message) |
||||
-- | PresenceEvent (Either PresenceError Presence) |
||||
-- | IQEvent (Either IQResult IQRequest) |
||||
-- | forall a. Dynamic a => DynamicEvent a |
||||
deriving (Show) |
||||
|
||||
-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a |
||||
-- data DynamicEvent = DynamicEvent Dynamic |
||||
|
||||
|
||||
-- data ConnectedFailureReason |
||||
-- = COSFR OpenStreamsFailureReason |
||||
-- | CTSFR TLSSecureFailureReason |
||||
-- | CAFR AuthenticateFailureReason |
||||
|
||||
|
||||
-- The "hook modification" events have a higher priority than other events, and |
||||
-- are thus sent through a Chan of their own. The boolean returns value signals |
||||
-- whether or not the hook should be removed. |
||||
|
||||
-- data HookModification m |
||||
-- = MonadIO m => -- RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) (Maybe (ConnectedEvent -> Bool)) |
||||
-- | RegisterTLSSecuredHook (TLSSecuredEvent -> XMPPT m Bool) (Maybe (TLSSecuredEvent -> Bool)) |
||||
-- | RegisterAuthenticatedHook (AuthenticatedEvent -> XMPPT m Bool) (Maybe (AuthenticatedEvent -> Bool)) |
||||
-- -- | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool) |
||||
-- | RegisterDynamicHook (DynamicEvent -> XMPPT m Bool) (Maybe (DynamicEvent -> Bool)) |
||||
|
||||
|
||||
-- Reads an event from the internal event channel, processes it, |
||||
-- performs the generated impure actions, and loops. |
||||
|
||||
stateLoop :: MonadIO m => XMPPT m () |
||||
|
||||
stateLoop = do |
||||
rs <- get |
||||
event <- liftIO $ readChan $ evtChan rs |
||||
liftIO $ putStrLn $ "Processing " ++ (show event) ++ "..." |
||||
processEvent event |
||||
-- sequence_ IO actions frmo procesEvent? |
||||
stateLoop |
||||
|
||||
|
||||
-- Processes an internal event and generates a list of impure actions. |
||||
|
||||
processEvent :: MonadIO m => InternalEvent m -> XMPPT m () |
||||
|
||||
processEvent (OpenStreamsEvent h p) = openStreamAction h p |
||||
where |
||||
openStreamAction :: MonadIO m => HostName -> PortNumber -> XMPPT m () |
||||
openStreamAction h p = let p' = fromIntegral p |
||||
computation chan = do -- chan ugly |
||||
-- threadID <- |
||||
handle <- N.connectTo h (N.PortNumber p') |
||||
hSetBuffering handle NoBuffering |
||||
forkIO $ conduit chan (Left handle) -- This must be done after hSetBuffering |
||||
hPutStr handle $ encodeString "<stream:stream to='" ++ h ++ "' version='1.0' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>" -- didn't work with <?xml version='1.0'> |
||||
hFlush handle |
||||
return () |
||||
in do |
||||
rs <- get |
||||
result <- liftIO $ CE.try (computation $ evtChan rs) |
||||
case result of |
||||
Right () -> do |
||||
return () |
||||
-- -- lift $ liftIO $ putMVar (stateThreadID state) threadID |
||||
Left (CE.SomeException e) -> do -- TODO: Safe to do this? |
||||
fireStreamsOpenedEvent $ Just OpenStreamsFailureReason |
||||
-- Left error -> do |
||||
-- -- let clientState = stateClientState state |
||||
-- -- ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState |
||||
-- -- put $ state { stateShouldExit = True } |
||||
-- -- return $ Just e |
||||
-- return $ Just error |
||||
|
||||
|
||||
-- hookConnectedEvent :: MonadIO m => (ConnectedEvent -> XMPPT m Bool) -> (Maybe (ConnectedEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookConnectedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterConnectedHook cb pred) |
||||
|
||||
|
||||
-- | Hook the provided callback and (optional) predicate to the |
||||
-- "Streams Opened" event. |
||||
-- |
||||
-- The "Streams Opened" event will be fired when the stream:features element has been successfully received or an error has occurred. |
||||
|
||||
hookStreamsOpenedEvent :: MonadIO m => (Maybe OpenStreamsFailureReason -> XMPPT m Bool) -> (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) -> XMPPT m HookId |
||||
|
||||
hookStreamsOpenedEvent cb pred = do |
||||
rs <- get |
||||
hookId <- liftIO $ nextId $ hookIdGenerator rs |
||||
put $ rs { hooks = (HookId hookId, StreamsOpenedHook pred cb):hooks rs } |
||||
return $ HookId hookId |
||||
|
||||
|
||||
hookDisconnectedEvent :: MonadIO m => (DisconnectReason -> XMPPT m Bool) -> (Maybe (DisconnectReason -> XMPPT m Bool)) -> XMPPT m HookId |
||||
hookDisconnectedEvent cb pred = do |
||||
rs <- get |
||||
hookId <- liftIO $ nextId $ hookIdGenerator rs |
||||
-- TODO: Actually hook it. |
||||
return $ HookId hookId |
||||
|
||||
|
||||
-- hookTLSSecuredEvent :: MonadIO m => (TLSSecuredEvent -> XMPPT m Bool) -> (Maybe (TLSSecuredEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookTLSSecuredEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterTLSSecuredHook cb pred) |
||||
|
||||
|
||||
-- hookAuthenticatedEvent :: MonadIO m => (AuthenticatedEvent -> XMPPT m Bool) -> (Maybe (AuthenticatedEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookAuthenticatedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterAuthenticatedHook cb pred) |
||||
|
||||
|
||||
-- hookDynamicEvent :: MonadIO m => (DynamicEvent -> XMPPT m Bool) -> (Maybe (DynamicEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookDynamicEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterDynamicHook cb pred) |
||||
|
||||
|
||||
-- | Asynchronously request to open a stream to an XMPP server on the |
||||
-- given host name and port. |
||||
|
||||
openStreams :: MonadIO m => HostName -> PortNumber -> XMPPT m () |
||||
|
||||
openStreams h p = get >>= \rs -> liftIO $ writeChan (evtChan rs) (OpenStreamsEvent h p) |
||||
|
||||
|
||||
-- Like any other fire*Event function, it queries the hooks, filters |
||||
-- out the ones that are relevant, prepares them to be used with |
||||
-- processHook, and processes them. |
||||
|
||||
fireStreamsOpenedEvent :: MonadIO m => Maybe OpenStreamsFailureReason -> XMPPT m () |
||||
|
||||
fireStreamsOpenedEvent r = do |
||||
rs <- get |
||||
let hooks' = filterStreamsOpenedHooks $ hooks rs |
||||
sequence_ $ map (\(hookId, pred, cb) -> processHook hookId pred cb) $ map prepareStreamsOpenedHooks hooks' |
||||
return () |
||||
where |
||||
prepareStreamsOpenedHooks :: MonadIO m => Hook m -> (HookId, Maybe (XMPPT m Bool), XMPPT m Bool) |
||||
prepareStreamsOpenedHooks (hookId, StreamsOpenedHook pred cb) = |
||||
let pred' = case pred of |
||||
Nothing -> Nothing |
||||
Just pred'' -> Just $ pred'' r |
||||
cb' = cb r in (hookId, pred', cb') |
||||
|
||||
|
||||
-- Takes an optional predicate and a callback function, and excecutes |
||||
-- the callback function if the predicate does not exist, or exists |
||||
-- and is true, and returns True if the hook should be removed. |
||||
|
||||
processHook :: MonadIO m => HookId -> Maybe (XMPPT m Bool) -> XMPPT m Bool -> XMPPT m () |
||||
|
||||
processHook id pred cb = do |
||||
remove <- processHook' |
||||
if remove then do |
||||
rs <- get |
||||
put $ rs { hooks = removeHook id (hooks rs) } |
||||
else return () |
||||
where |
||||
processHook' = case pred of |
||||
Just pred' -> do |
||||
result <- pred' |
||||
if result then cb else return False |
||||
Nothing -> cb |
||||
|
||||
|
||||
destroy = destroy |
||||
|
||||
|
||||
filterStreamsOpenedHooks :: MonadIO m => [Hook m] -> [Hook m] |
||||
|
||||
filterStreamsOpenedHooks h = filter pred h |
||||
where |
||||
pred (_, StreamsOpenedHook _ _) = True |
||||
pred _ = False |
||||
|
||||
|
||||
removeHook :: MonadIO m => HookId -> [Hook m] -> [Hook m] |
||||
|
||||
removeHook id h = filter (\(id', _) -> id' /= id) h |
||||
|
||||
|
||||
-- tlsSecure = tlsSecure |
||||
|
||||
-- authenticate = authenticate |
||||
|
||||
|
||||
-- fireConnectedEvent = fireConnectedEvent |
||||
|
||||
|
||||
-- | |
||||
-- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and |
||||
-- hookAuthenticatedEvent, and is offered as a convenience function for clients |
||||
-- that doesn't need to perform any XMPP actions in-between opening the streams |
||||
-- and TLS securing the stream and\/or authenticating, allowing them to listen |
||||
-- for and manage one event instead of up to three. Just-values in the third and |
||||
-- fourth parameters will make connect TLS secure the stream and authenticate, |
||||
-- respectively. Most clients will want to hook to the Connected event using |
||||
-- hookConnectedEvent prior to using this function. |
||||
-- |
||||
-- The ConnectedEvent and StreamOpenedEvent are guaranteed to be generated upon |
||||
-- calling this function. So will a subset of the TLSSecuredEvent and |
||||
-- AuthenticatedEvent, depending on whether their functionalities are requested |
||||
-- using Just-values in the third and fourth parameters. |
||||
-- |
||||
-- connect is designed with the assupmtion that openStreams, tlsSecure, and |
||||
-- authenticate will not be used by the client. Calling those functions may |
||||
-- generate events that can cause connect to behave incorrectly. |
||||
|
||||
-- connect :: MonadIO m => HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m () |
||||
-- |
||||
-- connect h p Nothing Nothing = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- fireConnectedEvent Nothing |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p (Just t) Nothing = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing |
||||
-- tlsSecure |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent Nothing = do |
||||
-- fireConnectedEvent Nothing |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ CTSFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p Nothing (Just a) = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing |
||||
-- authenticate |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onAuthenticatedEvent (Right r) = do |
||||
-- fireConnectedEvent $ Just r |
||||
-- return False |
||||
-- |
||||
-- onAuthenticated (Left e) = do |
||||
-- fireConnectedEvent $ Left $ CAFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p (Just t) (Just a) = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing |
||||
-- tlsSecure |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent Nothing = do |
||||
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing |
||||
-- authenticate |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ CTSFR e |
||||
-- return False |
||||
-- |
||||
-- onAuthenticatedEvent (Right r) = do |
||||
-- fireConnectedEvent $ Just r |
||||
-- return False |
||||
-- |
||||
-- onAuthenticated (Left e) = do |
||||
-- fireConnectedEvent $ Left $ CAFR e |
||||
-- return False |
||||
@ -1,30 +1,59 @@
@@ -1,30 +1,59 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? |
||||
-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? |
||||
-- TODO: Compression? |
||||
-- TODO: Validate certificate |
||||
module Network.XMPP.TLS where |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
import Control.Monad |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.State |
||||
|
||||
module Network.XMPP.TLS (tlsParams) where |
||||
import Data.Conduit |
||||
import Data.Conduit.List as CL |
||||
import Data.Conduit.TLS as TLS |
||||
import Data.Default |
||||
import Data.XML.Types |
||||
|
||||
import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), |
||||
TLSParams (..), Version (SSL3, TLS10, TLS11), |
||||
defaultLogging, nullCompression) |
||||
import Network.TLS.Extra (cipher_AES128_SHA1) |
||||
import qualified Network.TLS as TLS |
||||
import qualified Network.TLS.Extra as TLS |
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.Types |
||||
|
||||
import qualified Text.XML.Stream.Render as XR |
||||
|
||||
tlsParams :: TLSParams |
||||
|
||||
tlsParams = TLSParams { pConnectVersion = TLS10 |
||||
, pAllowedVersions = [SSL3, TLS10,TLS11] |
||||
, pCiphers = [cipher_AES128_SHA1] |
||||
, pCompressions = [nullCompression] |
||||
starttlsE :: Element |
||||
starttlsE = |
||||
Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] |
||||
|
||||
exampleParams :: TLS.TLSParams |
||||
exampleParams = TLS.TLSParams { pConnectVersion = TLS.TLS10 |
||||
, pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] |
||||
, pCiphers = [TLS.cipher_AES128_SHA1] |
||||
, pCompressions = [TLS.nullCompression] |
||||
, pWantClientCert = False -- Used for servers |
||||
, pUseSecureRenegotiation = False -- No renegotiation |
||||
, pCertificates = [] -- TODO |
||||
, pLogging = defaultLogging -- TODO |
||||
, pLogging = TLS.defaultLogging -- TODO |
||||
, onCertificatesRecv = \ certificate -> |
||||
return CertificateUsageAccept } |
||||
return TLS.CertificateUsageAccept } |
||||
|
||||
xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () |
||||
xmppStartTLS params = do |
||||
features <- gets sFeatures |
||||
unless (stls features == Nothing) $ do |
||||
pushN starttlsE |
||||
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE |
||||
Just handle <- gets sConHandle |
||||
(raw, snk, psh) <- lift $ TLS.tlsinit params handle |
||||
modify (\x -> x |
||||
{ sRawSrc = raw |
||||
-- , sConSrc = -- Note: this momentarily leaves us in an |
||||
-- inconsistent state |
||||
, sConPush = \xs -> CL.sourceList xs |
||||
$$ XR.renderBytes def =$ snk |
||||
, sConPushBS = psh |
||||
}) |
||||
xmppRestartStream |
||||
modify (\s -> s{sHaveTLS = True}) |
||||
return () |
||||
|
||||
|
||||
@ -1,30 +0,0 @@
@@ -1,30 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? |
||||
-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? |
||||
-- TODO: Compression? |
||||
-- TODO: Validate certificate |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
module Network.XMPP.TLS (tlsParams) where |
||||
|
||||
import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), |
||||
TLSParams (..), Version (SSL3, TLS10, TLS11), |
||||
defaultLogging, nullCompression) |
||||
import Network.TLS.Extra (cipher_AES128_SHA1) |
||||
|
||||
|
||||
tlsParams :: TLSParams |
||||
|
||||
tlsParams = TLSParams { pConnectVersion = TLS10 |
||||
, pAllowedVersions = [SSL3, TLS10,TLS11] |
||||
, pCiphers = [cipher_AES128_SHA1] |
||||
, pCompressions = [nullCompression] |
||||
, pWantClientCert = False -- Used for servers |
||||
, pUseSecureRenegotiation = False -- No renegotiation |
||||
, pCertificates = [] -- TODO |
||||
, pLogging = defaultLogging -- TODO |
||||
, onCertificatesRecv = \ certificate -> |
||||
return CertificateUsageAccept } |
||||
@ -1,89 +0,0 @@
@@ -1,89 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
-- | |
||||
-- Module: $Header$ |
||||
-- Description: Pontarius API |
||||
-- Copyright: Copyright © 2010-2012 Jon Kristensen |
||||
-- License: Apache License 2.0 |
||||
-- |
||||
-- Maintainer: jon.kristensen@nejla.com |
||||
-- Stability: unstable |
||||
-- Portability: portable |
||||
-- |
||||
-- XMPP is an open standard, extendable, and secure communications |
||||
-- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is |
||||
-- an XMPP client library, implementing the core capabilities of XMPP |
||||
-- (RFC 6120). |
||||
-- |
||||
-- Developers using this library are assumed to understand how XMPP |
||||
-- works. |
||||
-- |
||||
-- This module will be documented soon. |
||||
-- |
||||
-- Note that we are not recommending anyone to use Pontarius XMPP at |
||||
-- this time as it's still in an experimental stage and will have its |
||||
-- API and data types modified frequently. |
||||
|
||||
module Network.XMPP ( -- Network.XMPP.JID |
||||
Address (..) |
||||
, Localpart |
||||
, Domainpart |
||||
, Resourcepart |
||||
, isFull |
||||
, isBare |
||||
, fromString |
||||
, fromStrings |
||||
|
||||
-- Network.XMPP.Session |
||||
, runXMPPT |
||||
, hookStreamsOpenedEvent |
||||
, hookDisconnectedEvent |
||||
, destroy |
||||
, openStreams |
||||
, create |
||||
|
||||
-- , ClientHandler (..) |
||||
-- , ClientState (..) |
||||
-- , ConnectResult (..) |
||||
-- , HostName |
||||
-- , Password |
||||
-- , PortNumber |
||||
-- , Resource |
||||
-- , Session |
||||
-- , TerminationReason |
||||
-- , UserName |
||||
-- , sendIQ |
||||
-- , sendPresence |
||||
-- , sendMessage |
||||
-- , connect |
||||
-- , openStreams |
||||
-- , tlsSecureStreams |
||||
-- , authenticate |
||||
-- , session |
||||
-- , OpenStreamResult (..) |
||||
-- , SecureWithTLSResult (..) |
||||
-- , AuthenticateResult (..) |
||||
|
||||
-- Network.XMPP.Stanza |
||||
, StanzaID (SID) |
||||
, From |
||||
, To |
||||
, LangTag |
||||
, MessageType (..) |
||||
, Message (..) |
||||
, PresenceType (..) |
||||
, Presence (..) |
||||
, IQ (..) |
||||
, iqPayloadNamespace |
||||
, iqPayload ) where |
||||
|
||||
import Network.XMPP.Address |
||||
-- import Network.XMPP.SASL |
||||
import Network.XMPP.Session |
||||
import Network.XMPP.Stanza |
||||
import Network.XMPP.Utilities |
||||
import Network.XMPP.Types |
||||
-- import Network.XMPP.TLS |
||||
import Network.XMPP.Stream |
||||
|
||||
@ -0,0 +1,116 @@
@@ -0,0 +1,116 @@
|
||||
{-# LANGUAGE PackageImports, OverloadedStrings #-} |
||||
module Example where |
||||
|
||||
import Network.XMPP |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
|
||||
import Data.Maybe |
||||
import Data.Text (Text) |
||||
import qualified Data.Text as Text |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Pickle |
||||
|
||||
import System.Environment |
||||
|
||||
testUser1 :: JID |
||||
testUser1 = read "testuser1@species64739.dyndns.org/bot1" |
||||
|
||||
testUser2 :: JID |
||||
testUser2 = read "testuser2@species64739.dyndns.org/bot2" |
||||
|
||||
supervisor :: JID |
||||
supervisor = read "uart14@species64739.dyndns.org" |
||||
|
||||
|
||||
attXmpp :: STM a -> XMPPThread a |
||||
attXmpp = liftIO . atomically |
||||
|
||||
testNS :: Text |
||||
testNS = "xmpp:library:test" |
||||
|
||||
data Payload = Payload Int Bool Text deriving (Eq, Show) |
||||
|
||||
payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) |
||||
(\(Payload counter flag message) ->((counter,flag) , message)) $ |
||||
xpElem (Name "request" (Just testNS) Nothing) |
||||
(xpPair |
||||
(xpAttr "counter" xpPrim) |
||||
(xpAttr "flag" xpPrim) |
||||
) |
||||
(xpElemNodes (Name "message" (Just testNS) Nothing) |
||||
(xpContent xpId)) |
||||
|
||||
invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) |
||||
|
||||
iqResponder = do |
||||
(free, chan) <- listenIQChan Get testNS |
||||
unless free $ liftIO $ putStrLn "Channel was already taken" |
||||
>> error "hanging up" |
||||
forever $ do |
||||
next@(iq,_) <- liftIO . atomically $ readTChan chan |
||||
let payload = unpickleElem payloadP $ iqRequestPayload iq |
||||
let answerPayload = invertPayload payload |
||||
let answerBody = pickleElem payloadP answerPayload |
||||
answerIQ next (Right $ Just answerBody) |
||||
|
||||
autoAccept :: XMPPThread () |
||||
autoAccept = forever $ do |
||||
st <- waitForPresence isPresenceSubscribe |
||||
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) |
||||
|
||||
sendUser = sendMessage . simpleMessage supervisor . Text.pack |
||||
|
||||
expect debug x y | x == y = debug "Ok." |
||||
| otherwise = do |
||||
let failMSG = "failed" ++ show x ++ " /= " ++ show y |
||||
debug failMSG |
||||
sendUser failMSG |
||||
|
||||
|
||||
runMain :: (String -> STM ()) -> Int -> IO () |
||||
runMain debug number = do |
||||
let (we, them, active) = case number of |
||||
1 -> (testUser1, testUser2,True) |
||||
2 -> (testUser2, testUser1,False) |
||||
_ -> error "Need either 1 or 2" |
||||
sessionConnect "localhost" |
||||
"species64739.dyndns.org" |
||||
(fromJust $ node we) (resource we) $ do |
||||
let debug' = liftIO . atomically . debug . |
||||
(("Thread " ++ show number ++ ":") ++) |
||||
withConnection $ xmppSASL "pwd" |
||||
xmppThreadedBind (resource we) |
||||
withConnection $ xmppSession |
||||
sendPresence presenceOnline |
||||
forkXMPP autoAccept |
||||
forkXMPP iqResponder |
||||
-- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] |
||||
let delay = if active then 1000000 else 5000000 |
||||
when active . void . forkXMPP $ do |
||||
forM [1..10] $ \count -> do |
||||
let message = Text.pack . show $ node we |
||||
let payload = Payload count (even count) (Text.pack $ show count) |
||||
let body = pickleElem payloadP payload |
||||
Right answer <- sendIQ' (Just them) Get Nothing body |
||||
let answerPayload = unpickleElem payloadP |
||||
(fromJust $ iqResultPayload answer) |
||||
expect debug' (invertPayload payload) answerPayload |
||||
liftIO $ threadDelay delay |
||||
sendUser "All tests done" |
||||
liftIO . forever $ threadDelay 10000000 |
||||
return () |
||||
return () |
||||
|
||||
|
||||
main = do |
||||
out <- newTChanIO |
||||
forkIO . forever $ atomically (readTChan out) >>= putStrLn |
||||
let debugOut = writeTChan out |
||||
forkIO $ runMain debugOut 1 |
||||
runMain debugOut 2 |
||||
|
||||
@ -0,0 +1,78 @@
@@ -0,0 +1,78 @@
|
||||
module Text.XML.Stream.Elements where |
||||
|
||||
import Control.Applicative ((<$>)) |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Resource as R |
||||
|
||||
import Data.Text as T |
||||
import Text.XML.Unresolved |
||||
import Data.XML.Types |
||||
|
||||
import Data.Conduit as C |
||||
import Data.Conduit.List as CL |
||||
|
||||
import Text.XML.Stream.Parse |
||||
|
||||
compressNodes :: [Node] -> [Node] |
||||
compressNodes [] = [] |
||||
compressNodes [x] = [x] |
||||
compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = |
||||
compressNodes $ NodeContent (ContentText $ x `T.append` y) : z |
||||
compressNodes (x:xs) = x : compressNodes xs |
||||
|
||||
elementFromEvents :: R.MonadThrow m => C.Sink Event m Element |
||||
elementFromEvents = do |
||||
x <- CL.peek |
||||
case x of |
||||
Just (EventBeginElement n as) -> goE n as |
||||
_ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x |
||||
where |
||||
many f = |
||||
go id |
||||
where |
||||
go front = do |
||||
x <- f |
||||
case x of |
||||
Nothing -> return $ front [] |
||||
Just y -> go (front . (:) y) |
||||
dropReturn x = CL.drop 1 >> return x |
||||
goE n as = do |
||||
CL.drop 1 |
||||
ns <- many goN |
||||
y <- CL.head |
||||
if y == Just (EventEndElement n) |
||||
then return $ Element n as $ compressNodes ns |
||||
else lift $ R.monadThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y |
||||
goN = do |
||||
x <- CL.peek |
||||
case x of |
||||
Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as |
||||
Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i |
||||
Just (EventContent c) -> dropReturn $ Just $ NodeContent c |
||||
Just (EventComment t) -> dropReturn $ Just $ NodeComment t |
||||
Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t |
||||
_ -> return Nothing |
||||
|
||||
|
||||
openElementToEvents :: Element -> [Event] |
||||
openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] |
||||
where |
||||
goM [] = id |
||||
goM [x] = (goM' x :) |
||||
goM (x:xs) = (goM' x :) . goM xs |
||||
goM' (MiscInstruction i) = EventInstruction i |
||||
goM' (MiscComment t) = EventComment t |
||||
goE (Element name as ns) = |
||||
(EventBeginElement name as :) |
||||
. goN ns |
||||
. (EventEndElement name :) |
||||
goN [] = id |
||||
goN [x] = goN' x |
||||
goN (x:xs) = goN' x . goN xs |
||||
goN' (NodeElement e) = goE e |
||||
goN' (NodeInstruction i) = (EventInstruction i :) |
||||
goN' (NodeContent c) = (EventContent c :) |
||||
goN' (NodeComment t) = (EventComment t :) |
||||
|
||||
elementToEvents :: Element -> [Event] |
||||
elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] |
||||
@ -0,0 +1,7 @@
@@ -0,0 +1,7 @@
|
||||
module Utils where |
||||
|
||||
whileJust f = do |
||||
f' <- f |
||||
case f' of |
||||
Just x -> x : whileJust f |
||||
Nothing -> [] |
||||
Loading…
Reference in new issue