asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

refactor xmppConMonad

master
Philipp Balzarek 13 years ago
parent
fff335db2d
commit
ff22fb3d48
21 changed files with 346 additions and 373 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      pontarius-xmpp.cabal
  2. 32
      source/Data/Conduit/BufferedSource.hs
  3. 6
      source/Network/Xmpp.hs
  4. 5
      source/Network/Xmpp/Basic.hs
  5. 8
      source/Network/Xmpp/Bind.hs
  6. 8
      source/Network/Xmpp/Concurrent/Channels.hs
  7. 107
      source/Network/Xmpp/Concurrent/Monad.hs
  8. 21
      source/Network/Xmpp/Concurrent/Threads.hs
  9. 5
      source/Network/Xmpp/Concurrent/Types.hs
  10. 154
      source/Network/Xmpp/Connection.hs
  11. 8
      source/Network/Xmpp/Sasl.hs
  12. 2
      source/Network/Xmpp/Sasl/Common.hs
  13. 2
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  14. 2
      source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
  15. 2
      source/Network/Xmpp/Sasl/Types.hs
  16. 53
      source/Network/Xmpp/Session.hs
  17. 31
      source/Network/Xmpp/Stream.hs
  18. 16
      source/Network/Xmpp/TLS.hs
  19. 89
      source/Network/Xmpp/Types.hs
  20. 70
      source/Network/Xmpp/Xep/InbandRegistration.hs
  21. 11
      source/Network/Xmpp/Xep/ServiceDiscovery.hs

1
pontarius-xmpp.cabal
Unescape View File

@ -82,7 +82,6 @@ Library
, Network.Xmpp.Concurrent.Threads , Network.Xmpp.Concurrent.Threads
, Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Monad
, Text.XML.Stream.Elements , Text.XML.Stream.Elements
, Data.Conduit.BufferedSource
, Data.Conduit.TLS , Data.Conduit.TLS
, Network.Xmpp.Sasl.Common , Network.Xmpp.Sasl.Common
, Network.Xmpp.Sasl.StringPrep , Network.Xmpp.Sasl.StringPrep

32
source/Data/Conduit/BufferedSource.hs
Unescape View File

@ -1,32 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Conduit.BufferedSource where
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Exception
import Data.IORef
import Data.Conduit
import Data.Typeable(Typeable)
import qualified Data.Conduit.Internal as DCI
import qualified Data.Conduit.List as CL
data SourceClosed = SourceClosed deriving (Show, Typeable)
instance Exception SourceClosed
newtype BufferedSource m o = BufferedSource
{ bs :: IORef (ResumableSource m o)
}
-- | Buffered source from conduit 0.3
bufferSource :: Monad m => Source m o -> IO (BufferedSource m o)
bufferSource s = do
srcRef <- newIORef $ DCI.ResumableSource s (return ())
return $ BufferedSource srcRef
(.$$+) (BufferedSource bs) snk = do
src <- liftIO $ readIORef bs
(src', r) <- src $$++ snk
liftIO $ writeIORef bs src'
return r

6
source/Network/Xmpp.hs
Unescape View File

@ -31,7 +31,7 @@ module Network.Xmpp
Context Context
, newContext , newContext
, withConnection , withConnection
, connect , connectTcp
, simpleConnect , simpleConnect
, startTLS , startTLS
, simpleAuth , simpleAuth
@ -93,6 +93,7 @@ module Network.Xmpp
, sendMessage , sendMessage
-- *** Receiving -- *** Receiving
, pullMessage , pullMessage
, getMessage
, waitForMessage , waitForMessage
, waitForMessageError , waitForMessageError
, filterMessages , filterMessages
@ -147,10 +148,13 @@ module Network.Xmpp
-- * Miscellaneous -- * Miscellaneous
, LangTag(..) , LangTag(..)
, exampleParams , exampleParams
, PortID(..)
) where ) where
import Data.XML.Types (Element) import Data.XML.Types (Element)
import Network
import Network.Xmpp.Bind import Network.Xmpp.Bind
import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent
import Network.Xmpp.Concurrent.Channels import Network.Xmpp.Concurrent.Channels

5
source/Network/Xmpp/Basic.hs
Unescape View File

@ -1,8 +1,7 @@
module Network.Xmpp.Basic module Network.Xmpp.Basic
( XmppConMonad ( Connection(..)
, XmppConnection(..)
, XmppConnectionState(..) , XmppConnectionState(..)
, connect , connectTcp
, simpleConnect , simpleConnect
, startTLS , startTLS
, simpleAuth , simpleAuth

8
source/Network/Xmpp/Bind.hs
Unescape View File

@ -28,15 +28,15 @@ bindBody = pickleElem $
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
-- resource and extract the JID from the non-error response. -- resource and extract the JID from the non-error response.
xmppBind :: Maybe Text -> XmppConMonad Jid xmppBind :: Maybe Text -> Connection -> IO Jid
xmppBind rsrc = do xmppBind rsrc c = do
answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) answer <- pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c
jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer
, Right jid <- unpickleElem xpJid b , Right jid <- unpickleElem xpJid b
-> return jid -> return jid
| otherwise -> throw $ StreamXMLError | otherwise -> throw $ StreamXMLError
("Bind couldn't unpickle JID from " ++ show answer) ("Bind couldn't unpickle JID from " ++ show answer)
modify (\s -> s{sJid = Just jid}) withConnection (modify $ \s -> s{sJid = Just jid}) c
return jid return jid
where where
-- Extracts the character data in the `jid' element. -- Extracts the character data in the `jid' element.

8
source/Network/Xmpp/Concurrent/Channels.hs
Unescape View File

@ -92,8 +92,8 @@ toChans messageC presenceC stanzaC iqHands sta = atomically $ do
-- | Creates and initializes a new Xmpp context. -- | Creates and initializes a new Xmpp context.
newContext :: IO Context newContext :: Connection -> IO Context
newContext = do newContext con = do
messageC <- newTChanIO messageC <- newTChanIO
presenceC <- newTChanIO presenceC <- newTChanIO
outC <- newTChanIO outC <- newTChanIO
@ -101,7 +101,7 @@ newContext = do
iqHandlers <- newTVarIO (Map.empty, Map.empty) iqHandlers <- newTVarIO (Map.empty, Map.empty)
eh <- newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } eh <- newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () }
let stanzaHandler = toChans messageC presenceC stanzaC iqHandlers let stanzaHandler = toChans messageC presenceC stanzaC iqHandlers
(kill, wLock, conState, readerThread) <- startThreadsWith stanzaHandler eh (kill, wLock, conState, readerThread) <- startThreadsWith stanzaHandler eh con
writer <- forkIO $ writeWorker outC wLock writer <- forkIO $ writeWorker outC wLock
workermCh <- newIORef $ Nothing workermCh <- newIORef $ Nothing
workerpCh <- newIORef $ Nothing workerpCh <- newIORef $ Nothing
@ -113,7 +113,7 @@ newContext = do
let sess = Session { writeRef = wLock let sess = Session { writeRef = wLock
, readerThread = readerThread , readerThread = readerThread
, idGenerator = getId , idGenerator = getId
, conStateRef = conState , conRef = conState
, eventHandlers = eh , eventHandlers = eh
, stopThreads = kill >> killThread writer , stopThreads = kill >> killThread writer
} }

