minor formatting and documentation additions

src/Network/XMPP/TLS.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Network.XMPP.TLS where
 
@@ -18,58 +18,58 @@ import           Network.XMPP.Stream
 import           Network.XMPP.Types
 
 starttlsE :: Element
-starttlsE =
+starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
-  Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
 
 exampleParams :: TLS.TLSParams
 exampleParams = TLS.defaultParams
-                      {pConnectVersion    = TLS.TLS10
+    { pConnectVersion    = TLS.TLS10
-                      , pAllowedVersions   = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
+    , pAllowedVersions   = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
-                      , pCiphers           = [TLS.cipher_AES128_SHA1]
+    , pCiphers           = [TLS.cipher_AES128_SHA1]
-                      , pCompressions      = [TLS.nullCompression]
+    , pCompressions      = [TLS.nullCompression]
-                      , pWantClientCert    = False -- Used for servers
+    , pWantClientCert    = False -- Used for servers
-                      , pUseSecureRenegotiation = False -- No renegotiation
+    , pUseSecureRenegotiation = False -- No renegotiation
-                      , pCertificates      = [] -- TODO
+    , pCertificates      = [] -- TODO
-                      , pLogging           = TLS.defaultLogging -- TODO
+    , pLogging           = TLS.defaultLogging -- TODO
-                      , onCertificatesRecv = \ _certificate ->
+    , onCertificatesRecv = \_certificate ->
-                                             return TLS.CertificateUsageAccept
+          return TLS.CertificateUsageAccept
-                      }
+    }
 
 -- | Error conditions that may arise during TLS negotiation.
 data XMPPTLSError = TLSError TLSError
                   | TLSNoServerSupport
                   | TLSNoConnection
                   | TLSStreamError StreamError
+                  | XMPPTLSError -- General instance used for the Error instance
                     deriving (Show, Eq, Typeable)
 
 instance Error XMPPTLSError where
-  noMsg = TLSNoConnection -- TODO: What should we choose here?
+  noMsg = XMPPTLSError
 
+-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
+-- restarts the stream. May throw errors.
 startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ())
-startTLS params = Ex.handle (return . Left . TLSError)
+startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
-  . runErrorT $ do
+    features <- lift $ gets sFeatures
-      features <- lift $ gets sFeatures
+    handle' <- lift $ gets sConHandle
-      handle' <- lift $ gets sConHandle
+    handle <- maybe (throwError TLSNoConnection) return handle'
-      handle <- maybe (throwError TLSNoConnection) return handle'
+    when (stls features == Nothing) $ throwError TLSNoServerSupport
-      when (stls features == Nothing) $ throwError TLSNoServerSupport
+    lift $ pushN starttlsE
-      lift $ pushN starttlsE
+    answer <- lift $ pullElement
-      answer <- lift $ pullElement
+    case answer of
-      case answer of
         Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()
-        Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _
+        Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ ->
-            -> lift . Ex.throwIO $ StreamConnectionError
+            lift . Ex.throwIO $ StreamConnectionError
-                 -- TODO: find something more suitable
+            -- TODO: find something more suitable
-        e -> lift . Ex.throwIO . StreamXMLError
+        e -> lift . Ex.throwIO . StreamXMLError $
-               $ "Unexpected element: " ++ ppElement e
+            "Unexpected element: " ++ ppElement e
-      (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle
+    (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle
-      lift $ modify (\x -> x
+    lift $ modify ( \x -> x
-                    { sRawSrc = raw
+                  { sRawSrc = raw
---                  , sConSrc =  -- Note: this momentarily leaves us in an
+--                , sConSrc =  -- Note: this momentarily leaves us in an
-                                 -- inconsistent state
+                               -- inconsistent state
-                    , sConPushBS = catchPush . psh
+                  , sConPushBS = catchPush . psh
-                    , sCloseConnection = TLS.bye ctx >> sCloseConnection x
+                  , sCloseConnection = TLS.bye ctx >> sCloseConnection x
-                    })
+                  })
-      either (lift . Ex.throwIO) return =<< lift xmppRestartStream
+    either (lift . Ex.throwIO) return =<< lift xmppRestartStream
-      modify (\s -> s{sConnectionState = XmppConnectionSecured})
+    modify (\s -> s{sConnectionState = XmppConnectionSecured})
-      return ()
+    return ()
-