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

move from exceptions as StreamHandle error indicator to XmppFailure error values. 

This changes the return type of at least the following functions from IO Bool to IO (Either XmppFailure ())
  * sendIQ

  * sendIQ'

  * answerIQ

  * sendMessage

  * sendPresence
master
Philipp Balzarek 12 years ago
parent
3f8848825f
commit
1edaab5b92
14 changed files with 237 additions and 196 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. 8
      source/Network/Xmpp/Concurrent.hs
  2. 8
      source/Network/Xmpp/Concurrent/Basic.hs
  3. 36
      source/Network/Xmpp/Concurrent/IQ.hs
  4. 46
      source/Network/Xmpp/Concurrent/Message.hs
  5. 25
      source/Network/Xmpp/Concurrent/Presence.hs
  6. 26
      source/Network/Xmpp/Concurrent/Threads.hs
  7. 23
      source/Network/Xmpp/Concurrent/Types.hs
  8. 10
      source/Network/Xmpp/IM/Roster.hs
  9. 6
      source/Network/Xmpp/Sasl/Common.hs
  10. 155
      source/Network/Xmpp/Stream.hs
  11. 30
      source/Network/Xmpp/Tls.hs
  12. 26
      source/Network/Xmpp/Types.hs
  13. 4
      source/Network/Xmpp/Xep/ServiceDiscovery.hs

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

@ -104,12 +104,12 @@ handleIQ iqHands out sta as = do
False -> do False -> do
didSend <- out response didSend <- out response
case didSend of case didSend of
True -> do Right () -> do
atomically $ putTMVar sentRef True atomically $ putTMVar sentRef True
return $ Just True return $ Just (Right ())
False -> do er@Left{} -> do
atomically $ putTMVar sentRef False atomically $ putTMVar sentRef False
return $ Just False return $ Just er
writeTChan ch $ IQRequestTicket answerT iq as writeTChan ch $ IQRequestTicket answerT iq as
return Nothing return Nothing
maybe (return ()) (void . out) res maybe (return ()) (void . out) res

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

@ -11,12 +11,12 @@ import Network.Xmpp.Stream
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Utilities import Network.Xmpp.Utilities
semWrite :: WriteSemaphore -> BS.ByteString -> IO Bool semWrite :: WriteSemaphore -> BS.ByteString -> IO (Either XmppFailure ())
semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem) semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem)
(atomically . putTMVar sem) (atomically . putTMVar sem)
($ bs) ($ bs)
writeStanza :: WriteSemaphore -> Stanza -> IO Bool writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ())
writeStanza sem a = do writeStanza sem a = do
let outData = renderElement $ nsHack (pickleElem xpStanza a) let outData = renderElement $ nsHack (pickleElem xpStanza a)
semWrite sem outData semWrite sem outData
@ -24,11 +24,11 @@ writeStanza sem a = do
-- | Send a stanza to the server without running plugins. (The stanza is sent as -- | Send a stanza to the server without running plugins. (The stanza is sent as
-- is) -- is)
sendRawStanza :: Stanza -> Session -> IO Bool sendRawStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendRawStanza a session = writeStanza (writeSemaphore session) a sendRawStanza a session = writeStanza (writeSemaphore session) a
-- | Send a stanza to the server, managed by plugins -- | Send a stanza to the server, managed by plugins
sendStanza :: Stanza -> Session -> IO Bool sendStanza :: Stanza -> Session -> IO (Either XmppFailure ())
sendStanza = flip sendStanza' sendStanza = flip sendStanza'
-- | Get the channel of incoming stanzas. -- | Get the channel of incoming stanzas.

36
source/Network/Xmpp/Concurrent/IQ.hs
Unescape View File

@ -1,9 +1,10 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent.IQ where module Network.Xmpp.Concurrent.IQ where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.Thread.Delay (delay)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Thread.Delay (delay)
import Control.Monad import Control.Monad
@ -15,9 +16,10 @@ import Network.Xmpp.Concurrent.Basic
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Types import Network.Xmpp.Types
-- | Sends an IQ, returns Just a 'TMVar' that will be filled with the first -- | Sends an IQ, returns Right 'TMVar' that will be filled with the first
-- inbound IQ with a matching ID that has type @result@ or @error@ or Nothing if -- inbound IQ with a matching ID that has type @result@ or @error@ or Nothing if
-- the stanza could not be sent -- the stanza could not be sent.
-- Returns Left 'XmppFailure' when sending the stanza failed
sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response
-- TMVar will be filled with 'IQResponseTimeout' and the -- TMVar will be filled with 'IQResponseTimeout' and the
-- id is removed from the list of IQ handlers. 'Nothing' -- id is removed from the list of IQ handlers. 'Nothing'
@ -28,7 +30,7 @@ sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response
-- default) -- default)
-> Element -- ^ The IQ body (there has to be exactly one) -> Element -- ^ The IQ body (there has to be exactly one)
-> Session -> Session
-> IO (Maybe (TMVar ( Maybe (Annotated IQResponse)))) -> IO (Either XmppFailure (TMVar (Maybe (Annotated IQResponse))))
sendIQ timeOut to tp lang body session = do -- TODO: Add timeout sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
newId <- idGenerator session newId <- idGenerator session
ref <- atomically $ do ref <- atomically $ do
@ -38,15 +40,15 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
-- TODO: Check for id collisions (shouldn't happen?) -- TODO: Check for id collisions (shouldn't happen?)
return resRef return resRef
res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session
if res case res of
then do Right () -> do
case timeOut of case timeOut of
Nothing -> return () Nothing -> return ()
Just t -> void . forkIO $ do Just t -> void . forkIO $ do
delay t delay t
doTimeOut (iqHandlers session) newId ref doTimeOut (iqHandlers session) newId ref
return $ Just ref return $ Right ref
else return Nothing Left e -> return $ Left e
where where
doTimeOut handlers iqid var = atomically $ do doTimeOut handlers iqid var = atomically $ do
p <- tryPutTMVar var Nothing p <- tryPutTMVar var Nothing
@ -56,18 +58,28 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
return () return ()
-- | Like 'sendIQ', but waits for the answer IQ. -- | Like 'sendIQ', but waits for the answer IQ.
sendIQ' :: Maybe Integer sendIQA' :: Maybe Integer
-> Maybe Jid -> Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> Session -> Session
-> IO (Either IQSendError (Annotated IQResponse)) -> IO (Either IQSendError (Annotated IQResponse))
sendIQ' timeout to tp lang body session = do sendIQA' timeout to tp lang body session = do
ref <- sendIQ timeout to tp lang body session ref <- sendIQ timeout to tp lang body session
maybe (return $ Left IQSendError) (fmap (maybe (Left IQTimeOut) Right) either (return . Left . IQSendError) (fmap (maybe (Left IQTimeOut) Right)
. atomically . takeTMVar) ref . atomically . takeTMVar) ref
-- | Like 'sendIQ', but waits for the answer IQ. Discards plugin Annotations
sendIQ' :: Maybe Integer
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Session
-> IO (Either IQSendError IQResponse)
sendIQ' timeout to tp lang body session = fmap fst <$> sendIQA' timeout to tp lang body session
-- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not
-- already handled, a new 'TChan' is created and returned as a 'Right' value. -- 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' -- Otherwise, the already existing channel will be returned wrapped in a 'Left'
@ -119,5 +131,5 @@ dropIQChan tp ns session = do
-- (False is returned in that case) -- (False is returned in that case)
answerIQ :: IQRequestTicket answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element) -> Either StanzaError (Maybe Element)
-> IO (Maybe Bool) -> IO (Maybe (Either XmppFailure ()))
answerIQ ticket = answerTicket ticket answerIQ ticket = answerTicket ticket

