minor formatting and documentation additions

src/Network/XMPP/Stream.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
-{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TupleSections #-}
 
 module Network.XMPP.Stream where
 
@@ -24,98 +24,106 @@ import           Text.XML.Stream.Parse as XP
 
 -- import Text.XML.Stream.Elements
 
+-- Unpickles and returns a stream element. Throws a StreamXMLError on failure.
 streamUnpickleElem :: PU [Node] a
                    -> Element
                    -> ErrorT StreamError (Pipe Event Void IO) a
 streamUnpickleElem p x = do
-  case unpickleElem p x of
+    case unpickleElem p x of
-    Left l -> throwError $ StreamXMLError l
+        Left l -> throwError $ StreamXMLError l
-    Right r -> return r
+        Right r -> return r
 
-type StreamSink a =  ErrorT StreamError (Pipe Event Void IO) a
+-- 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
 
+-- Discards all events before the first EventBeginElement.
 throwOutJunk :: Monad m => Sink Event m ()
 throwOutJunk = do
-  next <- CL.peek
+    next <- CL.peek
-  case next of
+    case next of
-    Nothing -> return ()
+        Nothing -> return () -- This will only happen if the stream is closed.
-    Just (EventBeginElement _ _) -> return ()
+        Just (EventBeginElement _ _) -> return ()
-    _ -> CL.drop 1 >> throwOutJunk
+        _ -> CL.drop 1 >> throwOutJunk
 
+-- Returns an (empty) Element from a stream of XML events.
 openElementFromEvents :: StreamSink Element
 openElementFromEvents = do
-  lift throwOutJunk
+    lift throwOutJunk
-  hd <- lift CL.head
+    hd <- lift CL.head
-  case hd of
+    case hd of
-    Just (EventBeginElement name attrs) -> return $ Element name attrs []
+        Just (EventBeginElement name attrs) -> return $ Element name attrs []
-    _ -> throwError $ StreamConnectionError
+        _ -> throwError $ StreamConnectionError
 
+-- Sends the initial stream:stream element and pulls the server features.
 xmppStartStream :: XMPPConMonad (Either StreamError ())
 xmppStartStream = runErrorT $ do
-  hostname' <- gets sHostname
+    hostname' <- gets sHostname
-  case hostname' of
+    case hostname' of
-    Nothing -> throwError StreamConnectionError
+        Nothing -> throwError StreamConnectionError
-    Just hostname -> lift . pushOpen $
+        Just hostname -> lift . pushOpen $
-                       pickleElem pickleStream ("1.0",Nothing, Just hostname)
+            pickleElem pickleStream ("1.0", Nothing, Just hostname)
-  features <- ErrorT . pullSink $ runErrorT xmppStream
+    features <- ErrorT . pullSink $ runErrorT xmppStream
-  modify (\s -> s {sFeatures = features})
+    modify (\s -> s {sFeatures = features})
-  return ()
+    return ()
-
+
+-- Creates a new connection source (of Events) using the raw source (of bytes)
+-- and calls xmppStartStream.
 xmppRestartStream :: XMPPConMonad (Either StreamError ())
 xmppRestartStream = do
-  raw <- gets sRawSrc
+    raw <- gets sRawSrc
-  newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def
+    newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def
-  modify (\s -> s{sConSrc = newsrc})
+    modify (\s -> s{sConSrc = newsrc})
-  xmppStartStream
+    xmppStartStream
-
 
+-- Reads the (partial) stream:stream and the server features from the stream.
 xmppStream :: StreamSink ServerFeatures
 xmppStream = do
-  xmppStreamHeader
+    xmppStreamHeader
-  xmppStreamFeatures
+    xmppStreamFeatures
-
+  where
-xmppStreamHeader :: StreamSink ()
+    xmppStreamHeader :: StreamSink ()
-xmppStreamHeader = do
+    xmppStreamHeader = do
-  lift $ throwOutJunk
+        lift $ throwOutJunk
-  (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents
+        (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents
-  unless (ver == "1.0") . throwError $ StreamWrongVersion ver
+        unless (ver == "1.0") . throwError $ StreamWrongVersion ver
-  return()
+        return ()
-
+    xmppStreamFeatures :: StreamSink ServerFeatures
-
+    xmppStreamFeatures = do
-xmppStreamFeatures :: StreamSink ServerFeatures
+        e <- lift $ elements =$ CL.head
-xmppStreamFeatures = do
+        case e of
-    e <- lift $ elements =$ CL.head
+            Nothing -> liftIO $ Ex.throwIO StreamConnectionError
-    case e of
+            Just r -> streamUnpickleElem pickleStreamFeatures r
-        Nothing -> liftIO $ Ex.throwIO StreamConnectionError
+
-        Just r -> streamUnpickleElem pickleStreamFeatures r
+-- Pickler/Unpickler for the stream, with the version, from and to attributes.
-
--- Pickling
-
 pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text)
-pickleStream = xpElemAttrs (Name "stream"  (Just "http://etherx.jabber.org/streams") (Just "stream"))
+pickleStream = xpElemAttrs
-      (xpTriple
+    (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
-       (xpAttr "version" xpId)
+    (xpTriple
-       (xpOption $ xpAttr "from" xpId)
+         (xpAttr "version" xpId)
-       (xpOption $ xpAttr "to" xpId)
+         (xpOption $ xpAttr "from" xpId)
-       )
+         (xpOption $ xpAttr "to" xpId)
-
+    )
-pickleTLSFeature :: PU [Node] Bool
+
-pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
+-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
-                      (xpElemExists "required")
-
-pickleSaslFeature :: PU [Node] [Text]
-pickleSaslFeature =  xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
-                       (xpAll $ xpElemNodes
-                        "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) )
-
 pickleStreamFeatures :: PU [Node] ServerFeatures
-pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest)
+pickleStreamFeatures = xpWrap
-                              (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
+    (\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
-                               $
+    (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
-    xpElemNodes (Name "features"  (Just "http://etherx.jabber.org/streams") (Just "stream"))
+    (xpElemNodes (Name
-      (xpTriple
+         "features" (Just "http://etherx.jabber.org/streams") (Just "stream"))
-        (xpOption pickleTLSFeature)
+         (xpTriple
-        (xpOption pickleSaslFeature)
+              (xpOption pickleTLSFeature)
-        (xpAll xpElemVerbatim)
+              (xpOption pickleSaslFeature)
-      )
+              (xpAll xpElemVerbatim)
-
+         )
+    )
+  where
+    pickleTLSFeature :: PU [Node] Bool
+    pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
+        (xpElemExists "required")
+    pickleSaslFeature :: PU [Node] [Text]
+    pickleSaslFeature =  xpElemNodes
+        "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
+        (xpAll $ xpElemNodes
+             "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))