From cca3a6d4d01be53a120161921d65ac5700561130 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Apr 2012 18:59:04 +0200 Subject: [PATCH] added error handling to Stream, TLS switched to Strict State switched to mtl improved build script --- build.sh | 1 + pontarius.cabal | 2 + src/Network/XMPP.hs | 2 +- src/Network/XMPP/Bind.hs | 2 +- src/Network/XMPP/Concurrent/Monad.hs | 4 +- src/Network/XMPP/Concurrent/Threads.hs | 7 ++- src/Network/XMPP/Monad.hs | 4 +- src/Network/XMPP/Pickle.hs | 7 ++- src/Network/XMPP/SASL.hs | 2 +- src/Network/XMPP/Stream.hs | 59 +++++++++++++++++--------- src/Network/XMPP/TLS.hs | 56 ++++++++++++++++-------- src/Network/XMPP/Types.hs | 25 ++++++++--- src/Tests.hs | 4 +- 13 files changed, 115 insertions(+), 60 deletions(-) diff --git a/build.sh b/build.sh index afccab5..7e92cce 100644 --- a/build.sh +++ b/build.sh @@ -3,4 +3,5 @@ git submodule init git submodule update cabal-dev install ./xml-types-pickle cabal-dev install-deps +cabal-dev configure cabal-dev build diff --git a/pontarius.cabal b/pontarius.cabal index cb80740..947d444 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -26,6 +26,7 @@ Library Exposed: True Build-Depends: base >4 && <5 , conduit -any + , void -any , resourcet -any , containers -any , random -any @@ -48,6 +49,7 @@ Library , xml-conduit -any , xml-types-pickle -any , data-default -any +-- , stringprep -any Exposed-modules: Network.XMPP , Network.XMPP.Types , Network.XMPP.SASL diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 51c84d7..8c531e3 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -58,7 +58,7 @@ import Network.XMPP.Stream import Network.XMPP.TLS import Network.XMPP.Types -xmppConnect :: HostName -> Text -> XMPPConMonad () +xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 4ea7b3f..0cd307e 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -27,7 +27,7 @@ xmppThreadedBind :: Maybe Text -> XMPPThread Text xmppThreadedBind rsrc = do answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling - let (JID _n _d (Just r)) = unpickleElem jidP b + let Right (JID _n _d (Just r)) = unpickleElem jidP b return r diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a7ccb62..a39ce1b 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -6,8 +6,8 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad.Reader +import Control.Monad.State.Strict import Data.IORef import qualified Data.Map as Map diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 40669e3..b40024b 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -10,10 +10,9 @@ import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Control.Monad.Trans.State +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State.Strict import qualified Data.ByteString as BS import Data.Conduit diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 0b61c6a..cf3b634 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -8,7 +8,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource import Control.Concurrent -import Control.Monad.Trans.State +import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit @@ -55,7 +55,7 @@ pullE :: XMPPConMonad Element pullE = pulls elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem p <$> pullE +pullPickle p = unpickleElem' p <$> pullE pull :: XMPPConMonad Stanza pull = pullPickle stanzaP diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index a999956..97d3989 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -52,11 +52,14 @@ right :: Either [Char] t -> t right (Left l) = error l right (Right r) = r -unpickleElem :: PU [Node] c -> Element -> c -unpickleElem p x = case unpickle (xpNodeElem p) x of +unpickleElem' :: PU [Node] c -> Element -> c +unpickleElem' p x = case unpickle (xpNodeElem p) x of Left l -> error $ l ++ "\n saw: " ++ ppElement x Right r -> r +unpickleElem :: PU [Node] a -> Element -> Either String a +unpickleElem p x = unpickle (xpNodeElem p) x + pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 53b6c2e..72d823b 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -4,7 +4,7 @@ module Network.XMPP.SASL where import Control.Applicative import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.State +import Control.Monad.State.Strict import qualified Crypto.Classes as CC diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index b95706a..6f750e4 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -4,14 +4,17 @@ module Network.XMPP.Stream where import Control.Applicative((<$>)) +import Control.Exception(throwIO) import Control.Monad(unless) -import Control.Monad.Trans.State +import Control.Monad.Error +import Control.Monad.State.Strict import Data.Conduit import Data.Conduit.List as CL import Data.Text as T import Data.XML.Pickle import Data.XML.Types +import Data.Void(Void) import Network.XMPP.Monad import Network.XMPP.Pickle @@ -22,6 +25,16 @@ import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +streamUnpickleElem :: PU [Node] a + -> Element + -> ErrorT StreamError (Pipe Event Void IO) a +streamUnpickleElem p x = do + case unpickleElem p x of + Left l -> throwError $ StreamUnpickleError l + Right r -> return r + +type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a + throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do next <- CL.peek @@ -30,22 +43,26 @@ throwOutJunk = do Just (EventBeginElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk -openElementFromEvents :: Monad m => Sink Event m Element +openElementFromEvents :: StreamSink Element openElementFromEvents = do - throwOutJunk - Just (EventBeginElement name attrs) <- CL.head - return $ Element name attrs [] - - -xmppStartStream :: XMPPConMonad () -xmppStartStream = do - hostname <- gets sHostname - pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname) - features <- pulls xmppStream + lift throwOutJunk + hd <- lift CL.head + case hd of + Just (EventBeginElement name attrs) -> return $ Element name attrs [] + _ -> throwError $ StreamConnectionError + +xmppStartStream :: XMPPConMonad (Either StreamError ()) +xmppStartStream = runErrorT $ do + hostname' <- gets sHostname + case hostname' of + Nothing -> throwError StreamConnectionError + Just hostname -> lift . pushOpen $ + pickleElem pickleStream ("1.0",Nothing, Just hostname) + features <- ErrorT . pulls $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () -xmppRestartStream :: XMPPConMonad () +xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do raw <- gets sRawSrc let newsrc = raw $= XP.parseBytes def @@ -53,22 +70,22 @@ xmppRestartStream = do xmppStartStream -xmppStream :: Sink Event IO ServerFeatures +xmppStream :: StreamSink ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures -xmppStreamHeader :: Sink Event IO () +xmppStreamHeader :: StreamSink () xmppStreamHeader = do - throwOutJunk - (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents - unless (ver == "1.0") $ error "Not XMPP version 1.0 " + lift $ throwOutJunk + (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents + unless (ver == "1.0") . throwError $ StreamWrongVersion ver return() -xmppStreamFeatures :: Sink Event IO ServerFeatures -xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents - +xmppStreamFeatures :: StreamSink ServerFeatures +xmppStreamFeatures = streamUnpickleElem pickleStreamFeatures + =<< lift elementFromEvents -- Pickling diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 55884d5..7b9f159 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -1,15 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.TLS where +import Control.Applicative((<$>)) +import Control.Arrow(left) +import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Monad.Error +import Control.Monad.State.Strict +import Control.Monad.Trans import Data.Conduit import Data.Conduit.List as CL import Data.Conduit.TLS as TLS import Data.Default +import Data.Typeable import Data.XML.Types import qualified Network.TLS as TLS @@ -39,21 +45,37 @@ exampleParams = TLS.defaultParams return TLS.CertificateUsageAccept } -xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () -xmppStartTLS params = do - features <- gets sFeatures - unless (stls features == Nothing) $ do - pushN starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE - Just handle <- gets sConHandle +data XMPPTLSError = TLSError TLSError + | TLSNoServerSupport + | TLSNoConnection + | TLSStreamError StreamError + deriving (Show, Eq, Typeable) + +instance Error XMPPTLSError where + noMsg = TLSNoConnection -- TODO: What should we choose here? +instance Ex.Exception XMPPTLSError + + +xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) +xmppStartTLS params = Ex.handle (return . Left . TLSError) + . runErrorT $ do + features <- lift $ gets sFeatures + handle' <- lift $ gets sConHandle + handle <- maybe (throwError TLSNoConnection) return handle' + when (stls features == Nothing) $ throwError TLSNoServerSupport + lift $ pushN starttlsE + answer <- lift $ pullE + case answer of + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () + _ -> throwError $ TLSStreamError StreamXMLError (raw, snk, psh) <- lift $ TLS.tlsinit params handle - modify (\x -> x - { sRawSrc = raw --- , sConSrc = -- Note: this momentarily leaves us in an - -- inconsistent state - , sConPushBS = psh - }) - xmppRestartStream + lift $ modify (\x -> x + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConPushBS = psh + }) + ErrorT $ (left TLSStreamError) <$> xmppRestartStream modify (\s -> s{sHaveTLS = True}) - return () + return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 550c189..a3e827c 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} -- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the -- Pontarius distribution for more details. @@ -15,8 +16,11 @@ module Network.XMPP.Types where -- import Network.XMPP.Utilities (idGenerator) import Control.Applicative((<$>)) +import Control.Exception import Control.Monad.IO.Class -import Control.Monad.State +import Control.Monad.State.Strict +import Control.Monad.Error + import qualified Data.ByteString as BS import Data.Conduit @@ -24,6 +28,7 @@ import Data.List.Split as L import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text +import Data.Typeable(Typeable) import Data.XML.Types import qualified Network as N @@ -58,7 +63,7 @@ data SessionSettings = -- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- Stanza identifiers are generated by Pontarius. -data StanzaId = SI Text deriving (Eq, Ord) +data StanzaId = SI !Text deriving (Eq, Ord) instance Show StanzaId where show (SI s) = Text.unpack s @@ -73,11 +78,11 @@ instance IsString StanzaId where -- @From@ is a readability type synonym for @Address@. -- | Jabber ID (JID) datatype -data JID = JID { localpart :: Maybe Text +data JID = JID { localpart :: !(Maybe Text) -- ^ Account name - , domainpart :: Text + , domainpart :: !Text -- ^ Server adress - , resourcepart :: Maybe Text + , resourcepart :: !(Maybe Text) -- ^ Resource name } @@ -533,8 +538,14 @@ data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) type Timeout = Int -data StreamError = StreamError - +data StreamError = StreamError String + | StreamWrongVersion Text + | StreamXMLError + | StreamUnpickleError String + | StreamConnectionError + deriving (Show, Eq, Typeable) +instance Exception StreamError +instance Error StreamError where strMsg = StreamError -- ============================================================================= -- XML TYPES diff --git a/src/Tests.hs b/src/Tests.hs index 2e99ea2..07b5602 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -54,7 +54,7 @@ iqResponder = do >> error "hanging up" forever $ do next@(iq,_) <- liftIO . atomically $ readTChan chan - let payload = unpickleElem payloadP $ iqRequestPayload iq + let Right payload = unpickleElem payloadP $ iqRequestPayload iq let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload answerIQ next (Right $ Just answerBody) @@ -105,7 +105,7 @@ runMain debug number = do let payload = Payload count (even count) (Text.pack $ show count) let body = pickleElem payloadP payload Right answer <- sendIQ' (Just them) Get Nothing body - let answerPayload = unpickleElem payloadP + let Right answerPayload = unpickleElem payloadP (fromJust $ iqResultPayload answer) expect debug' (invertPayload payload) answerPayload liftIO $ threadDelay 100000