46
source/Network/Xmpp/Concurrent/Message.hs
Unescape View File

@ -1,6 +1,7 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent.Message where module Network.Xmpp.Concurrent.Message where
import Control.Applicative((<$>))
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Control.Concurrent.STM import Control.Concurrent.STM
import Network.Xmpp.Types import Network.Xmpp.Types
@ -16,46 +17,61 @@ pullMessage session = do
MessageErrorS e -> return $ Left (e, as) MessageErrorS e -> return $ Left (e, as)
_ -> pullMessage session _ -> pullMessage session
-- | Get the next received message with plugin Annotations
getMessageA :: Session -> IO (Annotated Message)
getMessageA = waitForMessageA (const True)
-- | Get the next received message -- | Get the next received message
getMessage :: Session -> IO (Annotated Message) getMessage :: Session -> IO Message
getMessage = waitForMessage (const True) getMessage s = fst <$> getMessageA s
-- | Pulls a (non-error) message and returns it if the given predicate returns -- | Pulls a (non-error) message and returns it if the given predicate returns
-- @True@. -- @True@.
waitForMessage :: (Annotated Message -> Bool) -> Session -> IO (Annotated Message) waitForMessageA :: (Annotated Message -> Bool) -> Session -> IO (Annotated Message)
waitForMessage f session = do waitForMessageA f session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
Left _ -> waitForMessage f session Left _ -> waitForMessageA f session
Right m | f m -> return m Right m | f m -> return m
| otherwise -> waitForMessage f session | otherwise -> waitForMessageA f session
waitForMessage :: (Message -> Bool) -> Session -> IO Message
waitForMessage f s = fst <$> waitForMessageA (f . fst) s
-- | Pulls an error message and returns it if the given predicate returns @True@. -- | Pulls an error message and returns it if the given predicate returns @True@.
waitForMessageError :: (Annotated MessageError -> Bool) waitForMessageErrorA :: (Annotated MessageError -> Bool)
-> Session -> Session
-> IO (Annotated MessageError) -> IO (Annotated MessageError)
waitForMessageError f session = do waitForMessageErrorA f session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
Right _ -> waitForMessageError f session Right _ -> waitForMessageErrorA f session
Left m | f m -> return m Left m | f m -> return m
| otherwise -> waitForMessageError f session | otherwise -> waitForMessageErrorA f session
waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError
waitForMessageError f s = fst <$> waitForMessageErrorA (f . fst) s
-- | Pulls a message and returns it if the given predicate returns @True@. -- | Pulls a message and returns it if the given predicate returns @True@.
filterMessages :: (Annotated MessageError -> Bool) filterMessagesA :: (Annotated MessageError -> Bool)
-> (Annotated Message -> Bool) -> (Annotated Message -> Bool)
-> Session -> IO (Either (Annotated MessageError) -> Session -> IO (Either (Annotated MessageError)
(Annotated Message)) (Annotated Message))
filterMessages f g session = do filterMessagesA f g session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
Left e | f e -> return $ Left e Left e | f e -> return $ Left e
| otherwise -> filterMessages f g session | otherwise -> filterMessagesA f g session
Right m | g m -> return $ Right m Right m | g m -> return $ Right m
| otherwise -> filterMessages f g session | otherwise -> filterMessagesA f g session
filterMessages :: (MessageError -> Bool)
-> (Message -> Bool)
-> Session
-> IO (Either (Annotated MessageError) (Annotated Message))
filterMessages f g s = filterMessagesA (f . fst) (g . fst) s
-- | Send a message stanza. Returns @False@ when the 'Message' could not be -- | Send a message stanza. Returns @False@ when the 'Message' could not be
-- sent. -- sent.
sendMessage :: Message -> Session -> IO Bool sendMessage :: Message -> Session -> IO (Either XmppFailure ())
sendMessage m session = sendStanza (MessageS m) session sendMessage m session = sendStanza (MessageS m) session

25
source/Network/Xmpp/Concurrent/Presence.hs
Unescape View File

