update to conduit 0.5 and xml-conduit 1.0

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

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

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
+    con <- client tlsParams gen handle
+    handshake con
+    let src = forever $ do
+            dt <- liftIO $ 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 ())
+            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
            )

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 ()

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

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 ()

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