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 @@ |
|||||||
|
[submodule "xml-types-pickle"] |
||||||
|
path = xml-types-pickle |
||||||
|
url = git@github.com:Philonous/xml-types-pickle.git |
||||||
@ -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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
|
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 @@ |
|||||||
|
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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
{-# LANGUAGE OverloadedStrings #-} |
||||||
-- Pontarius distribution for more details. |
|
||||||
|
|
||||||
|
module Network.XMPP.Session where |
||||||
|
|
||||||
-- TODO: Predicates on callbacks? |
import Data.XML.Pickle |
||||||
-- TODO: . vs $ |
import Data.XML.Types(Element) |
||||||
-- TODO: type XMPP = XMPPT IO? + runXMPP |
|
||||||
|
|
||||||
|
import Network.XMPP.Monad |
||||||
{-# LANGUAGE ExistentialQuantification #-} |
import Network.XMPP.Pickle |
||||||
{-# LANGUAGE MultiParamTypeClasses #-} |
|
||||||
|
|
||||||
|
|
||||||
module Network.XMPP.Session ( |
|
||||||
XMPPT (runXMPPT) |
|
||||||
, hookStreamsOpenedEvent |
|
||||||
, hookDisconnectedEvent |
|
||||||
, destroy |
|
||||||
, openStreams |
|
||||||
, create |
|
||||||
, DisconnectReason |
|
||||||
) where |
|
||||||
|
|
||||||
import Network.XMPP.Stream |
|
||||||
import Network.XMPP.Types |
import Network.XMPP.Types |
||||||
import Network.XMPP.Utilities |
|
||||||
|
|
||||||
import Control.Concurrent (Chan, forkIO, forkOS, newChan, readChan, writeChan) |
sessionXML :: Element |
||||||
import Control.Monad.IO.Class (MonadIO, liftIO) |
sessionXML = pickleElem |
||||||
import Data.Certificate.X509 (X509) |
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) |
||||||
import Data.Dynamic (Dynamic) |
() |
||||||
-- import Control.Monad.Reader (MonadReader, ReaderT, ask) |
|
||||||
import Control.Monad.State.Lazy (MonadState, StateT, get, put, execStateT) |
|
||||||
|
|
||||||
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 |
xmppSession :: XMPPConMonad () |
||||||
chan <- liftIO $ newChan |
xmppSession = do |
||||||
idGen <- liftIO $ idGenerator "" |
push $ sessionIQ |
||||||
execStateT (runXMPPT init) (State chan idGen []) |
answer <- pull |
||||||
|
let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer |
||||||
return () |
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 @@ |
|||||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
{-# LANGUAGE OverloadedStrings #-} |
||||||
-- Pontarius distribution for more details. |
|
||||||
|
|
||||||
-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? |
module Network.XMPP.TLS where |
||||||
-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? |
|
||||||
-- TODO: Compression? |
|
||||||
-- TODO: Validate certificate |
|
||||||
|
|
||||||
{-# 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), |
import qualified Network.TLS as TLS |
||||||
TLSParams (..), Version (SSL3, TLS10, TLS11), |
import qualified Network.TLS.Extra as TLS |
||||||
defaultLogging, nullCompression) |
import Network.XMPP.Monad |
||||||
import Network.TLS.Extra (cipher_AES128_SHA1) |
import Network.XMPP.Stream |
||||||
|
import Network.XMPP.Types |
||||||
|
|
||||||
|
import qualified Text.XML.Stream.Render as XR |
||||||
|
|
||||||
tlsParams :: TLSParams |
|
||||||
|
|
||||||
tlsParams = TLSParams { pConnectVersion = TLS10 |
starttlsE :: Element |
||||||
, pAllowedVersions = [SSL3, TLS10,TLS11] |
starttlsE = |
||||||
, pCiphers = [cipher_AES128_SHA1] |
Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] |
||||||
, pCompressions = [nullCompression] |
|
||||||
|
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 |
, pWantClientCert = False -- Used for servers |
||||||
, pUseSecureRenegotiation = False -- No renegotiation |
, pUseSecureRenegotiation = False -- No renegotiation |
||||||
, pCertificates = [] -- TODO |
, pCertificates = [] -- TODO |
||||||
, pLogging = defaultLogging -- TODO |
, pLogging = TLS.defaultLogging -- TODO |
||||||
, onCertificatesRecv = \ certificate -> |
, 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 @@ |
|||||||
-- 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 @@ |
|||||||
-- 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
|
module Utils where |
||||||
|
|
||||||
|
whileJust f = do |
||||||
|
f' <- f |
||||||
|
case f' of |
||||||
|
Just x -> x : whileJust f |
||||||
|
Nothing -> [] |
||||||
Loading…
Reference in new issue