added error handling to Stream, TLS

switched to Strict State
switched to mtl
improved build script

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

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

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)

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
 
 

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

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

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

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
 

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
 

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
 

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
+      lift $ modify (\x -> x
                     { sRawSrc = raw
 --                  , sConSrc =  -- Note: this momentarily leaves us in an
                                  -- inconsistent state
                     , sConPushBS = psh
                     })
-      xmppRestartStream
+      ErrorT $ (left TLSStreamError) <$> xmppRestartStream
       modify (\s -> s{sHaveTLS = True})
       return ()
 

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

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