107
source/Network/Xmpp/Concurrent/Monad.hs
Unescape View File

@ -4,18 +4,9 @@ module Network.Xmpp.Concurrent.Monad where
import Network.Xmpp.Types import Network.Xmpp.Types
import Control.Applicative((<$>))
import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad.IO.Class
import Control.Monad.Reader 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.Concurrent.Types
import Network.Xmpp.Connection import Network.Xmpp.Connection
@ -25,47 +16,47 @@ import Network.Xmpp.Connection
-- TODO: Wait for presence error? -- TODO: Wait for presence error?
-- | Run an XmppConMonad action in isolation. Reader and writer workers will be -- -- | Run an XmppConMonad action in isolation. Reader and writer workers will be
-- temporarily stopped and resumed with the new session details once the action -- -- temporarily stopped and resumed with the new session details once the action
-- returns. The action will run in the calling thread. Any uncaught exceptions -- -- returns. The action will run in the calling thread. Any uncaught exceptions
-- will be interpreted as connection failure. -- -- will be interpreted as connection failure.
withConnection :: XmppConMonad a -> Session -> IO (Either StreamError a) -- withConnection :: XmppConMonad a -> Session -> IO (Either StreamError a)
withConnection a session = do -- withConnection a session = do
wait <- newEmptyTMVarIO -- wait <- newEmptyTMVarIO
Ex.mask_ $ do -- Ex.mask_ $ do
-- Suspends the reader until the lock (wait) is released (set to `()'). -- -- Suspends the reader until the lock (wait) is released (set to `()').
throwTo (readerThread session) $ Interrupt wait -- throwTo (readerThread session) $ Interrupt wait
-- We acquire the write and stateRef locks, to make sure that this is -- -- We acquire the write and stateRef locks, to make sure that this is
-- the only thread that can write to the stream and to perform a -- -- the only thread that can write to the stream and to perform a
-- withConnection calculation. Afterwards, we release the lock and -- -- withConnection calculation. Afterwards, we release the lock and
-- fetches an updated state. -- -- fetches an updated state.
s <- Ex.catch -- s <- Ex.catch
(atomically $ do -- (atomically $ do
_ <- takeTMVar (writeRef session) -- _ <- takeTMVar (writeRef session)
s <- takeTMVar (conStateRef session) -- s <- takeTMVar (conStateRef session)
putTMVar wait () -- putTMVar wait ()
return s -- return s
) -- )
-- If we catch an exception, we have failed to take the MVars above. -- -- If we catch an exception, we have failed to take the MVars above.
(\e -> atomically (putTMVar wait ()) >> -- (\e -> atomically (putTMVar wait ()) >>
Ex.throwIO (e :: Ex.SomeException) -- Ex.throwIO (e :: Ex.SomeException)
) -- )
-- Run the XmppMonad action, save the (possibly updated) states, release -- -- Run the XmppMonad action, save the (possibly updated) states, release
-- the locks, and return the result. -- -- the locks, and return the result.
Ex.catches -- Ex.catches
(do -- (do
(res, s') <- runStateT a s -- (res, s') <- runStateT a s
atomically $ do -- atomically $ do
putTMVar (writeRef session) (cSend . sCon $ s') -- putTMVar (writeRef session) (cSend . sCon $ s')
putTMVar (conStateRef session) s' -- putTMVar (conStateRef session) s'
return $ Right res -- return $ Right res
) -- )
-- We treat all Exceptions as fatal. If we catch a StreamError, we -- -- We treat all Exceptions as fatal. If we catch a StreamError, we
-- return it. Otherwise, we throw an exception. -- -- return it. Otherwise, we throw an exception.
[ Ex.Handler $ \e -> return $ Left (e :: StreamError) -- [ Ex.Handler $ \e -> return $ Left (e :: StreamError)
, Ex.Handler $ \e -> runStateT xmppKillConnection s -- , Ex.Handler $ \e -> runStateT xmppKillConnection s
>> Ex.throwIO (e :: Ex.SomeException) -- >> Ex.throwIO (e :: Ex.SomeException)
] -- ]
-- | Executes a function to update the event handlers. -- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
@ -93,7 +84,7 @@ runHandler h session = h =<< atomically (readTVar $ eventHandlers session)
-- | End the current Xmpp session. -- | End the current Xmpp session.
endSession :: Session -> IO () endSession :: Session -> IO ()
endSession session = do -- TODO: This has to be idempotent (is it?) endSession session = do -- TODO: This has to be idempotent (is it?)
void $ withConnection xmppKillConnection session closeConnection session
stopThreads session stopThreads session
-- | Close the connection to the server. Closes the stream (by enforcing a -- | Close the connection to the server. Closes the stream (by enforcing a
@ -101,14 +92,8 @@ endSession session = do -- TODO: This has to be idempotent (is it?)
-- seconds, and then closes the connection. -- seconds, and then closes the connection.
closeConnection :: Session -> IO () closeConnection :: Session -> IO ()
closeConnection session = Ex.mask_ $ do closeConnection session = Ex.mask_ $ do
send <- atomically $ takeTMVar (writeRef session) (_send, connection) <- atomically $ liftM2 (,)
cc <- cClose . sCon <$> ( atomically $ readTMVar (conStateRef session)) (takeTMVar $ writeRef session)
send "</stream:stream>" (takeTMVar $ conRef session)
void . forkIO $ do _ <- closeStreams connection
threadDelay 3000000
-- When we close the connection, we close the handle that was used in the
-- sCloseConnection above. So even if a new connection has been
-- established at this point, it will not be affected by this action.
(Ex.try cc) :: IO (Either Ex.SomeException ())
return () return ()
atomically $ putTMVar (writeRef session) (\_ -> return False)

21
source/Network/Xmpp/Concurrent/Threads.hs
Unescape View File

@ -24,7 +24,7 @@ import GHC.IO (unsafeUnmask)
-- all listener threads. -- all listener threads.
readWorker :: (Stanza -> IO ()) readWorker :: (Stanza -> IO ())
-> (StreamError -> IO ()) -> (StreamError -> IO ())
-> TMVar XmppConnection -> TMVar Connection
-> IO a -> IO a
readWorker onStanza onConnectionClosed stateRef = readWorker onStanza onConnectionClosed stateRef =
Ex.mask_ . forever $ do Ex.mask_ . forever $ do
@ -32,12 +32,13 @@ readWorker onStanza onConnectionClosed stateRef =
-- we don't know whether pull will -- we don't know whether pull will
-- necessarily be interruptible -- necessarily be interruptible
s <- atomically $ do s <- atomically $ do
sr <- readTMVar stateRef con@(Connection con_) <- readTMVar stateRef
when (sConnectionState sr == XmppConnectionClosed) state <- sConnectionState <$> readTMVar con_
when (state == XmppConnectionClosed)
retry retry
return sr return con
allowInterrupt allowInterrupt
Just . fst <$> runStateT pullStanza s Just <$> pullStanza s
) )
[ Ex.Handler $ \(Interrupt t) -> do [ Ex.Handler $ \(Interrupt t) -> do
void $ handleInterrupts [t] void $ handleInterrupts [t]
@ -71,14 +72,16 @@ readWorker onStanza onConnectionClosed stateRef =
-- connection. -- connection.
startThreadsWith :: (Stanza -> IO ()) startThreadsWith :: (Stanza -> IO ())
-> TVar EventHandlers -> TVar EventHandlers
-> Connection
-> IO -> IO
(IO (), (IO (),
TMVar (BS.ByteString -> IO Bool), TMVar (BS.ByteString -> IO Bool),
TMVar XmppConnection, TMVar Connection,
ThreadId) ThreadId)
startThreadsWith stanzaHandler eh = do startThreadsWith stanzaHandler eh con = do
writeLock <- newTMVarIO (\_ -> return False) read <- withConnection' (gets $ cSend. cHand) con
conS <- newTMVarIO xmppNoConnection writeLock <- newTMVarIO read
conS <- newTMVarIO con
-- lw <- forkIO $ writeWorker outC writeLock -- lw <- forkIO $ writeWorker outC writeLock
cp <- forkIO $ connPersist writeLock cp <- forkIO $ connPersist writeLock
rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS

5
source/Network/Xmpp/Concurrent/Types.hs
Unescape View File

@ -8,9 +8,6 @@ import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.Map as Map
import Data.Text(Text)
import Data.Typeable import Data.Typeable
import Network.Xmpp.Types import Network.Xmpp.Types
@ -28,7 +25,7 @@ data Session = Session
, idGenerator :: IO StanzaId , idGenerator :: IO StanzaId
-- | Lock (used by withConnection) to make sure that a maximum of one -- | Lock (used by withConnection) to make sure that a maximum of one
-- XmppConMonad action is executed at any given time. -- XmppConMonad action is executed at any given time.
, conStateRef :: TMVar XmppConnection , conRef :: TMVar Connection
, eventHandlers :: TVar EventHandlers , eventHandlers :: TVar EventHandlers
, stopThreads :: IO () , stopThreads :: IO ()
} }

154
source/Network/Xmpp/Connection.hs
Unescape View File

@ -17,7 +17,7 @@ import Control.Monad.State.Strict
import Data.ByteString as BS import Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.Conduit.Binary as CB import Data.Conduit.Binary as CB
import Data.Conduit.BufferedSource import Data.Conduit.Internal as DCI
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.IORef import Data.IORef
import Data.Text(Text) import Data.Text(Text)
@ -41,41 +41,42 @@ import Text.XML.Unresolved(InvalidEventStream(..))
debug :: Bool debug :: Bool
debug = False debug = False
pushElement :: Element -> XmppConMonad Bool pushElement :: Element -> StateT Connection_ IO Bool
pushElement x = do pushElement x = do
send <- gets (cSend . sCon) send <- gets (cSend . cHand)
liftIO . send $ renderElement x liftIO . send $ renderElement x
-- | Encode and send stanza -- | Encode and send stanza
pushStanza :: Stanza -> XmppConMonad Bool pushStanza :: Stanza -> Connection -> IO Bool
pushStanza = pushElement . pickleElem xpStanza pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s
-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. -- XML documents and XMPP streams SHOULD be preceeded by an XML declaration.
-- UTF-8 is the only supported XMPP encoding. The standalone document -- UTF-8 is the only supported XMPP encoding. The standalone document
-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in -- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in
-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. -- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.
pushXmlDecl :: XmppConMonad Bool pushXmlDecl :: StateT Connection_ IO Bool
pushXmlDecl = do pushXmlDecl = do
con <- gets sCon con <- gets cHand
liftIO $ (cSend con) "<?xml version='1.0' encoding='UTF-8' ?>" liftIO $ (cSend con) "<?xml version='1.0' encoding='UTF-8' ?>"
pushOpenElement :: Element -> XmppConMonad Bool pushOpenElement :: Element -> StateT Connection_ IO Bool
pushOpenElement e = do pushOpenElement e = do
sink <- gets (cSend . sCon ) sink <- gets (cSend . cHand )
liftIO . sink $ renderOpenElement e liftIO . sink $ renderOpenElement e
-- `Connect-and-resumes' the given sink to the connection source, and pulls a -- `Connect-and-resumes' the given sink to the connection source, and pulls a
-- `b' value. -- `b' value.
pullToSinkEvents :: Sink Event IO b -> XmppConMonad b runEventsSink :: Sink Event IO b -> StateT Connection_ IO b
pullToSinkEvents snk = do runEventsSink snk = do
source <- gets (cEventSource . sCon) source <- gets cEventSource
r <- lift $ source .$$+ snk (src', r) <- lift $ source $$++ snk
modify (\s -> s{cEventSource = src'})
return r return r
pullElement :: XmppConMonad Element pullElement :: StateT Connection_ IO Element
pullElement = do pullElement = do
Ex.catches (do Ex.catches (do
e <- pullToSinkEvents (elements =$ await) e <- runEventsSink (elements =$ await)
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamConnectionError
Just r -> return r Just r -> return r
@ -85,12 +86,11 @@ pullElement = do
-> liftIO . Ex.throwIO $ StreamXMLError s) -> liftIO . Ex.throwIO $ StreamXMLError s)
, Ex.Handler $ \(e :: InvalidEventStream) , Ex.Handler $ \(e :: InvalidEventStream)
-> liftIO . Ex.throwIO $ StreamXMLError (show e) -> liftIO . Ex.throwIO $ StreamXMLError (show e)
] ]
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
pullPickle :: PU [Node] a -> XmppConMonad a pullUnpickle :: PU [Node] a -> StateT Connection_ IO a
pullPickle p = do pullUnpickle p = do
res <- unpickleElem p <$> pullElement res <- unpickleElem p <$> pullElement
case res of case res of
Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e)
@ -98,17 +98,17 @@ pullPickle p = do
-- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream -- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream
-- error. -- error.
pullStanza :: XmppConMonad Stanza pullStanza :: Connection -> IO Stanza
pullStanza = do pullStanza = withConnection' $ do
res <- pullPickle xpStreamStanza res <- pullUnpickle xpStreamStanza
case res of case res of
Left e -> liftIO . Ex.throwIO $ StreamError e Left e -> liftIO . Ex.throwIO $ StreamError e
Right r -> return r Right r -> return r
-- Performs the given IO operation, catches any errors and re-throws everything -- Performs the given IO operation, catches any errors and re-throws everything
-- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead -- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead
catchSend :: IO () -> IO Bool catchPush :: IO () -> IO Bool
catchSend p = Ex.catch catchPush p = Ex.catch
(p >> return True) (p >> return True)
(\e -> case GIE.ioe_type e of (\e -> case GIE.ioe_type e of
GIE.ResourceVanished -> return False GIE.ResourceVanished -> return False
@ -116,16 +116,16 @@ catchSend p = Ex.catch
_ -> Ex.throwIO e _ -> Ex.throwIO e
) )
-- -- XmppConnection state used when there is no connection. -- -- Connection_ state used when there is no connection.
xmppNoConnection :: XmppConnection xmppNoConnection :: Connection_
xmppNoConnection = XmppConnection xmppNoConnection = Connection_
{ sCon = Connection { cSend = \_ -> return False { cHand = Hand { cSend = \_ -> return False
, cRecv = \_ -> Ex.throwIO , cRecv = \_ -> Ex.throwIO
$ StreamConnectionError $ StreamConnectionError
, cEventSource = undefined
, cFlush = return () , cFlush = return ()
, cClose = return () , cClose = return ()
} }
, cEventSource = DCI.ResumableSource zeroSource (return ())
, sFeatures = SF Nothing [] [] , sFeatures = SF Nothing [] []
, sConnectionState = XmppConnectionClosed , sConnectionState = XmppConnectionClosed
, sHostname = Nothing , sHostname = Nothing
@ -142,31 +142,30 @@ xmppNoConnection = XmppConnection
zeroSource = liftIO . Ex.throwIO $ StreamConnectionError zeroSource = liftIO . Ex.throwIO $ StreamConnectionError
-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and -- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and
-- updates the XmppConMonad XmppConnection state. -- updates the XmppConMonad Connection_ state.
xmppConnectTCP :: HostName -> PortID -> Text -> XmppConMonad () connectTcpRaw :: HostName -> PortID -> Text -> IO Connection
xmppConnectTCP host port hostname = do connectTcpRaw host port hostname = do
hand <- liftIO $ do
h <- connectTo host port h <- connectTo host port
hSetBuffering h NoBuffering hSetBuffering h NoBuffering
return h let eSource = DCI.ResumableSource (sourceHandle h $= XP.parseBytes def)
eSource <- liftIO . bufferSource $ (sourceHandle hand) $= XP.parseBytes def (return ())
let con = Connection { cSend = if debug let hand = Hand { cSend = if debug
then \d -> do then \d -> do
BS.putStrLn (BS.append "out: " d) BS.putStrLn (BS.append "out: " d)
catchSend $ BS.hPut hand d catchPush $ BS.hPut h d
else catchSend . BS.hPut hand else catchPush . BS.hPut h
, cRecv = if debug then , cRecv = if debug then
\n -> do \n -> do
bs <- BS.hGetSome hand n bs <- BS.hGetSome h n
BS.putStrLn bs BS.putStrLn bs
return bs return bs
else BS.hGetSome hand else BS.hGetSome h
, cEventSource = eSource , cFlush = hFlush h
, cFlush = hFlush hand , cClose = hClose h
, cClose = hClose hand
} }
let st = XmppConnection let con = Connection_
{ sCon = con { cHand = hand
, cEventSource = eSource
, sFeatures = (SF Nothing [] []) , sFeatures = (SF Nothing [] [])
, sConnectionState = XmppConnectionPlain , sConnectionState = XmppConnectionPlain
, sHostname = (Just hostname) , sHostname = (Just hostname)
@ -178,55 +177,48 @@ xmppConnectTCP host port hostname = do
, sJidWhenPlain = False -- TODO: Allow user to set , sJidWhenPlain = False -- TODO: Allow user to set
, sFrom = Nothing , sFrom = Nothing
} }
put st mkConnection con
-- Execute a XmppConMonad computation.
xmppNewSession :: XmppConMonad a -> IO (a, XmppConnection)
xmppNewSession action = runStateT action xmppNoConnection
-- Closes the connection and updates the XmppConMonad XmppConnection state. -- Closes the connection and updates the XmppConMonad Connection_ state.
xmppKillConnection :: XmppConMonad (Either Ex.SomeException ()) killConnection :: Connection -> IO (Either Ex.SomeException ())
xmppKillConnection = do killConnection = withConnection $ do
cc <- gets (cClose . sCon) cc <- gets (cClose . cHand)
err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ()))
put xmppNoConnection put xmppNoConnection
return err return err
xmppReplaceConnection :: XmppConnection -> XmppConMonad (Either Ex.SomeException ())
xmppReplaceConnection newCon = do
cc <- gets (cClose . sCon)
err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ()))
put newCon
return err
-- Sends an IQ request and waits for the response. If the response ID does not -- Sends an IQ request and waits for the response. If the response ID does not
-- match the outgoing ID, an error is thrown. -- match the outgoing ID, an error is thrown.
xmppSendIQ' :: StanzaId pushIQ' :: StanzaId
-> Maybe Jid -> Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> XmppConMonad (Either IQError IQResult) -> Connection
xmppSendIQ' iqID to tp lang body = do -> IO (Either IQError IQResult)
pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body pushIQ' iqID to tp lang body con = do
res <- pullPickle $ xpEither xpIQError xpIQResult pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con
res <- pullStanza con
case res of case res of
Left e -> return $ Left e IQErrorS e -> return $ Left e
Right iq' -> do IQResultS r -> do
unless unless
(iqID == iqResultID iq') . liftIO . Ex.throwIO $ (iqID == iqResultID r) . liftIO . Ex.throwIO $
StreamXMLError StreamXMLError
("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ ("In sendIQ' IDs don't match: " ++ show iqID ++ " /= " ++
show (iqResultID iq') ++ " .") show (iqResultID r) ++ " .")
return $ Right iq' return $ Right r
_ -> liftIO . Ex.throwIO . StreamXMLError $
"sendIQ': unexpected stanza type "
-- | Send "</stream:stream>" and wait for the server to finish processing and to -- | Send "</stream:stream>" and wait for the server to finish processing and to
-- close the connection. Any remaining elements from the server and whether or -- close the connection. Any remaining elements from the server and whether or
-- not we received a </stream:stream> element from the server is returned. -- not we received a </stream:stream> element from the server is returned.
xmppCloseStreams :: XmppConMonad ([Element], Bool) closeStreams :: Connection -> IO ([Element], Bool)
xmppCloseStreams = do closeStreams = withConnection $ do
send <- gets (cSend . sCon) send <- gets (cSend . cHand)
cc <- gets (cClose . sCon) cc <- gets (cClose . cHand)
liftIO $ send "</stream:stream>" liftIO $ send "</stream:stream>"
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelay 3000000 threadDelay 3000000
@ -236,18 +228,18 @@ xmppCloseStreams = do
where where
-- Pulls elements from the stream until the stream ends, or an error is -- Pulls elements from the stream until the stream ends, or an error is
-- raised. -- raised.
collectElems :: [Element] -> XmppConMonad ([Element], Bool) collectElems :: [Element] -> StateT Connection_ IO ([Element], Bool)
collectElems elems = do collectElems es = do
result <- Ex.try pullElement result <- Ex.try pullElement
case result of case result of
Left StreamStreamEnd -> return (elems, True) Left StreamStreamEnd -> return (es, True)
Left _ -> return (elems, False) Left _ -> return (es, False)
Right elem -> collectElems (elem:elems) Right e -> collectElems (e:es)
debugConduit :: Pipe l ByteString ByteString u IO b debugConduit :: Pipe l ByteString ByteString u IO b
debugConduit = forever $ do debugConduit = forever $ do
s <- await s' <- await
case s of case s' of
Just s -> do Just s -> do
liftIO $ BS.putStrLn (BS.append "in: " s) liftIO $ BS.putStrLn (BS.append "in: " s)
yield s yield s

8
source/Network/Xmpp/Sasl.hs
Unescape View File

@ -30,7 +30,6 @@ import Data.Text (Text)
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Network.Xmpp.Connection import Network.Xmpp.Connection
import Network.Xmpp.Pickle
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Types import Network.Xmpp.Types
@ -44,8 +43,9 @@ import Network.Xmpp.Sasl.Mechanisms
-- success. -- success.
xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
-- corresponding handlers -- corresponding handlers
-> XmppConMonad (Either AuthError ()) -> Connection
xmppSasl handlers = do -> IO (Either AuthError ())
xmppSasl handlers = withConnection $ do
-- Chooses the first mechanism that is acceptable by both the client and the -- Chooses the first mechanism that is acceptable by both the client and the
-- server. -- server.
mechanisms <- gets $ saslMechanisms . sFeatures mechanisms <- gets $ saslMechanisms . sFeatures
@ -57,5 +57,5 @@ xmppSasl handlers = do
XmppConnectionClosed -> throwError AuthConnectionError XmppConnectionClosed -> throwError AuthConnectionError
_ -> do _ -> do
r <- handler r <- handler
_ <- ErrorT $ left AuthStreamError <$> xmppRestartStream _ <- ErrorT $ left AuthStreamError <$> restartStream
return r return r

2
source/Network/Xmpp/Sasl/Common.hs
Unescape View File

@ -113,7 +113,7 @@ saslInit mechanism payload = lift . pushElement . saslInitE mechanism $
-- | Pull the next element. -- | Pull the next element.
pullSaslElement :: SaslM SaslElement pullSaslElement :: SaslM SaslElement
pullSaslElement = do pullSaslElement = do
el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) el <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case el of case el of
Left e ->throwError $ AuthSaslFailure e Left e ->throwError $ AuthSaslFailure e
Right r -> return r Right r -> return r

2
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
Unescape View File

@ -35,8 +35,6 @@ import Network.Xmpp.Connection
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types

2
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
Unescape View File

@ -36,9 +36,9 @@ import qualified Data.ByteString as BS
import Data.XML.Types import Data.XML.Types
import Network.Xmpp.Connection import Network.Xmpp.Connection
import Network.Xmpp.Pickle
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Pickle
import qualified System.Random as Random import qualified System.Random as Random

2
source/Network/Xmpp/Sasl/Types.hs
Unescape View File

@ -29,7 +29,7 @@ data SaslElement = SaslSuccess (Maybe Text.Text)
-- | SASL mechanism XmppConnection computation, with the possibility of throwing -- | SASL mechanism XmppConnection computation, with the possibility of throwing
-- an authentication error. -- an authentication error.
type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a type SaslM a = ErrorT AuthError (StateT Connection_ IO) a
type Pairs = [(ByteString, ByteString)] type Pairs = [(ByteString, ByteString)]

53
source/Network/Xmpp/Session.hs
Unescape View File

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.Session where module Network.Xmpp.Session where
import qualified Control.Exception as Ex
import Control.Monad.Error import Control.Monad.Error
import Data.Text as Text import Data.Text as Text
import Data.XML.Pickle import Data.XML.Pickle
@ -10,6 +11,7 @@ import Network
import qualified Network.TLS as TLS import qualified Network.TLS as TLS
import Network.Xmpp.Bind import Network.Xmpp.Bind
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Channels
import Network.Xmpp.Connection import Network.Xmpp.Connection
import Network.Xmpp.Marshal import Network.Xmpp.Marshal
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
@ -45,28 +47,31 @@ simpleConnect :: HostName -- ^ Host to connect to
-> Text -- ^ Password -> Text -- ^ Password
-> Maybe Text -- ^ Desired resource (or Nothing to let the server -> Maybe Text -- ^ Desired resource (or Nothing to let the server
-- decide) -- decide)
-> XmppConMonad Jid -> IO Context
simpleConnect host port hostname username password resource = do simpleConnect host port hostname username password resource = do
connect host port hostname con' <- connectTcp host port hostname
startTLS exampleParams con <- case con' of
saslResponse <- simpleAuth username password resource Left e -> Ex.throwIO e
Right r -> return r
startTLS exampleParams con
saslResponse <- simpleAuth username password resource con
case saslResponse of case saslResponse of
Right jid -> return jid Right jid -> newContext con
Left e -> error $ show e Left e -> error $ show e
-- | Connect to host with given address. -- | Connect to host with given address.
connect :: HostName -> PortID -> Text -> XmppConMonad (Either StreamError ()) connectTcp :: HostName -> PortID -> Text -> IO (Either StreamError Connection)
connect address port hostname = do connectTcp address port hostname = do
xmppConnectTCP address port hostname con <- connectTcpRaw address port hostname
result <- xmppStartStream result <- withConnection startStream con
case result of case result of
Left e -> do Left e -> do
pushElement . pickleElem xpStreamError $ toError e withConnection (pushElement . pickleElem xpStreamError $ toError e)
xmppCloseStreams con
return () closeStreams con
Right () -> return () return $ Left e
return result Right () -> return $ Right con
where where
-- TODO: Descriptive texts in stream errors? -- TODO: Descriptive texts in stream errors?
toError (StreamNotStreamElement _name) = toError (StreamNotStreamElement _name) =
@ -100,9 +105,9 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
-- Sends the session IQ set element and waits for an answer. Throws an error if -- Sends the session IQ set element and waits for an answer. Throws an error if
-- if an IQ error stanza is returned from the server. -- if an IQ error stanza is returned from the server.
xmppStartSession :: XmppConMonad () startSession :: Connection -> IO ()
xmppStartSession = do startSession con = do
answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML answer <- pushIQ' "session" Nothing Set Nothing sessionXML con
case answer of case answer of
Left e -> error $ show e Left e -> error $ show e
Right _ -> return () Right _ -> return ()
@ -111,11 +116,12 @@ xmppStartSession = do
-- resource. -- resource.
auth :: [SaslHandler] auth :: [SaslHandler]
-> Maybe Text -> Maybe Text
-> XmppConMonad (Either AuthError Jid) -> Connection
auth mechanisms resource = runErrorT $ do -> IO (Either AuthError Jid)
ErrorT $ xmppSasl mechanisms auth mechanisms resource con = runErrorT $ do
jid <- lift $ xmppBind resource ErrorT $ xmppSasl mechanisms con
lift $ xmppStartSession jid <- lift $ xmppBind resource con
lift $ startSession con
return jid return jid
-- | Authenticate to the server with the given username and password -- | Authenticate to the server with the given username and password
@ -126,7 +132,8 @@ simpleAuth :: Text.Text -- ^ The username
-> Text.Text -- ^ The password -> Text.Text -- ^ The password
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the -> Maybe Text -- ^ The desired resource or 'Nothing' to let the
-- server assign one -- server assign one
-> XmppConMonad (Either AuthError Jid) -> Connection
-> IO (Either AuthError Jid)
simpleAuth username passwd resource = flip auth resource $ simpleAuth username passwd resource = flip auth resource $
[ -- TODO: scramSha1Plus [ -- TODO: scramSha1Plus
scramSha1 username Nothing passwd scramSha1 username Nothing passwd

31
source/Network/Xmpp/Stream.hs
Unescape View File

@ -7,11 +7,12 @@ module Network.Xmpp.Stream where
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State.Strict import Control.Monad.State.Strict
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.Conduit.BufferedSource import qualified Data.Conduit.Internal as DCI
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Maybe (fromJust, isJust, isNothing) import Data.Maybe (fromJust, isJust, isNothing)
import Data.Text as Text import Data.Text as Text
@ -61,8 +62,8 @@ openElementFromEvents = do
_ -> throwError $ StreamConnectionError _ -> throwError $ StreamConnectionError
-- Sends the initial stream:stream element and pulls the server features. -- Sends the initial stream:stream element and pulls the server features.
xmppStartStream :: XmppConMonad (Either StreamError ()) startStream :: StateT Connection_ IO (Either StreamError ())
xmppStartStream = runErrorT $ do startStream = runErrorT $ do
state <- get state <- get
-- Set the `to' attribute depending on the state of the connection. -- Set the `to' attribute depending on the state of the connection.
let from = case sConnectionState state of let from = case sConnectionState state of
@ -80,24 +81,24 @@ xmppStartStream = runErrorT $ do
, Nothing , Nothing
, sPreferredLang state , sPreferredLang state
) )
(lt, from, id, features) <- ErrorT . pullToSinkEvents $ runErrorT $ (lt, from, id, features) <- ErrorT . runEventsSink $ runErrorT $
xmppStream from streamS from
modify (\s -> s{ sFeatures = features modify (\s -> s{ sFeatures = features
, sStreamLang = Just lt , sStreamLang = Just lt
, sStreamId = id , sStreamId = id
, sFrom = from , sFrom = from
} } )
)
return () return ()
-- Sets a new Event source using the raw source (of bytes) -- Sets a new Event source using the raw source (of bytes)
-- and calls xmppStartStream. -- and calls xmppStartStream.
xmppRestartStream :: XmppConMonad (Either StreamError ()) restartStream :: StateT Connection_ IO (Either StreamError ())
xmppRestartStream = do restartStream = do
raw <- gets (cRecv . sCon) raw <- gets (cRecv . cHand)
newSrc <- liftIO . bufferSource $ loopRead raw $= XP.parseBytes def let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def)
modify (\s -> s{sCon = (sCon s){cEventSource = newSrc}}) (return ())
xmppStartStream modify (\s -> s{cEventSource = newSource })
startStream
where where
loopRead read = do loopRead read = do
bs <- liftIO (read 4096) bs <- liftIO (read 4096)
@ -109,11 +110,11 @@ xmppRestartStream = do
-- Also validates the stream element's attributes and throws an error if -- Also validates the stream element's attributes and throws an error if
-- appropriate. -- appropriate.
-- TODO: from. -- TODO: from.
xmppStream :: Maybe Jid -> StreamSink ( LangTag streamS :: Maybe Jid -> StreamSink ( LangTag
, Maybe Jid , Maybe Jid
, Maybe Text , Maybe Text
, ServerFeatures) , ServerFeatures)
xmppStream expectedTo = do streamS expectedTo = do
(from, to, id, langTag) <- xmppStreamHeader (from, to, id, langTag) <- xmppStreamHeader
features <- xmppStreamFeatures features <- xmppStreamFeatures
return (langTag, from, id, features) return (langTag, from, id, features)

16
source/Network/Xmpp/TLS.hs
Unescape View File

@ -86,15 +86,17 @@ instance Error XmppTLSError where
-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
-- restarts the stream. May throw errors. -- restarts the stream. May throw errors.
startTLS :: TLS.TLSParams -> XmppConMonad (Either XmppTLSError ()) startTLS :: TLS.TLSParams -> Connection -> IO (Either XmppTLSError ())
startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do startTLS params con = Ex.handle (return . Left . TLSError)
. flip withConnection con
. runErrorT $ do
features <- lift $ gets sFeatures features <- lift $ gets sFeatures
state <- gets sConnectionState state <- gets sConnectionState
case state of case state of
XmppConnectionPlain -> return () XmppConnectionPlain -> return ()
XmppConnectionClosed -> throwError TLSNoConnection XmppConnectionClosed -> throwError TLSNoConnection
XmppConnectionSecured -> throwError TLSConnectionSecured XmppConnectionSecured -> throwError TLSConnectionSecured
con <- lift $ gets sCon con <- lift $ gets cHand
when (stls features == Nothing) $ throwError TLSNoServerSupport when (stls features == Nothing) $ throwError TLSNoServerSupport
lift $ pushElement starttlsE lift $ pushElement starttlsE
answer <- lift $ pullElement answer <- lift $ pullElement
@ -105,15 +107,13 @@ startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
-- TODO: find something more suitable -- TODO: find something more suitable
e -> lift . Ex.throwIO . StreamXMLError $ e -> lift . Ex.throwIO . StreamXMLError $
"Unexpected element: " ++ ppElement e "Unexpected element: " ++ ppElement e
liftIO $ putStrLn "#"
(raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con)
liftIO $ putStrLn "*" let newHand = Hand { cSend = catchPush . psh
let newCon = Connection { cSend = catchSend . psh
, cRecv = read , cRecv = read
, cFlush = contextFlush ctx , cFlush = contextFlush ctx
, cClose = bye ctx >> cClose con , cClose = bye ctx >> cClose con
} }
lift $ modify ( \x -> x {sCon = newCon}) lift $ modify ( \x -> x {cHand = newHand})
either (lift . Ex.throwIO) return =<< lift xmppRestartStream either (lift . Ex.throwIO) return =<< lift restartStream
modify (\s -> s{sConnectionState = XmppConnectionSecured}) modify (\s -> s{sConnectionState = XmppConnectionSecured})
return () return ()

89
source/Network/Xmpp/Types.hs
Unescape View File

@ -31,11 +31,13 @@ module Network.Xmpp.Types
, StreamError(..) , StreamError(..)
, StreamErrorCondition(..) , StreamErrorCondition(..)
, Version(..) , Version(..)
, XmppConMonad , HandleLike(..)
, Connection(..) , Connection(..)
, XmppConnection(..) , Connection_(..)
, withConnection
, withConnection'
, mkConnection
, XmppConnectionState(..) , XmppConnectionState(..)
, XmppT(..)
, XmppStreamError(..) , XmppStreamError(..)
, langTag , langTag
, module Network.Xmpp.Jid , module Network.Xmpp.Jid
@ -43,15 +45,15 @@ module Network.Xmpp.Types
where where
import Control.Applicative ((<$>), many) import Control.Applicative ((<$>), many)
import Control.Concurrent.STM
import Control.Exception import Control.Exception
import Control.Monad.Error
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Error
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.Conduit.BufferedSource
import Data.IORef import Data.IORef
import Data.Maybe (fromJust, fromMaybe, maybeToList) import Data.Maybe (fromJust, fromMaybe, maybeToList)
import Data.String(IsString(..)) import Data.String(IsString(..))
@ -60,6 +62,7 @@ import qualified Data.Text as Text
import Data.Typeable(Typeable) import Data.Typeable(Typeable)
import Data.XML.Types import Data.XML.Types
import qualified Network as N import qualified Network as N
import Network.Xmpp.Jid import Network.Xmpp.Jid
@ -743,54 +746,68 @@ data XmppConnectionState
| XmppConnectionSecured -- ^ Connection established and secured via TLS. | XmppConnectionSecured -- ^ Connection established and secured via TLS.
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
data Connection = Connection { cSend :: BS.ByteString -> IO Bool data HandleLike = Hand { cSend :: BS.ByteString -> IO Bool
, cRecv :: Int -> IO BS.ByteString , cRecv :: Int -> IO BS.ByteString
-- This is to hold the state of the XML parser -- This is to hold the state of the XML parser
-- (otherwise we will receive lot's of EvenBegin -- (otherwise we will receive lot's of EvenBegin
-- Document and forger about name prefixes) -- Document and forger about name prefixes)
, cEventSource :: BufferedSource IO Event
, cFlush :: IO () , cFlush :: IO ()
, cClose :: IO () , cClose :: IO ()
} }
data XmppConnection = XmppConnection data Connection_ = Connection_
{ sCon :: Connection { sConnectionState :: !XmppConnectionState -- ^ State of
-- connection
, cHand :: HandleLike
, cEventSource :: ResumableSource IO Event
, sFeatures :: !ServerFeatures -- ^ Features the server , sFeatures :: !ServerFeatures -- ^ Features the server
-- advertised -- advertised
, sConnectionState :: !XmppConnectionState -- ^ State of connection , sHostname :: !(Maybe Text) -- ^ Hostname of the
, sHostname :: !(Maybe Text) -- ^ Hostname of the server -- server
, sJid :: !(Maybe Jid) -- ^ Our JID , sJid :: !(Maybe Jid) -- ^ Our JID
, sPreferredLang :: !(Maybe LangTag) -- ^ Default language when , sPreferredLang :: !(Maybe LangTag) -- ^ Default language
-- no explicit language -- when no explicit
-- tag is set -- language tag is set
, sStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value , sStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just'
-- once connected to the -- value once connected
-- to the server.
, sStreamId :: !(Maybe Text) -- ^ Stream ID as
-- specified by the
-- server. -- server.
, sStreamId :: !(Maybe Text) -- ^ Stream ID as specified by
-- the server.
, sToJid :: !(Maybe Jid) -- ^ JID to include in the , sToJid :: !(Maybe Jid) -- ^ JID to include in the
-- stream element's `to' -- stream element's `to'
-- attribute when the -- attribute when the
-- connection is secured. See -- connection is
-- also below. -- secured. See also below.
, sJidWhenPlain :: !Bool -- ^ Whether or not to also include the , sJidWhenPlain :: !Bool -- ^ Whether or not to also
-- Jid when the connection is plain. -- include the Jid when the
, sFrom :: !(Maybe Jid) -- ^ From as specified by the -- connection is plain.
-- server in the stream , sFrom :: !(Maybe Jid) -- ^ From as specified by
-- element's `from' -- the server in the
-- stream element's `from'
-- attribute. -- attribute.
} }
-- |
-- The Xmpp monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this
-- context.
newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Monad, MonadIO)
-- | Low-level and single-threaded Xmpp monad. See @Xmpp@ for a concurrent newtype Connection = Connection {unConnection :: TMVar Connection_}
-- implementation.
type XmppConMonad a = StateT XmppConnection IO a withConnection :: StateT Connection_ IO c -> Connection -> IO c
withConnection action (Connection con) = bracketOnError
(atomically $ takeTMVar con)
(atomically . putTMVar con )
(\c -> do
(r, c') <- runStateT action c
atomically $ putTMVar con c'
return r
)
-- nonblocking version. Changes to the connection are ignored!
withConnection' :: StateT Connection_ IO b -> Connection -> IO b
withConnection' action (Connection con) = do
con_ <- atomically $ readTMVar con
(r, _) <- runStateT action con_
return r
-- Make XmppT derive the Monad and MonadIO instances. mkConnection :: Connection_ -> IO Connection
deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m) mkConnection con = Connection `fmap` (atomically $ newTMVar con)