@ -1,6 +1,7 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent.Presence where module Network.Xmpp.Concurrent.Presence where
import Control.Applicative ((<$>))
import Control.Concurrent.STM import Control.Concurrent.STM
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
@ -8,27 +9,33 @@ import Network.Xmpp.Concurrent.Basic
-- | Read an element from the inbound stanza channel, discardes any non-Presence -- | Read an element from the inbound stanza channel, discardes any non-Presence
-- stanzas from the channel -- stanzas from the channel
pullPresence :: Session -> IO (Either (Annotated PresenceError) pullPresenceA :: Session -> IO (Either (Annotated PresenceError)
(Annotated Presence)) (Annotated Presence))
pullPresence session = do pullPresenceA session = do
(stanza, as) <- atomically . readTChan $ stanzaCh session (stanza, as) <- atomically . readTChan $ stanzaCh session
case stanza of case stanza of
PresenceS p -> return $ Right (p, as) PresenceS p -> return $ Right (p, as)
PresenceErrorS e -> return $ Left (e, as) PresenceErrorS e -> return $ Left (e, as)
_ -> pullPresence session _ -> pullPresenceA session
pullPresence :: Session -> IO (Either PresenceError Presence)
pullPresence s = either (Left . fst) (Right . fst) <$> pullPresenceA s
-- | Pulls a (non-error) presence and returns it if the given predicate returns -- | Pulls a (non-error) presence and returns it if the given predicate returns
-- @True@. -- @True@.
waitForPresence :: (Annotated Presence -> Bool) waitForPresenceA :: (Annotated Presence -> Bool)
-> Session -> Session
-> IO (Annotated Presence) -> IO (Annotated Presence)
waitForPresence f session = do waitForPresenceA f session = do
s <- pullPresence session s <- pullPresenceA session
case s of case s of
Left _ -> waitForPresence f session Left _ -> waitForPresenceA f session
Right m | f m -> return m Right m | f m -> return m
| otherwise -> waitForPresence f session | otherwise -> waitForPresenceA f session
waitForPresence :: (Presence -> Bool) -> Session -> IO Presence
waitForPresence f s = fst <$> waitForPresenceA (f . fst) s
-- | Send a presence stanza. -- | Send a presence stanza.
sendPresence :: Presence -> Session -> IO Bool sendPresence :: Presence -> Session -> IO (Either XmppFailure ())
sendPresence p session = sendStanza (PresenceS p) session sendPresence p session = sendStanza (PresenceS p) session

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

@ -45,26 +45,24 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do
Just s -> do Just s -> do
res <- Ex.catches (do res <- Ex.catches (do
allowInterrupt allowInterrupt
Just <$> pullStanza s res <- pullStanza s
) case res of
[ Ex.Handler $ \(Interrupt t) -> do Left e -> do
void $ handleInterrupts [t]
return Nothing
, Ex.Handler $ \(e :: XmppFailure) -> do
errorM "Pontarius.Xmpp" $ "Read error: " errorM "Pontarius.Xmpp" $ "Read error: "
++ show e ++ show e
_ <- closeStreams s _ <- closeStreams s
onCClosed e onCClosed e
return Nothing return Nothing
Right r -> return $ Just r
)
[ Ex.Handler $ \(Interrupt t) -> do
void $ handleInterrupts [t]
return Nothing
] ]
case res of case res of
Nothing -> return () -- Caught an exception, nothing to Nothing -> return () -- Caught an exception, nothing to
-- do. TODO: Can this happen? -- do. TODO: Can this happen?
Just (Left e) -> do Just sta -> void $ onStanza sta
errorM "Pontarius.Xmpp" $ "Stanza error:" ++ show e
_ <- closeStreams s
onCClosed e
Just (Right sta) -> void $ onStanza sta
where where
-- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7
-- compatibility. -- compatibility.
@ -89,7 +87,7 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do
-- | Runs thread in XmppState monad. Returns channel of incoming and outgoing -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing
-- stances, respectively, and an Action to stop the Threads and close the -- stances, respectively, and an Action to stop the Threads and close the
-- connection. -- connection.
startThreadsWith :: TMVar (BS.ByteString -> IO Bool) startThreadsWith :: TMVar (BS.ByteString -> IO (Either XmppFailure ()))
-> (Stanza -> IO ()) -> (Stanza -> IO ())
-> TMVar EventHandlers -> TMVar EventHandlers
-> Stream -> Stream
@ -110,7 +108,7 @@ startThreadsWith writeSem stanzaHandler eh con = do
killConnection threads = liftIO $ do killConnection threads = liftIO $ do
_ <- atomically $ do _ <- atomically $ do
_ <- takeTMVar writeSem _ <- takeTMVar writeSem
putTMVar writeSem $ \_ -> return False putTMVar writeSem $ \_ -> return $ Left XmppNoStream
_ <- forM threads killThread _ <- forM threads killThread
return () return ()
-- Call the connection closed handlers. -- Call the connection closed handlers.
@ -122,7 +120,7 @@ startThreadsWith writeSem stanzaHandler eh con = do
-- Acquires the write lock, pushes a space, and releases the lock. -- Acquires the write lock, pushes a space, and releases the lock.
-- | Sends a blank space every 30 seconds to keep the connection alive. -- | Sends a blank space every 30 seconds to keep the connection alive.
connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () connPersist :: TMVar (BS.ByteString -> IO a) -> IO ()
connPersist sem = forever $ do connPersist sem = forever $ do
pushBS <- atomically $ takeTMVar sem pushBS <- atomically $ takeTMVar sem
_ <- pushBS " " _ <- pushBS " "

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

