@ -6,6 +6,7 @@ module Network.Xmpp.Connection_ where
import Control.Applicative ( ( <$> ) ) import Control.Applicative ( ( <$> ) )
import Control.Concurrent ( forkIO , threadDelay ) import Control.Concurrent ( forkIO , threadDelay )
import System.IO.Error ( tryIOError )
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
@ -41,7 +42,7 @@ import System.Log.Logger
import Data.ByteString.Base64 import Data.ByteString.Base64
import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TMVar
import Control.Monad.Error
-- Enable/disable debug output -- Enable/disable debug output
-- This will dump all incoming and outgoing network taffic to the console, -- This will dump all incoming and outgoing network taffic to the console,
@ -49,69 +50,83 @@ import Control.Concurrent.STM.TMVar
debug :: Bool debug :: Bool
debug = False debug = False
pushElement :: Element -> StateT Connection IO Bool -- TODO: Can the TLS send/recv functions throw something other than an IO error?
wrapIOException :: IO a -> StateT Connection IO ( Either XmppFailure a )
wrapIOException action = do
r <- liftIO $ tryIOError action
case r of
Right b -> return $ Right b
Left e -> return $ Left $ XmppIOException e
pushElement :: Element -> StateT Connection IO ( Either XmppFailure Bool )
pushElement x = do pushElement x = do
send <- gets ( cSend . cHandle ) send <- gets ( cSend . cHandle )
liftIO . send $ renderElement x wrapIOException $ send $ renderElement x
-- | Encode and send stanza -- | Encode and send stanza
pushStanza :: Stanza -> TMVar Connection -> IO Bool pushStanza :: Stanza -> TMVar Connection -> IO ( Either XmppFailure Bool )
pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s 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 :: StateT Connection IO Bool pushXmlDecl :: StateT Connection IO ( Either XmppFailure Bool )
pushXmlDecl = do pushXmlDecl = do
con <- gets cHandle con <- gets cHandle
liftIO $ ( cSend con ) " <?xml version= \ " 1.0 \ " encoding= \ " UTF-8 \ " ?> " wrapIOException $ ( cSend con ) " <?xml version= \ " 1.0 \ " encoding= \ " UTF-8 \ " ?> "
pushOpenElement :: Element -> StateT Connection IO Bool pushOpenElement :: Element -> StateT Connection IO ( Either XmppFailure Bool )
pushOpenElement e = do pushOpenElement e = do
sink <- gets ( cSend . cHandle ) sink <- gets ( cSend . cHandle )
liftIO . sink $ renderOpenElement e wrapIOException $ 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.
runEventsSink :: Sink Event IO b -> StateT Connection IO b runEventsSink :: Sink Event IO b -> StateT Connection IO ( Either XmppFailure b )
runEventsSink snk = do runEventsSink snk = do -- TODO: Wrap exceptions?
source <- gets cEventSource source <- gets cEventSource
( src' , r ) <- lift $ source $$++ snk ( src' , r ) <- lift $ source $$++ snk
modify ( \ s -> s { cEventSource = src' } ) modify ( \ s -> s { cEventSource = src' } )
return r return $ Right r
pullElement :: StateT Connection IO Element pullElement :: StateT Connection IO ( Either XmppFailure Element )
pullElement = do pullElement = do
Ex . catches ( do Ex . catches ( do
e <- runEventsSink ( elements =$ await ) e <- runEventsSink ( elements =$ await )
case e of case e of
Nothing -> liftIO $ Ex . throwIO StreamOtherFailure Left f -> return $ Left f
Just r -> return r Right Nothing -> return $ Left XmppOtherFailure -- TODO
Right ( Just r ) -> return $ Right r
) )
[ Ex . Handler ( \ StreamEnd -> Ex . throwIO StreamEndFailure ) [ Ex . Handler ( \ StreamEnd -> return $ Left StreamEndFailure )
, Ex . Handler ( \ ( InvalidXmppXml s ) -- Invalid XML `Event' encountered, or missing element close tag , Ex . Handler ( \ ( InvalidXmppXml s ) -- Invalid XML `Event' encountered, or missing element close tag
-> liftIO . Ex . throwIO $ Stream OtherFailure) -- TODO: Log: s -> return $ Left Xmpp OtherFailure) -- TODO: Log: s
, Ex . Handler $ \ ( e :: InvalidEventStream ) -- xml-conduit exception , Ex . Handler $ \ ( e :: InvalidEventStream ) -- xml-conduit exception
-> liftIO . Ex . throwIO $ Stream OtherFailure-- TODO: Log: (show e) -> return $ Left Xmpp OtherFailure-- TODO: Log: (show e)
] ]
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
pullUnpickle :: PU [ Node ] a -> StateT Connection IO a pullUnpickle :: PU [ Node ] a -> StateT Connection IO ( Either XmppFailure a )
pullUnpickle p = do pullUnpickle p = do
res <- unpickleElem p <$> pullElement elem <- pullElement
case elem of
Left e -> return $ Left e
Right elem' -> do
let res = unpickleElem p elem'
case res of case res of
Left e -> liftIO $ Ex . throwIO e Left e -> return $ Left XmppOtherFailure -- TODO: Log
Right r -> return r Right r -> return $ Right r
-- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream -- | Pulls a stanza (or stream error) from the stream.
-- error. pullStanza :: TMVar Connection -> IO ( Either XmppFailure Stanza )
pullStanza :: TMVar Connection -> IO Stanza
pullStanza = withConnection' $ do pullStanza = withConnection' $ do
res <- pullUnpickle xpStreamStanza res <- pullUnpickle xpStreamStanza
case res of case res of
Left e -> liftIO . Ex . throwIO $ StreamErrorFailure e Left e -> return $ Left e
Right r -> return r Right ( Left e ) -> return $ Left $ StreamErrorFailure e
Right ( Right r ) -> return $ Right 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
@ -129,7 +144,7 @@ xmppNoConnection :: Connection
xmppNoConnection = Connection xmppNoConnection = Connection
{ cHandle = ConnectionHandle { cSend = \ _ -> return False { cHandle = ConnectionHandle { cSend = \ _ -> return False
, cRecv = \ _ -> Ex . throwIO , cRecv = \ _ -> Ex . throwIO
Stream OtherFailure Xmpp OtherFailure
, cFlush = return () , cFlush = return ()
, cClose = return () , cClose = return ()
} }
@ -147,9 +162,9 @@ xmppNoConnection = Connection
} }
where where
zeroSource :: Source IO output zeroSource :: Source IO output
zeroSource = liftIO . Ex . throwIO $ Stream OtherFailure zeroSource = liftIO . Ex . throwIO $ Xmpp OtherFailure
connectTcp :: HostName -> PortID -> Text -> IO ( TMVar Connection ) connectTcp :: HostName -> PortID -> Text -> IO ( Either XmppFailure ( TMVar Connection ) )
connectTcp host port hostname = do connectTcp host port hostname = do
let PortNumber portNumber = port let PortNumber portNumber = port
debugM " Pontarius.Xmpp " $ " Connecting to " ++ host ++ " on port " ++ debugM " Pontarius.Xmpp " $ " Connecting to " ++ host ++ " on port " ++
@ -190,7 +205,8 @@ connectTcp host port hostname = do
, cJidWhenPlain = False -- TODO: Allow user to set , cJidWhenPlain = False -- TODO: Allow user to set
, cFrom = Nothing , cFrom = Nothing
} }
mkConnection con con' <- mkConnection con
return $ Right con'
where where
logConduit :: Conduit ByteString IO ByteString logConduit :: Conduit ByteString IO ByteString
logConduit = CL . mapM $ \ d -> do logConduit = CL . mapM $ \ d -> do
@ -201,10 +217,12 @@ connectTcp host port hostname = do
-- Closes the connection and updates the XmppConMonad Connection state. -- Closes the connection and updates the XmppConMonad Connection state.
killConnection :: TMVar Connection -> IO ( Either Ex . SomeException () ) -- killConnection :: TMVar Connection -> IO (Either Ex.SomeException ())
killConnection :: TMVar Connection -> IO ( Either XmppFailure () )
killConnection = withConnection $ do killConnection = withConnection $ do
cc <- gets ( cClose . cHandle ) cc <- gets ( cClose . cHandle )
err <- liftIO $ ( Ex . try cc :: IO ( Either Ex . SomeException () ) ) err <- wrapIOException cc
-- (Ex.try cc :: IO (Either Ex.SomeException ()))
put xmppNoConnection put xmppNoConnection
return err return err
@ -216,44 +234,45 @@ pushIQ' :: StanzaId
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> TMVar Connection -> TMVar Connection
-> IO ( Either IQError IQResult ) -> IO ( Either XmppFailure ( Either IQError IQResult ) )
pushIQ' iqID to tp lang body con = do pushIQ' iqID to tp lang body con = do
pushStanza ( IQRequestS $ IQRequest iqID Nothing to lang tp body ) con pushStanza ( IQRequestS $ IQRequest iqID Nothing to lang tp body ) con
res <- pullStanza con res <- pullStanza con
case res of case res of
IQErrorS e -> return $ Left e Left e -> return $ Left e
IQResultS r -> do Right ( IQErrorS e ) -> return $ Right $ Left e
Right ( IQResultS r ) -> do
unless unless
( iqID == iqResultID r ) . liftIO . Ex . throwIO $ ( iqID == iqResultID r ) . liftIO . Ex . throwIO $
Stream OtherFailure Xmpp OtherFailure
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
-- " /= " ++ show (iqResultID r) ++ " .") -- " /= " ++ show (iqResultID r) ++ " .")
return $ Right r return $ Right $ Right r
_ -> liftIO $ Ex . throwIO Stream OtherFailure _ -> return $ Left Xmpp OtherFailure
-- TODO: Log: "sendIQ': unexpected stanza type " -- TODO: Log: "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 are returned.
-- not we received a </stream:stream> element from the server is returned . -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError .
closeStreams :: TMVar Connection -> IO ( [ Element ] , Bool ) closeStreams :: TMVar Connection -> IO ( Either XmppFailure [ Element ] )
closeStreams = withConnection $ do closeStreams = withConnection $ do
send <- gets ( cSend . cHandle ) send <- gets ( cSend . cHandle )
cc <- gets ( cClose . cHandle ) cc <- gets ( cClose . cHandle )
liftIO $ send " </stream:stream> " liftIO $ send " </stream:stream> "
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelay 3000000 threadDelay 3000000 -- TODO: Configurable value
( Ex . try cc ) :: IO ( Either Ex . SomeException () ) ( Ex . try cc ) :: IO ( Either Ex . SomeException () )
return () return ()
collectElems [] collectElems []
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 ] -> StateT Connection IO ( [ Element ] , Bool ) collectElems :: [ Element ] -> StateT Connection IO ( Either XmppFailure [ Element ] )
collectElems es = do collectElems es = do
result <- Ex . try pullElement result <- pullElement
case result of case result of
Left StreamEndFailure -> return ( es , True ) Left StreamEndFailure -> return $ Right es
Left _ -> return ( es , Fals e) Left e -> return $ Left $ StreamCloseError ( es , e )
Right e -> collectElems ( e : es ) Right e -> collectElems ( e : es )
debugConduit :: Pipe l ByteString ByteString u IO b debugConduit :: Pipe l ByteString ByteString u IO b
Jon Kristensen
13 years ago