70
source/Network/Xmpp/Xep/InbandRegistration.hs
Unescape View File

@ -47,33 +47,33 @@ data Query = Query { instructions :: Maybe Text.Text
emptyQuery = Query Nothing False False [] emptyQuery = Query Nothing False False []
supported :: XmppConMonad (Either IbrError Bool) -- supported :: XmppConMonad (Either IbrError Bool)
supported = runErrorT $ fromFeatures <+> fromDisco -- supported = runErrorT $ fromFeatures <+> fromDisco
where -- where
fromFeatures = do -- fromFeatures = do
fs <- other <$> gets sFeatures -- fs <- other <$> gets sFeatures
let fe = XML.Element -- let fe = XML.Element
"{http://jabber.org/features/iq-register}register" -- "{http://jabber.org/features/iq-register}register"
[] -- []
[] -- []
return $ fe `elem` fs -- return $ fe `elem` fs
fromDisco = do -- fromDisco = do
hn' <- gets sHostname -- hn' <- gets sHostname
hn <- case hn' of -- hn <- case hn' of
Just h -> return (Jid Nothing h Nothing) -- Just h -> return (Jid Nothing h Nothing)
Nothing -> throwError IbrNoConnection -- Nothing -> throwError IbrNoConnection
qi <- lift $ xmppQueryInfo Nothing Nothing -- qi <- lift $ xmppQueryInfo Nothing Nothing
case qi of -- case qi of
Left e -> return False -- Left e -> return False
Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir -- Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir
f <+> g = do -- f <+> g = do
r <- f -- r <- f
if r then return True else g -- if r then return True else g
query :: IQRequestType -> Query -> XmppConMonad (Either IbrError Query) query :: IQRequestType -> Query -> Connection -> IO (Either IbrError Query)
query queryType x = do query queryType x con = do
answer <- xmppSendIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con
case answer of case answer of
Right IQResult{iqResultPayload = Just b} -> Right IQResult{iqResultPayload = Just b} ->
case unpickleElem xpQuery b of case unpickleElem xpQuery b of
@ -96,9 +96,11 @@ mapError f = mapErrorT (liftM $ left f)
-- | Retrieve the necessary fields and fill them in to register an account with -- | Retrieve the necessary fields and fill them in to register an account with
-- the server -- the server
registerWith :: [(Field, Text.Text)] -> XmppConMonad (Either RegisterError Query) registerWith :: [(Field, Text.Text)]
registerWith givenFields = runErrorT $ do -> Connection
fs <- mapError IbrError $ ErrorT requestFields -> IO (Either RegisterError Query)
registerWith givenFields con = runErrorT $ do
fs <- mapError IbrError . ErrorT $ requestFields con
when (registered fs) . throwError $ AlreadyRegistered when (registered fs) . throwError $ AlreadyRegistered
let res = flip map (fields fs) $ \(field,_) -> let res = flip map (fields fs) $ \(field,_) ->
case lookup field givenFields of case lookup field givenFields of
@ -107,18 +109,18 @@ registerWith givenFields = runErrorT $ do
fields <- case partitionEithers res of fields <- case partitionEithers res of
([],fs) -> return fs ([],fs) -> return fs
(fs,_) -> throwError $ MissingFields fs (fs,_) -> throwError $ MissingFields fs
result <- mapError IbrError . ErrorT . query Set $ emptyQuery {fields} result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con
return result return result
-- | Terminate your account on the server. You have to be logged in for this to -- | Terminate your account on the server. You have to be logged in for this to
-- work. You connection will most likely be terminated after unregistering. -- work. You connection will most likely be terminated after unregistering.
unregister :: XmppConMonad (Either IbrError Query) unregister :: Connection -> IO (Either IbrError Query)
unregister = query Set $ emptyQuery {remove = True} unregister = query Set $ emptyQuery {remove = True}
requestFields = runErrorT $ do requestFields con = runErrorT $ do
-- supp <- ErrorT supported -- supp <- ErrorT supported
-- unless supp $ throwError $ IbrNotSupported -- unless supp $ throwError $ IbrNotSupported
qr <- ErrorT $ query Get emptyQuery qr <- ErrorT $ query Get emptyQuery con
return $ qr return $ qr
xpQuery :: PU [XML.Node] Query xpQuery :: PU [XML.Node] Query

11
source/Network/Xmpp/Xep/ServiceDiscovery.hs
Unescape View File

@ -89,8 +89,8 @@ queryInfo :: Jid -- ^ Entity to query
-> Maybe Text.Text -- ^ Node -> Maybe Text.Text -- ^ Node
-> Context -> Context
-> IO (Either DiscoError QueryInfoResult) -> IO (Either DiscoError QueryInfoResult)
queryInfo to node session = do queryInfo to node context = do
res <- sendIQ' (Just to) Get Nothing queryBody session res <- sendIQ' (Just to) Get Nothing queryBody context
return $ case res of return $ case res of
IQResponseError e -> Left $ DiscoIQError e IQResponseError e -> Left $ DiscoIQError e
IQResponseTimeout -> Left $ DiscoTimeout IQResponseTimeout -> Left $ DiscoTimeout
@ -105,9 +105,10 @@ queryInfo to node session = do
xmppQueryInfo :: Maybe Jid xmppQueryInfo :: Maybe Jid
-> Maybe Text.Text -> Maybe Text.Text
-> XmppConMonad (Either DiscoError QueryInfoResult) -> Connection
xmppQueryInfo to node = do -> IO (Either DiscoError QueryInfoResult)
res <- xmppSendIQ' "info" to Get Nothing queryBody xmppQueryInfo to node con = do
res <- pushIQ' "info" to Get Nothing queryBody con
return $ case res of return $ case res of
Left e -> Left $ DiscoIQError e Left e -> Left $ DiscoIQError e
Right r -> case iqResultPayload r of Right r -> case iqResultPayload r of

Write Preview
Loading…
Cancel
Save