From aec8b3e2c3651697c0075570d97d08bace50b875 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 2 Jul 2012 12:33:52 +0200 Subject: [PATCH] update to conduit 0.5 and xml-conduit 1.0 --- pontarius-xmpp.cabal | 6 ++--- source/Data/Conduit/BufferedSource.hs | 24 +++++++++++++++---- source/Data/Conduit/TLS.hs | 34 +++++++++++++-------------- source/Network/Xmpp.hs | 28 ++++++++++++++++++++++ source/Network/Xmpp/Monad.hs | 7 ++++-- source/Network/Xmpp/Stream.hs | 4 ++-- source/Text/XML/Stream/Elements.hs | 9 +++++-- 7 files changed, 81 insertions(+), 31 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index e59005a..acb5bbb 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -26,7 +26,7 @@ Library hs-source-dirs: source Exposed: True Build-Depends: base >4 && <5 - , conduit -any + , conduit >= 0.5 , void -any , resourcet -any , containers -any @@ -48,8 +48,8 @@ Library , split -any , stm -any , xml-types -any - , xml-conduit -any - , xml-types-pickle -any + , xml-conduit >= 1.0 + , xml-picklers >= 0.1 , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.Xmpp diff --git a/source/Data/Conduit/BufferedSource.hs b/source/Data/Conduit/BufferedSource.hs index c755509..cfb620e 100644 --- a/source/Data/Conduit/BufferedSource.hs +++ b/source/Data/Conduit/BufferedSource.hs @@ -1,20 +1,34 @@ +{-# 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 + -- | Buffered source from conduit 0.3 bufferSource :: MonadIO m => Source m o -> IO (Source m o) bufferSource s = do - srcRef <- newIORef s + srcRef <- newIORef . Just $ DCI.ResumableSource s (return ()) return $ do - src <- liftIO $ readIORef srcRef + src' <- liftIO $ readIORef srcRef + src <- case src' of + Just s -> return s + Nothing -> liftIO $ throwIO SourceClosed let go src = do - (src', res) <- lift $ src $$+ CL.head + (src', res) <- lift $ src $$++ CL.head case res of - Nothing -> return () - Just x -> liftIO (writeIORef srcRef src') >> yield x >> go src' + Nothing -> liftIO $ writeIORef srcRef Nothing + Just x -> do + liftIO (writeIORef srcRef $ Just src') + yield x + go src' in go src diff --git a/source/Data/Conduit/TLS.hs b/source/Data/Conduit/TLS.hs index 7cb2df2..cd89aab 100644 --- a/source/Data/Conduit/TLS.hs +++ b/source/Data/Conduit/TLS.hs @@ -16,6 +16,7 @@ import Crypto.Random import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit +import Control.Monad import Network.TLS as TLS import Network.TLS.Extra as TLSExtra @@ -33,25 +34,24 @@ tlsinit :: (MonadIO m, MonadIO m1) => tlsinit debug tlsParams handle = do when debug . liftIO $ putStrLn "Debug mode enabled" gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? - clientContext <- client tlsParams gen handle - handshake clientContext - let src = sourceState - clientContext - (\con -> do - dt <- recvData con - when debug (liftIO $ BS.putStrLn dt) - return $ StateOpen con dt) - let snk = sinkState - clientContext - (\con bs -> do - sendData con (BL.fromChunks [bs]) - when debug (liftIO $ BS.putStrLn bs) - return (StateProcessing con)) - (\_ -> return ()) + con <- client tlsParams gen handle + handshake con + let src = forever $ do + dt <- liftIO $ recvData con + when debug (liftIO $ BS.putStrLn dt) + yield dt + let snk = do + d <- await + case d of + Nothing -> return () + Just x -> do + sendData con (BL.fromChunks [x]) + when debug (liftIO $ BS.putStrLn x) + snk return ( src , snk , \s -> do when debug (liftIO $ BS.putStrLn s) - sendData clientContext $ BL.fromChunks [s] - , clientContext + sendData con $ BL.fromChunks [s] + , con ) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 12495ae..d3924ac 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -223,3 +223,31 @@ simpleAuth username passwd resource = flip auth resource $ scramSha1 username Nothing passwd , digestMd5 username Nothing passwd ] + + + +-- | The quick and easy way to set up a connection to an XMPP server +-- +-- This will +-- * connect to the host +-- * secure the connection with TLS +-- * authenticate to the server using either SCRAM-SHA1 (preferred) or +-- Digest-MD5 +-- * bind a resource +-- +-- Note that the server might assign a different resource even when we send +-- a preference. +simpleConnect :: HostName -- ^ Target host name + -> Text -- ^ User name (authcid) + -> Text -- ^ Password + -> Maybe Text -- ^ Desired resource (or Nothing to let the server + -- decide) + -> XmppConMonad () +simpleConnect host username password resource = do + connect host username + startTLS exampleParams + saslResponse <- simpleAuth username password resource + case saslResponse of + Right _ -> return () + Left e -> error $ show e + return () diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index 342d44a..5d01f74 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -78,8 +78,11 @@ pullElement = do Just r -> return r ) [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) - , Ex.Handler (\(InvalidEventStream s) + , Ex.Handler (\(InvalidXmppXml s) -> liftIO . Ex.throwIO $ StreamXMLError s) + , Ex.Handler $ \(e :: InvalidEventStream) + -> liftIO . Ex.throwIO $ StreamXMLError (show e) + ] -- Pulls an element and unpickles it. @@ -225,7 +228,7 @@ xmppCloseStreams = do Left _ -> return (elems, False) Right elem -> collectElems (elem:elems) -debugConduit :: MonadIO m => Pipe BS.ByteString BS.ByteString m () +debugConduit :: Pipe l ByteString ByteString u IO b debugConduit = forever $ do s <- await case s of diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 1c64db0..a51114f 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -30,7 +30,7 @@ import Text.XML.Stream.Parse as XP -- Unpickles and returns a stream element. Throws a StreamXMLError on failure. streamUnpickleElem :: PU [Node] a -> Element - -> ErrorT StreamError (Pipe Event Void IO) a + -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of Left l -> throwError $ StreamXMLError l @@ -38,7 +38,7 @@ streamUnpickleElem p x = do -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a +type StreamSink a = ErrorT StreamError (Pipe Event Event Void () IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () diff --git a/source/Text/XML/Stream/Elements.hs b/source/Text/XML/Stream/Elements.hs index 740a2f6..a10e7a6 100644 --- a/source/Text/XML/Stream/Elements.hs +++ b/source/Text/XML/Stream/Elements.hs @@ -35,6 +35,10 @@ streamName = data StreamEnd = StreamEnd deriving (Typeable, Show) instance Exception StreamEnd +data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) + +instance Exception InvalidXmppXml + elements :: R.MonadThrow m => C.Conduit Event m Element elements = do x <- C.await @@ -44,7 +48,7 @@ elements = do elements Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd Nothing -> return () - _ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x + _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x where many' f = go id @@ -58,7 +62,8 @@ elements = do (y, ns) <- many' goN if y == Just (EventEndElement n) then return $ Element n as $ compressNodes ns - else lift $ R.monadThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y + else lift $ R.monadThrow $ InvalidXmppXml $ + "Missing close tag: " ++ show n goN = do x <- await case x of