@ -20,7 +20,7 @@ import Network.Xmpp.IM.Roster.Types
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types import Network.Xmpp.Types
type StanzaHandler = (Stanza -> IO Bool) -- ^ outgoing stanza type StanzaHandler = (Stanza -> IO (Either XmppFailure ()) ) -- ^ outgoing stanza
-> Stanza -- ^ stanza to handle -> Stanza -- ^ stanza to handle
-> [Annotation] -- ^ annotations added by previous handlers -> [Annotation] -- ^ annotations added by previous handlers
-> IO [(Stanza, [Annotation])] -- ^ modified stanzas and -> IO [(Stanza, [Annotation])] -- ^ modified stanzas and
@ -40,14 +40,15 @@ getAnnotation = foldr (\(Annotation a) b -> maybe b Just $ cast a) Nothing . snd
data Plugin' = Plugin' { inHandler :: Stanza data Plugin' = Plugin' { inHandler :: Stanza
-> [Annotation] -> [Annotation]
-> IO [(Stanza, [Annotation])] -> IO [(Stanza, [Annotation])]
, outHandler :: Stanza -> IO Bool , outHandler :: Stanza -> IO (Either XmppFailure ())
-- | In order to allow plugins to tie the knot (Plugin -- | In order to allow plugins to tie the knot (Plugin
-- / Session) we pass the plugin the completed Session -- / Session) we pass the plugin the completed Session
-- once it exists -- once it exists
, onSessionUp :: Session -> IO () , onSessionUp :: Session -> IO ()
} }
type Plugin = (Stanza -> IO Bool) -> ErrorT XmppFailure IO Plugin' type Plugin = (Stanza -> IO (Either XmppFailure ()))
-> ErrorT XmppFailure IO Plugin'
-- | Configuration for the @Session@ object. -- | Configuration for the @Session@ object.
data SessionConfiguration = SessionConfiguration data SessionConfiguration = SessionConfiguration
@ -86,7 +87,7 @@ instance Show Interrupt where show _ = "<Interrupt>"
instance Ex.Exception Interrupt instance Ex.Exception Interrupt
type WriteSemaphore = TMVar (BS.ByteString -> IO Bool) type WriteSemaphore = TMVar (BS.ByteString -> IO (Either XmppFailure ()))
-- | The Session object represents a single session with an XMPP server. You can -- | The Session object represents a single session with an XMPP server. You can
-- use 'session' to establish a session -- use 'session' to establish a session
@ -106,7 +107,7 @@ data Session = Session
, stopThreads :: IO () , stopThreads :: IO ()
, rosterRef :: TVar Roster , rosterRef :: TVar Roster
, conf :: SessionConfiguration , conf :: SessionConfiguration
, sendStanza' :: Stanza -> IO Bool , sendStanza' :: Stanza -> IO (Either XmppFailure ())
, sRealm :: HostName , sRealm :: HostName
, sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text) , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text)
, reconnectWait :: TVar Int , reconnectWait :: TVar Int
@ -122,17 +123,19 @@ type IQHandlers = ( Map.Map (IQRequestType, Text) (TChan IQRequestTicket)
-- | Contains whether or not a reply has been sent, and the IQ request body to -- | Contains whether or not a reply has been sent, and the IQ request body to
-- reply to. -- reply to.
data IQRequestTicket = IQRequestTicket data IQRequestTicket = IQRequestTicket
{ answerTicket :: Either StanzaError (Maybe Element) -> IO (Maybe Bool) { answerTicket :: Either StanzaError (Maybe Element)
-> IO (Maybe (Either XmppFailure ()))
-- ^ Return Nothing when the IQ request was already -- ^ Return Nothing when the IQ request was already
-- answered before, Just True when it was sucessfully -- answered before, Just (Right ()) when it was
-- answered and Just False when the answer was attempted, -- sucessfully answered and Just (Left error) when the
-- but failed (e.g. there is a connection failure) -- answer was attempted, but failed (e.g. there is a
-- connection failure)
, iqRequestBody :: IQRequest , iqRequestBody :: IQRequest
-- | Annotations set by plugins in receive -- | Annotations set by plugins in receive
, iqRequestAnnotations :: [Annotation] , iqRequestAnnotations :: [Annotation]
} }
-- | Error that can occur during sendIQ' -- | Error that can occur during sendIQ'
data IQSendError = IQSendError -- There was an error sending the IQ stanza data IQSendError = IQSendError XmppFailure -- There was an error sending the IQ stanza
| IQTimeOut -- No answer was received during the allotted time | IQTimeOut -- No answer was received during the allotted time
deriving (Show, Eq) deriving (Show, Eq)

10
source/Network/Xmpp/IM/Roster.hs
Unescape View File

@ -36,7 +36,7 @@ timeout = Just 3000000 -- 3 seconds
rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse)) rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse))
rosterPush item session = do rosterPush item session = do
let el = pickleElem xpQuery (Query Nothing [fromItem item]) let el = pickleElem xpQuery (Query Nothing [fromItem item])
sendIQ' timeout Nothing Set Nothing el session sendIQA' timeout Nothing Set Nothing el session
-- | Add or update an item to the roster. -- | Add or update an item to the roster.
-- --
@ -55,7 +55,7 @@ rosterAdd j n gs session = do
, qiSubscription = Nothing , qiSubscription = Nothing
, qiGroups = nub gs , qiGroups = nub gs
}]) }])
sendIQ' timeout Nothing Set Nothing el session sendIQA' timeout Nothing Set Nothing el session
-- | Remove an item from the roster. Return True when the item is sucessfully -- | Remove an item from the roster. Return True when the item is sucessfully
-- removed or if it wasn't in the roster to begin with. -- removed or if it wasn't in the roster to begin with.
@ -132,16 +132,16 @@ retrieveRoster mbOldRoster sess = do
Left e -> do Left e -> do
errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e errorM "Pontarius.Xmpp.Roster" $ "getRoster: " ++ show e
return Nothing return Nothing
Right (IQResponseResult (IQResult{iqResultPayload = Just ros}), _) Right (IQResponseResult IQResult{iqResultPayload = Just ros})
-> case unpickleElem xpQuery ros of -> case unpickleElem xpQuery ros of
Left _e -> do Left _e -> do
errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element"
return Nothing return Nothing
Right ros' -> return . Just $ toRoster ros' Right ros' -> return . Just $ toRoster ros'
Right (IQResponseResult (IQResult{iqResultPayload = Nothing}), _) -> do Right (IQResponseResult IQResult{iqResultPayload = Nothing}) -> do
return mbOldRoster return mbOldRoster
-- sever indicated that no roster updates are necessary -- sever indicated that no roster updates are necessary
Right (IQResponseError e, _) -> do Right (IQResponseError e) -> do
errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error" errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error"
++ show e ++ show e
return Nothing return Nothing

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

@ -139,8 +139,7 @@ saslInit mechanism payload = do
r <- lift . pushElement . saslInitE mechanism $ r <- lift . pushElement . saslInitE mechanism $
Text.decodeUtf8 . B64.encode <$> payload Text.decodeUtf8 . B64.encode <$> payload
case r of case r of
Right True -> return () Right () -> return ()
Right False -> throwError $ AuthStreamFailure XmppNoStream
Left e -> throwError $ AuthStreamFailure e Left e -> throwError $ AuthStreamFailure e
-- | Pull the next element. -- | Pull the next element.
@ -205,8 +204,7 @@ respond m = do
r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
case r of case r of
Left e -> throwError $ AuthStreamFailure e Left e -> throwError $ AuthStreamFailure e
Right False -> throwError $ AuthStreamFailure XmppNoStream Right () -> return ()
Right True -> return ()
-- | Run the appropriate stringprep profiles on the credentials. -- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure' -- May fail with 'AuthStringPrepFailure'

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

