{-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where import Network.Xmpp.Types import Control.Applicative((<$>)) import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar) import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict import Data.IORef import qualified Data.Map as Map import Data.Text(Text) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Monad -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- already handled, a new 'TChan' is created and returned as a 'Right' value. -- Otherwise, the already existing channel will be returned wrapped in a 'Left' -- value. Note that the 'Left' channel might need to be duplicated in order not -- to interfere with existing consumers. listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) -> Text -- ^ Namespace of the child element -> Session -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) listenIQChan tp ns session = do let handlers = iqHandlers session atomically $ do (byNS, byID) <- readTVar handlers iqCh <- newTChan let (present, byNS') = Map.insertLookupWithKey' (\_ _ old -> old) (tp, ns) iqCh byNS writeTVar handlers (byNS', byID) return $ case present of Nothing -> Right iqCh Just iqCh' -> Left iqCh' -- | Get a duplicate of the stanza channel getStanzaChan :: Session -> IO (TChan Stanza) getStanzaChan session = atomically $ dupTChan (sShadow session) -- | 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 :: Session -> IO (TChan (Either MessageError Message)) getMessageChan session = do mCh <- readIORef $ messagesRef session case mCh of Nothing -> do mCh' <- atomically $ dupTChan (mShadow session) writeIORef (messagesRef session) (Just mCh') return mCh' Just mCh' -> return mCh' -- | Analogous to 'getMessageChan'. getPresenceChan :: Session -> IO (TChan (Either PresenceError Presence)) getPresenceChan session = do pCh <- readIORef $ presenceRef session case pCh of Nothing -> do pCh' <- atomically $ dupTChan (pShadow session) writeIORef (presenceRef session) (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 :: Session -> IO () dropMessageChan session = writeIORef (messagesRef session) Nothing -- | Analogous to 'dropMessageChan'. dropPresenceChan :: Session -> IO () dropPresenceChan session = writeIORef (presenceRef session) Nothing -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. pullMessage :: Session -> IO (Either MessageError Message) pullMessage session = do c <- getMessageChan session atomically $ readTChan c -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. pullPresence :: Session -> IO (Either PresenceError Presence) pullPresence session = do c <- getPresenceChan session atomically $ readTChan c -- | Send a stanza to the server. sendStanza :: Stanza -> Session -> IO () sendStanza a session = atomically $ writeTChan (outCh session) a -- | Create a forked session object forkSession :: Session -> IO Session forkSession session = do mCH' <- newIORef Nothing pCH' <- newIORef Nothing return $ session {messagesRef = mCH', presenceRef = pCH'} -- | Pulls a message and returns it if the given predicate returns @True@. filte yield x go src' in go src pontarius-xmpp-0.1.0.0/source/Data/Conduit/TLS.hs0000644000000000000000000000332412052012054017607 0ustar0000000000000000{-# Language NoMonomorphismRestriction #-} {-# OPTIONS_HADDOCK hide #-} module Data.Conduit.TLS ( tlsinit -- , conduitStdout , module TLS , module TLSExtra ) where import Control.Monad(liftM, when) import Control.Monad.IO.Class import Crypto.Random import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit import Control.Monad import Network.TLS as TLS import Network.TLS.Extra as TLSExtra import System.IO(Handle) client params gen handle = do contextNewOnHandle handle params gen defaultParams = defaultParamsClient tlsinit :: (MonadIO m, MonadIO m1) => Bool -> TLSParams -> Handle -> m ( Source m1 BS.ByteString , Sink BS.ByteString m1 () , BS.ByteString -> IO () , Context ) tlsinit debug tlsParams handle = do when debug . liftIO $ putStrLn "TLS with debug mode enabled" gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? con <- client tlsParams gen handle handshake con let src = forever $ do dt <- liftIO $ recvData con when debug (liftIO $ putStr "in: " >> BS.putStrLn dt) yield dt let snk = do d <- await case d of Nothing -> return () Just x -> do sendData con (BL.fromChunks [x]) when debug (liftIO $ putStr "out: " >> BS.putStrLn x) snk return ( src , snk , \s -> do when debug (liftIO $ BS.putStrLn s) sendData con $ BL.fromChunks [s] , con ) pontarius-xmpp-0.1.0.0/examples/0000755000000000000000000000000012052012054014647 5ustar0000000000000000pontarius-xmpp-0.1.0.0/examples/EchoClient.hs0000644000000000000000000000317712052012054017230 0ustar0000000000000000{- Copyright © 2010-2012 Jon Kristensen. This file (EchoClient.hs) illustrates how to connect, authenticate, set a simple presence, receive message stanzas, and echo them back to whoever is sending them, using Pontarius. The contents of this file may be used freely, as if it is in the public domain. -} {-# LANGUAGE OverloadedStrings #-} module Main (main) where import Control.Monad (forever) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromJust, isJust) import Network.Xmpp import Network.Xmpp.IM -- Server and authentication details. hostname = "localhost" -- portNumber = 5222 -- TODO username = "" password = "" resource = Nothing -- TODO: Incomplete code, needs documentation, etc. main :: IO () main = do session <- newSession withConnection (simpleConnect hostname username password resource) session sendPresence presenceOnline session echo session return () -- Pull message stanzas, verify that they originate from a `full' XMPP -- address, and, if so, `echo' the message back. echo :: Session -> IO () echo session = forever $ do result <- pullMessage session case result of Right message -> if (isJust $ messageFrom message) && (isFull $ fromJust $ messageFrom message) then do -- TODO: May not set from. sendMessage (Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message)) session liftIO $ putStrLn "Message echoed!" else liftIO $ putStrLn "Message sender is not set or is bare!" Left exception -> liftIO $ putStrLn "Error: "