@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Network.Xmpp.Stream where module Network.Xmpp.Stream where
@ -16,7 +17,6 @@ import qualified Control.Exception.Lifted as ExL
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource as R
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Char8 as BSC8
@ -44,7 +44,6 @@ import System.IO
import System.Log.Logger import System.Log.Logger
import System.Random (randomRIO) import System.Random (randomRIO)
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..))
import Network.Xmpp.Utilities import Network.Xmpp.Utilities
@ -65,17 +64,6 @@ lmb :: [t] -> Maybe [t]
lmb [] = Nothing lmb [] = Nothing
lmb x = Just x lmb x = Just x
pushing :: MonadIO m =>
m (Either XmppFailure Bool)
-> ErrorT XmppFailure m ()
pushing m = do
res <- ErrorT m
case res of
True -> return ()
False -> do
liftIO $ debugM "Pontarius.Xmpp" "Failed to send data."
throwError XmppOtherFailure
-- Unpickles and returns a stream element. -- Unpickles and returns a stream element.
streamUnpickleElem :: PU [Node] a streamUnpickleElem :: PU [Node] a
-> Element -> Element
@ -89,7 +77,7 @@ streamUnpickleElem p x = do
-- This is the conduit sink that handles the stream XML events. We extend it -- This is the conduit sink that handles the stream XML events. We extend it
-- with ErrorT capabilities. -- with ErrorT capabilities.
type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a type StreamSink a = ConduitM Event Void (ErrorT XmppFailure IO) a
-- Discards all events before the first EventBeginElement. -- Discards all events before the first EventBeginElement.
throwOutJunk :: Monad m => ConduitM Event a m () throwOutJunk :: Monad m => ConduitM Event a m ()
@ -103,8 +91,8 @@ throwOutJunk = do
-- Returns an (empty) Element from a stream of XML events. -- Returns an (empty) Element from a stream of XML events.
openElementFromEvents :: StreamSink Element openElementFromEvents :: StreamSink Element
openElementFromEvents = do openElementFromEvents = do
lift throwOutJunk throwOutJunk
hd <- lift CL.head hd <- await
case hd of case hd of
Just (EventBeginElement name attrs) -> return $ Element name attrs [] Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> do _ -> do
@ -134,15 +122,15 @@ startStream = runErrorT $ do
lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname." lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname."
throwError XmppOtherFailure throwError XmppOtherFailure
Just address -> do Just address -> do
pushing pushXmlDecl ErrorT $ pushXmlDecl
pushing . pushOpenElement . streamNSHack $ ErrorT . pushOpenElement . streamNSHack $
pickleElem xpStream ( "1.0" pickleElem xpStream ( "1.0"
, expectedTo , expectedTo
, Just (Jid Nothing address Nothing) , Just (Jid Nothing address Nothing)
, Nothing , Nothing
, preferredLang $ streamConfiguration st , preferredLang $ streamConfiguration st
) )
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo response <- ErrorT $ runEventsSink $ streamS expectedTo
case response of case response of
Right (ver, from, to, sid, lt, features) Right (ver, from, to, sid, lt, features)
| (Text.unpack ver) /= "1.0" -> | (Text.unpack ver) /= "1.0" ->
@ -244,11 +232,15 @@ restartStream = do
startStream startStream
sourceStreamHandle :: MonadIO m => StreamHandle -> ConduitM i ByteString m () sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m)
=> StreamHandle -> ConduitM i ByteString m ()
sourceStreamHandle s = loopRead $ streamReceive s sourceStreamHandle s = loopRead $ streamReceive s
where where
loopRead rd = do loopRead rd = do
bs <- liftIO (rd 4096) bs' <- liftIO (rd 4096)
bs <- case bs' of
Left e -> throwError e
Right r -> return r
if BS.null bs if BS.null bs
then return () then return ()
else do else do
@ -260,25 +252,31 @@ sourceStreamHandle s = loopRead $ streamReceive s
-- We buffer sources because we don't want to lose data when multiple -- We buffer sources because we don't want to lose data when multiple
-- xml-entities are sent with the same packet and we don't want to eternally -- xml-entities are sent with the same packet and we don't want to eternally
-- block the StreamState while waiting for data to arrive -- block the StreamState while waiting for data to arrive
bufferSrc :: MonadIO m => Source IO o -> IO (ConduitM i o m ()) bufferSrc :: Source (ErrorT XmppFailure IO) o
-> IO (ConduitM i o (ErrorT XmppFailure IO) ())
bufferSrc src = do bufferSrc src = do
ref <- newTMVarIO $ DCI.ResumableSource src (return ()) ref <- newTMVarIO $ DCI.ResumableSource src (return ())
let go = do let go = do
dt <- liftIO $ Ex.bracketOnError (atomically $ takeTMVar ref) dt <- liftIO $ Ex.bracketOnError
(\_ -> atomically . putTMVar ref $ (atomically $ takeTMVar ref)
DCI.ResumableSource zeroSource (\_ -> atomically . putTMVar ref $ zeroResumableSource)
(return ())
)
(\s -> do (\s -> do
(s', dt) <- s $$++ CL.head res <- runErrorT (s $$++ await)
case res of
Left e -> do
atomically $ putTMVar ref zeroResumableSource
return $ Left e
Right (s',b) -> do
atomically $ putTMVar ref s' atomically $ putTMVar ref s'
return dt return $ Right b
) )
case dt of case dt of
Nothing -> return () Left e -> throwError e
Just d -> yield d >> go Right Nothing -> return ()
Right (Just d) -> yield d >> go
return go return go
where
zeroResumableSource = DCI.ResumableSource zeroSource (return ())
-- Reads the (partial) stream:stream and the server features from the stream. -- Reads the (partial) stream:stream and the server features from the stream.
-- Returns the (unvalidated) stream attributes, the unparsed element, or -- Returns the (unvalidated) stream attributes, the unparsed element, or
@ -302,7 +300,7 @@ streamS _expectedTo = do -- TODO: check expectedTo
where where
xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))
xmppStreamHeader = do xmppStreamHeader = do
lift throwOutJunk throwOutJunk
-- Get the stream:stream element (or whatever it is) from the server, -- Get the stream:stream element (or whatever it is) from the server,
-- and validate what we get. -- and validate what we get.
el <- openElementFromEvents -- May throw `XmppOtherFailure' if an el <- openElementFromEvents -- May throw `XmppOtherFailure' if an
@ -312,7 +310,7 @@ streamS _expectedTo = do -- TODO: check expectedTo
Right r -> return $ Right r Right r -> return $ Right r
xmppStreamFeatures :: StreamSink StreamFeatures xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures = do xmppStreamFeatures = do
e <- lift $ elements =$ CL.head e <- elements =$ await
case e of case e of
Nothing -> do Nothing -> do
lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended." lift $ lift $ errorM "Pontarius.Xmpp" "streamS: Stream ended."
@ -367,21 +365,22 @@ debugOut :: MonadIO m => ByteString -> m ()
debugOut outData = liftIO $ debugM "Pontarius.Xmpp" debugOut outData = liftIO $ debugM "Pontarius.Xmpp"
("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData))
wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException :: MonadIO m =>
IO a -> m (Either XmppFailure a)
wrapIOException action = do wrapIOException action = do
r <- liftIO $ tryIOError action r <- liftIO $ tryIOError action
case r of case r of
Right b -> return $ Right b Right b -> return $ Right b
Left e -> do Left e -> do
lift $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e) liftIO $ warningM "Pontarius.Xmpp" $ "wrapIOException: Exception wrapped: " ++ (show e)
return $ Left $ XmppIOException e return $ Left $ XmppIOException e
pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushElement x = do pushElement x = do
send <- gets (streamSend . streamHandle) send <- gets (streamSend . streamHandle)
let outData = renderElement $ nsHack x let outData = renderElement $ nsHack x
debugOut outData debugOut outData
wrapIOException $ send outData lift $ send outData
where where
-- HACK: We remove the "jabber:client" namespace because it is set as -- HACK: We remove the "jabber:client" namespace because it is set as
-- default in the stream. This is to make isode's M-LINK server happy and -- default in the stream. This is to make isode's M-LINK server happy and
@ -400,53 +399,46 @@ nsHack e@(Element{elementName = n})
mapNSHack nd = nd mapNSHack nd = nd
-- | Encode and send stanza -- | Encode and send stanza
pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) pushStanza :: Stanza -> Stream -> IO (Either XmppFailure ())
pushStanza s = withStream' . pushElement $ pickleElem xpStanza s pushStanza s = withStream' . 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 StreamState IO (Either XmppFailure Bool) pushXmlDecl :: StateT StreamState IO (Either XmppFailure ())
pushXmlDecl = do pushXmlDecl = do
con <- gets streamHandle con <- gets streamHandle
wrapIOException $ (streamSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" lift $ streamSend con "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure ())
pushOpenElement e = do pushOpenElement e = do
send <- gets (streamSend . streamHandle) send <- gets (streamSend . streamHandle)
let outData = renderOpenElement e let outData = renderOpenElement e
debugOut outData debugOut outData
wrapIOException $ send outData lift $ send outData
-- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `Connect-and-resumes' the given sink to the stream source, and pulls a
-- `b' value. -- `b' value.
runEventsSink :: Sink Event IO b -> StateT StreamState IO b runEventsSink :: Sink Event (ErrorT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b)
runEventsSink snk = do -- TODO: Wrap exceptions? runEventsSink snk = do -- TODO: Wrap exceptions?
src <- gets streamEventSource src <- gets streamEventSource
r <- liftIO $ src $$ snk lift . runErrorT $ src $$ snk
return r
pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement = do pullElement = do
ExL.catches (do
e <- runEventsSink (elements =$ await) e <- runEventsSink (elements =$ await)
case e of case e of
Nothing -> do Left l -> do
lift $ errorM "Pontarius.Xmpp" "pullElement: Stream ended." liftIO . errorM "Pontarius.Xmpp" $
return . Left $ XmppOtherFailure "Error while retrieving XML element: " ++ show l
Just r -> return $ Right r return $ Left l
)
[ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure) Right Nothing -> do
, ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag liftIO $ errorM "Pontarius.Xmpp" "pullElement: Stream ended."
-> do
lift $ errorM "Pontarius.Xmpp" $ "pullElement: Invalid XML: " ++ (show s)
return . Left $ XmppOtherFailure)
, ExL.Handler $ \(e :: InvalidEventStream)
-> do
lift $ errorM "Pontarius.Xmpp" $ "pullElement: Invalid event stream: " ++ (show e)
return . Left $ XmppOtherFailure return . Left $ XmppOtherFailure
] Right (Just r) -> return $ Right r
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
@ -473,21 +465,21 @@ pullStanza = withStream' $ do
-- 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
catchPush :: IO () -> IO Bool catchPush :: IO () -> IO (Either XmppFailure ())
catchPush p = ExL.catch catchPush p = ExL.catch
(p >> return True) (p >> return (Right ()))
(\e -> case GIE.ioe_type e of (\e -> case GIE.ioe_type e of
GIE.ResourceVanished -> return False GIE.ResourceVanished -> return . Left $ XmppIOException e
GIE.IllegalOperation -> return False GIE.IllegalOperation -> return . Left $ XmppIOException e
_ -> ExL.throwIO e _ -> ExL.throwIO e
) )
zeroHandle :: StreamHandle zeroHandle :: StreamHandle
zeroHandle = StreamHandle { streamSend = \_ -> return False zeroHandle = StreamHandle { streamSend = \_ -> return (Left XmppNoStream)
, streamReceive = \_ -> do , streamReceive = \_ -> do
errorM "Pontarius.Xmpp" errorM "Pontarius.Xmpp"
"xmppNoStream: Stream is closed." "xmppNoStream: Stream is closed."
ExL.throwIO XmppOtherFailure return $ Left XmppNoStream
, streamFlush = return () , streamFlush = return ()
, streamClose = return () , streamClose = return ()
} }
@ -507,14 +499,16 @@ xmppNoStream = StreamState {
, streamConfiguration = def , streamConfiguration = def
} }
zeroSource :: Source IO output zeroSource :: Source (ErrorT XmppFailure IO) a
zeroSource = liftIO $ do zeroSource = do
debugM "Pontarius.Xmpp" "zeroSource" liftIO $ debugM "Pontarius.Xmpp" "zeroSource"
ExL.throwIO XmppOtherFailure throwError XmppNoStream
handleToStreamHandle :: Handle -> StreamHandle handleToStreamHandle :: Handle -> StreamHandle
handleToStreamHandle h = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d handleToStreamHandle h = StreamHandle { streamSend = \d ->
, streamReceive = \n -> BS.hGetSome h n wrapIOException $ BS.hPut h d
, streamReceive = \n ->
wrapIOException $ BS.hGetSome h n
, streamFlush = hFlush h , streamFlush = hFlush h
, streamClose = hClose h , streamClose = hClose h
} }
@ -547,9 +541,9 @@ createStream realm config = do
lift $ debugM "Pontarius.Xmpp" "Did not acquire handle." lift $ debugM "Pontarius.Xmpp" "Did not acquire handle."
throwError TcpConnectionFailure throwError TcpConnectionFailure
where where
logConduit :: Conduit ByteString IO ByteString logConduit :: MonadIO m => Conduit ByteString m ByteString
logConduit = CL.mapM $ \d -> do logConduit = CL.mapM $ \d -> do
debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++ liftIO . debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++
"." "."
return d return d
@ -780,7 +774,7 @@ pushIQ :: Text
-> Stream -> Stream
-> IO (Either XmppFailure (Either IQError IQResult)) -> IO (Either XmppFailure (Either IQError IQResult))
pushIQ iqID to tp lang body stream = runErrorT $ do pushIQ iqID to tp lang body stream = runErrorT $ do
pushing $ pushStanza ErrorT $ pushStanza
(IQRequestS $ IQRequest iqID Nothing to lang tp body) stream (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream
res <- lift $ pullStanza stream res <- lift $ pullStanza stream
case res of case res of
@ -807,7 +801,7 @@ debugConduit = forever $ do
yield s yield s
Nothing -> return () Nothing -> return ()
elements :: R.MonadThrow m => Conduit Event m Element elements :: MonadError XmppFailure m => Conduit Event m Element
elements = do elements = do
x <- await x <- await
case x of case x of
@ -816,11 +810,11 @@ elements = do
elements elements
-- This might be an XML error if the end element tag is not -- This might be an XML error if the end element tag is not
-- "</stream>". TODO: We might want to check this at a later time -- "</stream>". TODO: We might want to check this at a later time
Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd Just (EventEndElement _) -> throwError StreamEndFailure
Just (EventContent (ContentText ct)) | Text.all isSpace ct -> Just (EventContent (ContentText ct)) | Text.all isSpace ct ->
elements elements
Nothing -> return () Nothing -> return ()
_ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x _ -> throwError $ XmppInvalidXml $ "not an element: " ++ show x
where where
many' f = many' f =
go id go id
@ -834,8 +828,7 @@ elements = do
(y, ns) <- many' goN (y, ns) <- many' goN
if y == Just (EventEndElement n) if y == Just (EventEndElement n)
then return $ Element n as $ compressNodes ns then return $ Element n as $ compressNodes ns
else lift $ R.monadThrow $ InvalidXmppXml $ else throwError . XmppInvalidXml $ "Missing close tag: " ++ show n
"Missing close tag: " ++ show n
goN = do goN = do
x <- await x <- await
case x of case x of

30
source/Network/Xmpp/Tls.hs
Unescape View File

@ -34,7 +34,10 @@ mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
bufferReceive recv n = BS.concat `liftM` (go n) bufferReceive recv n = BS.concat `liftM` (go n)
where where
go m = do go m = do
bs <- recv m mbBs <- recv m
bs <- case mbBs of
Left e -> Ex.throwIO e
Right r -> return r
case BS.length bs of case BS.length bs of
0 -> return [] 0 -> return []
l -> if l < m l -> if l < m
@ -46,7 +49,9 @@ starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
-- | Checks for TLS support and run starttls procedure if applicable -- | Checks for TLS support and run starttls procedure if applicable
tls :: Stream -> IO (Either XmppFailure ()) tls :: Stream -> IO (Either XmppFailure ())
tls con = Ex.handle (return . Left . TlsError) tls con = fmap join -- We can have Left values both from exceptions and the
-- error monad. Join unifies them into one error layer
. wrapExceptions
. flip withStream con . flip withStream con
. runErrorT $ do . runErrorT $ do
conf <- gets $ streamConfiguration conf <- gets $ streamConfiguration
@ -77,10 +82,7 @@ tls con = Ex.handle (return . Left . TlsError)
startTls = do startTls = do
liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS" liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS"
params <- gets $ tlsParams . streamConfiguration params <- gets $ tlsParams . streamConfiguration
sent <- ErrorT $ pushElement starttlsE ErrorT $ pushElement starttlsE
unless sent $ do
liftIO $ errorM "Pontarius.Xmpp.Tls" "Could not sent stanza."
throwError XmppOtherFailure
answer <- lift $ pullElement answer <- lift $ pullElement
case answer of case answer of
Left e -> throwError e Left e -> throwError e
@ -95,7 +97,7 @@ tls con = Ex.handle (return . Left . TlsError)
hand <- gets streamHandle hand <- gets streamHandle
(_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand)
let newHand = StreamHandle { streamSend = catchPush . psh let newHand = StreamHandle { streamSend = catchPush . psh
, streamReceive = recv , streamReceive = wrapExceptions . recv
, streamFlush = contextFlush ctx , streamFlush = contextFlush ctx
, streamClose = bye ctx >> streamClose hand , streamClose = bye ctx >> streamClose hand
} }
@ -173,7 +175,19 @@ connectTls config params host = do
let hand = handleToStreamHandle h let hand = handleToStreamHandle h
(_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand
return $ StreamHandle { streamSend = catchPush . psh return $ StreamHandle { streamSend = catchPush . psh
, streamReceive = recv , streamReceive = wrapExceptions . recv
, streamFlush = contextFlush ctx , streamFlush = contextFlush ctx
, streamClose = bye ctx >> streamClose hand , streamClose = bye ctx >> streamClose hand
} }
wrapExceptions :: IO a -> IO (Either XmppFailure a)
wrapExceptions f = Ex.catches (liftM Right $ f)
[ Ex.Handler $ return . Left . XmppIOException
, Ex.Handler $ wrap . XmppTlsError
, Ex.Handler $ wrap . XmppTlsConnectionNotEstablished
, Ex.Handler $ wrap . XmppTlsTerminated
, Ex.Handler $ wrap . XmppTlsHandshakeFailed
, Ex.Handler $ return . Left
]
where
wrap = return . Left . TlsError

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

@ -38,6 +38,7 @@ module Network.Xmpp.Types
, StanzaErrorCondition(..) , StanzaErrorCondition(..)
, StanzaErrorType(..) , StanzaErrorType(..)
, XmppFailure(..) , XmppFailure(..)
, XmppTlsError(..)
, StreamErrorCondition(..) , StreamErrorCondition(..)
, Version(..) , Version(..)
, StreamHandle(..) , StreamHandle(..)
@ -62,8 +63,6 @@ module Network.Xmpp.Types
, domainpart , domainpart
, resourcepart , resourcepart
, parseJid , parseJid
, StreamEnd(..)
, InvalidXmppXml(..)
, TlsBehaviour(..) , TlsBehaviour(..)
, AuthFailure(..) , AuthFailure(..)
) )
@ -486,6 +485,12 @@ data StreamErrorInfo = StreamErrorInfo
, errorXml :: !(Maybe Element) , errorXml :: !(Maybe Element)
} deriving (Show, Eq) } deriving (Show, Eq)
data XmppTlsError = XmppTlsError TLSError
| XmppTlsConnectionNotEstablished ConnectionNotEstablished
| XmppTlsTerminated Terminated
| XmppTlsHandshakeFailed HandshakeFailed
deriving (Show, Eq, Typeable)
-- | Signals an XMPP stream error or another unpredicted stream-related -- | Signals an XMPP stream error or another unpredicted stream-related
-- situation. This error is fatal, and closes the XMPP stream. -- situation. This error is fatal, and closes the XMPP stream.
data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
@ -507,7 +512,7 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
-- failed. -- failed.
| XmppIllegalTcpDetails -- ^ The TCP details provided did not | XmppIllegalTcpDetails -- ^ The TCP details provided did not
-- validate. -- validate.
| TlsError TLSError -- ^ An error occurred in the | TlsError XmppTlsError -- ^ An error occurred in the
-- TLS layer -- TLS layer
| TlsNoServerSupport -- ^ The server does not support | TlsNoServerSupport -- ^ The server does not support
-- the use of TLS -- the use of TLS
@ -522,6 +527,7 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
-- the log. -- the log.
| XmppIOException IOException -- ^ An 'IOException' | XmppIOException IOException -- ^ An 'IOException'
-- occurred -- occurred
| XmppInvalidXml String -- ^ Received data is not valid XML
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception XmppFailure instance Exception XmppFailure
@ -649,9 +655,10 @@ data ConnectionState
-- | Defines operations for sending, receiving, flushing, and closing on a -- | Defines operations for sending, receiving, flushing, and closing on a
-- stream. -- stream.
data StreamHandle = data StreamHandle =
StreamHandle { streamSend :: BS.ByteString -> IO Bool -- ^ Sends may not StreamHandle { streamSend :: BS.ByteString
-> IO (Either XmppFailure ()) -- ^ Sends may not
-- interleave -- interleave
, streamReceive :: Int -> IO BS.ByteString , streamReceive :: Int -> IO (Either XmppFailure BS.ByteString)
-- This is to hold the state of the XML parser (otherwise we -- This is to hold the state of the XML parser (otherwise we
-- will receive EventBeginDocument events and forget about -- will receive EventBeginDocument events and forget about
-- name prefixes). (TODO: Clarify) -- name prefixes). (TODO: Clarify)
@ -665,7 +672,7 @@ data StreamState = StreamState
-- | Functions to send, receive, flush, and close the stream -- | Functions to send, receive, flush, and close the stream
, streamHandle :: StreamHandle , streamHandle :: StreamHandle
-- | Event conduit source, and its associated finalizer -- | Event conduit source, and its associated finalizer
, streamEventSource :: Source IO Event , streamEventSource :: Source (ErrorT XmppFailure IO) Event
-- | Stream features advertised by the server -- | Stream features advertised by the server
, streamFeatures :: !StreamFeatures -- TODO: Maybe? , streamFeatures :: !StreamFeatures -- TODO: Maybe?
-- | The hostname or IP specified for the connection -- | The hostname or IP specified for the connection
@ -993,13 +1000,6 @@ resourceprepProfile = SP.Profile { SP.maps = [SP.b1]
, SP.shouldCheckBidi = True , SP.shouldCheckBidi = True
} }
data StreamEnd = StreamEnd deriving (Typeable, Show)
instance Exception StreamEnd
data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable)
instance Exception InvalidXmppXml
data ConnectionDetails = UseRealm -- ^ Use realm to resolv host data ConnectionDetails = UseRealm -- ^ Use realm to resolv host
| UseSrv HostName -- ^ Use this hostname for a SRV lookup | UseSrv HostName -- ^ Use this hostname for a SRV lookup
| UseHost HostName PortID -- ^ Use specified host | UseHost HostName PortID -- ^ Use specified host

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

@ -79,7 +79,7 @@ handleInfoRequest
:: [Identity] :: [Identity]
-> [Text.Text] -> [Text.Text]
-> Map.Map Text.Text ([Identity], [Text.Text]) -> Map.Map Text.Text ([Identity], [Text.Text])
-> (Stanza -> IO Bool) -> (Stanza -> IO (Either XmppFailure ()) )
-> Stanza -> Stanza
-> [Annotation] -> [Annotation]
-> IO [Annotated Stanza] -> IO [Annotated Stanza]
@ -126,7 +126,7 @@ queryItems timeout to' node session' = do
handleItemsRequest :: (Maybe Text.Text -> IO (Maybe [Item])) handleItemsRequest :: (Maybe Text.Text -> IO (Maybe [Item]))
-> (Stanza -> IO Bool) -> (Stanza -> IO (Either XmppFailure ()))
-> Stanza -> Stanza
-> [Annotation] -> [Annotation]
-> IO [Annotated Stanza] -> IO [Annotated Stanza]

Write Preview
Loading…
Cancel
Save