Browse Source

Projects/Pontarius/Apply various minor fixes

Started using double quotes instead of single quotes on XMLDecl, to
conform to the quotations of the other XML.

To conform with the Haskell style guidelines, `TLS' is now spelled
`Tls', and `XML' is now spelled `Xml'.

Updated library name in README file.
master
Jon Kristensen 13 years ago
parent
commit
c34982dba9
  1. 4
      README
  2. 6
      pontarius-xmpp.cabal
  3. 2
      source/Data/Conduit/Tls.hs
  4. 10
      source/Network/Xmpp.hs
  5. 4
      source/Network/Xmpp/Basic.hs
  6. 2
      source/Network/Xmpp/Concurrent/Channels.hs
  7. 4
      source/Network/Xmpp/Connection.hs
  8. 2
      source/Network/Xmpp/Pickle.hs
  9. 12
      source/Network/Xmpp/Session.hs
  10. 12
      source/Network/Xmpp/Stream.hs
  11. 14
      source/Network/Xmpp/Tls.hs
  12. 20
      source/Network/Xmpp/Types.hs
  13. 8
      source/Network/Xmpp/Xep/ServiceDiscovery.hs
  14. 2
      source/Text/Xml/Stream/Elements.hs

4
README

@ -1,2 +1,2 @@
Pontarius is an active work in progress to build a Haskell XMPP library that Pontarius XMPP is an active work in progress to build a Haskell XMPP library
implements the client capabilities of RFC 6120 ("XMPP Core"). that implements the client capabilities of RFC 6120 ("XMPP Core").

6
pontarius-xmpp.cabal

@ -56,7 +56,7 @@ Library
Exposed-modules: Network.Xmpp Exposed-modules: Network.Xmpp
, Network.Xmpp.IM , Network.Xmpp.IM
, Network.Xmpp.Basic , Network.Xmpp.Basic
Other-modules: Data.Conduit.TLS Other-modules: Data.Conduit.Tls
, Network.Xmpp.Bind , Network.Xmpp.Bind
, Network.Xmpp.Concurrent , Network.Xmpp.Concurrent
, Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Types
@ -87,10 +87,10 @@ Library
, Network.Xmpp.Sasl.Types , Network.Xmpp.Sasl.Types
, Network.Xmpp.Session , Network.Xmpp.Session
, Network.Xmpp.Stream , Network.Xmpp.Stream
, Network.Xmpp.TLS , Network.Xmpp.Tls
, Network.Xmpp.Types , Network.Xmpp.Types
, Network.Xmpp.Xep.ServiceDiscovery , Network.Xmpp.Xep.ServiceDiscovery
, Text.XML.Stream.Elements , Text.Xml.Stream.Elements
GHC-Options: -Wall GHC-Options: -Wall
Source-Repository head Source-Repository head

2
source/Data/Conduit/TLS.hs → source/Data/Conduit/Tls.hs

@ -1,6 +1,6 @@
{-# Language NoMonomorphismRestriction #-} {-# Language NoMonomorphismRestriction #-}
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Data.Conduit.TLS module Data.Conduit.Tls
( tlsinit ( tlsinit
-- , conduitStdout -- , conduitStdout
, module TLS , module TLS

10
source/Network/Xmpp.hs

@ -25,11 +25,11 @@
module Network.Xmpp module Network.Xmpp
( -- * Session management ( -- * Session management
Session Session
, simpleConnect
, connectTcp
, newSession , newSession
, withConnection , withConnection
, connectTcp , startTls
, simpleConnect
, startTLS
, simpleAuth , simpleAuth
, auth , auth
, scramSha1 , scramSha1
@ -148,7 +148,7 @@ module Network.Xmpp
, StreamFailure(..) , StreamFailure(..)
, StreamErrorInfo(..) , StreamErrorInfo(..)
, StreamErrorCondition(..) , StreamErrorCondition(..)
, TLSFailure(..) , TlsFailure(..)
) where ) where
@ -166,5 +166,5 @@ import Network.Xmpp.Presence
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Session import Network.Xmpp.Session
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.TLS import Network.Xmpp.Tls
import Network.Xmpp.Types import Network.Xmpp.Types

4
source/Network/Xmpp/Basic.hs

@ -3,7 +3,7 @@ module Network.Xmpp.Basic
, ConnectionState(..) , ConnectionState(..)
, connectTcp , connectTcp
, simpleConnect , simpleConnect
, startTLS , startTls
, simpleAuth , simpleAuth
, auth , auth
, scramSha1 , scramSha1
@ -19,5 +19,5 @@ import Network.Xmpp.Connection
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Session import Network.Xmpp.Session
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.TLS import Network.Xmpp.Tls
import Network.Xmpp.Types import Network.Xmpp.Types

2
source/Network/Xmpp/Concurrent/Channels.hs

@ -32,7 +32,7 @@ import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Marshal import Network.Xmpp.Marshal
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.Xml.Stream.Elements
toChans :: TChan Stanza toChans :: TChan Stanza
-> TVar IQHandlers -> TVar IQHandlers

4
source/Network/Xmpp/Connection.hs

@ -33,7 +33,7 @@ import Network.Xmpp.Pickle
import System.IO import System.IO
import Text.XML.Stream.Elements import Text.Xml.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..)) import Text.XML.Unresolved(InvalidEventStream(..))
@ -62,7 +62,7 @@ pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s
pushXmlDecl :: StateT Connection_ IO Bool pushXmlDecl :: StateT Connection_ IO Bool
pushXmlDecl = do pushXmlDecl = do
con <- gets cHand con <- gets cHand
liftIO $ (cSend con) "<?xml version='1.0' encoding='UTF-8' ?>" liftIO $ (cSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
pushOpenElement :: Element -> StateT Connection_ IO Bool pushOpenElement :: Element -> StateT Connection_ IO Bool
pushOpenElement e = do pushOpenElement e = do

2
source/Network/Xmpp/Pickle.hs

@ -27,7 +27,7 @@ import Data.XML.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.Xml.Stream.Elements
mbToBool :: Maybe t -> Bool mbToBool :: Maybe t -> Bool
mbToBool (Just _) = True mbToBool (Just _) = True

12
source/Network/Xmpp/Session.hs

@ -19,7 +19,7 @@ import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Mechanisms
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.TLS import Network.Xmpp.Tls
import Network.Xmpp.Types import Network.Xmpp.Types
-- | The quick and easy way to set up a connection to an XMPP server -- | The quick and easy way to set up a connection to an XMPP server
@ -53,7 +53,7 @@ simpleConnect host port hostname username password resource = do
con <- case con' of con <- case con' of
Left e -> Ex.throwIO e Left e -> Ex.throwIO e
Right r -> return r Right r -> return r
startTLS exampleParams con startTls exampleParams con
saslResponse <- simpleAuth username password resource con saslResponse <- simpleAuth username password resource con
case saslResponse of case saslResponse of
Right jid -> newSession con Right jid -> newSession con
@ -88,8 +88,8 @@ connectTcp address port hostname = do
-- TODO: Catch remaining xmppStartStream errors. -- TODO: Catch remaining xmppStartStream errors.
toError _ = StreamErrorInfo StreamBadFormat Nothing Nothing toError _ = StreamErrorInfo StreamBadFormat Nothing Nothing
sessionXML :: Element sessionXml :: Element
sessionXML = pickleElem sessionXml = pickleElem
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")
() ()
@ -99,14 +99,14 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
, iqRequestTo = Nothing , iqRequestTo = Nothing
, iqRequestLangTag = Nothing , iqRequestLangTag = Nothing
, iqRequestType = Set , iqRequestType = Set
, iqRequestPayload = sessionXML , iqRequestPayload = sessionXml
} }
-- Sends the session IQ set element and waits for an answer. Throws an error if -- Sends the session IQ set element and waits for an answer. Throws an error if
-- if an IQ error stanza is returned from the server. -- if an IQ error stanza is returned from the server.
startSession :: Connection -> IO () startSession :: Connection -> IO ()
startSession con = do startSession con = do
answer <- pushIQ' "session" Nothing Set Nothing sessionXML con answer <- pushIQ' "session" Nothing Set Nothing sessionXml con
case answer of case answer of
Left e -> error $ show e Left e -> error $ show e
Right _ -> return () Right _ -> return ()

12
source/Network/Xmpp/Stream.hs

@ -25,18 +25,18 @@ import Network.Xmpp.Errors
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.Xml.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
-- Unpickles and returns a stream element. Throws a StreamXMLError on failure. -- Unpickles and returns a stream element. Throws a StreamXmlError on failure.
streamUnpickleElem :: PU [Node] a streamUnpickleElem :: PU [Node] a
-> Element -> Element
-> StreamSink a -> StreamSink a
streamUnpickleElem p x = do streamUnpickleElem p x = do
case unpickleElem p x of case unpickleElem p x of
Left l -> throwError $ StreamOtherFailure -- TODO: Log: StreamXMLError (show l) Left l -> throwError $ StreamOtherFailure -- TODO: Log: StreamXmlError (show l)
Right r -> return r Right r -> return r
-- This is the conduit sink that handles the stream XML events. We extend it -- This is the conduit sink that handles the stream XML events. We extend it
@ -166,14 +166,14 @@ xpStreamFeatures = xpWrap
(Just "stream") (Just "stream")
) )
(xpTriple (xpTriple
(xpOption pickleTLSFeature) (xpOption pickleTlsFeature)
(xpOption pickleSaslFeature) (xpOption pickleSaslFeature)
(xpAll xpElemVerbatim) (xpAll xpElemVerbatim)
) )
) )
where where
pickleTLSFeature :: PU [Node] Bool pickleTlsFeature :: PU [Node] Bool
pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" pickleTlsFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
(xpElemExists "required") (xpElemExists "required")
pickleSaslFeature :: PU [Node] [Text] pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = xpElemNodes pickleSaslFeature = xpElemNodes

14
source/Network/Xmpp/TLS.hs → source/Network/Xmpp/Tls.hs

@ -2,7 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.TLS where module Network.Xmpp.Tls where
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
@ -13,7 +13,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import Data.Conduit.TLS as TLS import Data.Conduit.Tls as TLS
import Data.Typeable import Data.Typeable
import Data.XML.Types import Data.XML.Types
@ -74,18 +74,18 @@ exampleParams = TLS.defaultParamsClient
-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
-- restarts the stream. -- restarts the stream.
startTLS :: TLS.TLSParams -> Connection -> IO (Either TLSFailure ()) startTls :: TLS.TLSParams -> Connection -> IO (Either TlsFailure ())
startTLS params con = Ex.handle (return . Left . TLSError) startTls params con = Ex.handle (return . Left . TlsError)
. flip withConnection con . flip withConnection con
. runErrorT $ do . runErrorT $ do
features <- lift $ gets sFeatures features <- lift $ gets sFeatures
state <- gets sConnectionState state <- gets sConnectionState
case state of case state of
ConnectionPlain -> return () ConnectionPlain -> return ()
ConnectionClosed -> throwError TLSNoConnection ConnectionClosed -> throwError TlsNoConnection
ConnectionSecured -> throwError TLSConnectionSecured ConnectionSecured -> throwError TlsConnectionSecured
con <- lift $ gets cHand con <- lift $ gets cHand
when (stls features == Nothing) $ throwError TLSNoServerSupport when (stls features == Nothing) $ throwError TlsNoServerSupport
lift $ pushElement starttlsE lift $ pushElement starttlsE
answer <- lift $ pullElement answer <- lift $ pullElement
case answer of case answer of

20
source/Network/Xmpp/Types.hs

@ -40,7 +40,7 @@ module Network.Xmpp.Types
, ConnectionState(..) , ConnectionState(..)
, StreamErrorInfo(..) , StreamErrorInfo(..)
, langTag , langTag
, TLSFailure(..) , TlsFailure(..)
, module Network.Xmpp.Jid , module Network.Xmpp.Jid
) )
where where
@ -625,7 +625,7 @@ instance Read StreamErrorCondition where
data StreamErrorInfo = StreamErrorInfo data StreamErrorInfo = StreamErrorInfo
{ errorCondition :: !StreamErrorCondition { errorCondition :: !StreamErrorCondition
, errorText :: !(Maybe (Maybe LangTag, Text)) , errorText :: !(Maybe (Maybe LangTag, Text))
, errorXML :: !(Maybe Element) , errorXml :: !(Maybe Element)
} deriving (Show, Eq) } deriving (Show, Eq)
-- | Signals an XMPP stream error or another unpredicted stream-related -- | Signals an XMPP stream error or another unpredicted stream-related
@ -814,13 +814,13 @@ mkConnection con = Connection `fmap` (atomically $ newTMVar con)
-- | Failure conditions that may arise during TLS negotiation. -- | Failure conditions that may arise during TLS negotiation.
data TLSFailure = TLSError TLS.TLSError data TlsFailure = TlsError TLS.TLSError
| TLSNoServerSupport | TlsNoServerSupport
| TLSNoConnection | TlsNoConnection
| TLSConnectionSecured -- ^ Connection already secured | TlsConnectionSecured -- ^ Connection already secured
| TLSStreamError StreamFailure | TlsStreamError StreamFailure
| TLSFailureError -- General instance used for the Error instance (TODO) | TlsFailureError -- General instance used for the Error instance (TODO)
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Error TLSFailure where instance Error TlsFailure where
noMsg = TLSFailureError noMsg = TlsFailureError

8
source/Network/Xmpp/Xep/ServiceDiscovery.hs

@ -35,7 +35,7 @@ import Network.Xmpp.Types
data DiscoError = DiscoNoQueryElement data DiscoError = DiscoNoQueryElement
| DiscoIQError IQError | DiscoIQError IQError
| DiscoTimeout | DiscoTimeout
| DiscoXMLError Element UnpickleError | DiscoXmlError Element UnpickleError
deriving (Show) deriving (Show)
@ -97,7 +97,7 @@ queryInfo to node context = do
IQResponseResult r -> case iqResultPayload r of IQResponseResult r -> case iqResultPayload r of
Nothing -> Left DiscoNoQueryElement Nothing -> Left DiscoNoQueryElement
Just p -> case unpickleElem xpQueryInfo p of Just p -> case unpickleElem xpQueryInfo p of
Left e -> Left $ DiscoXMLError p e Left e -> Left $ DiscoXmlError p e
Right r -> Right r Right r -> Right r
where where
queryBody = pickleElem xpQueryInfo (QIR node [] []) queryBody = pickleElem xpQueryInfo (QIR node [] [])
@ -114,7 +114,7 @@ xmppQueryInfo to node con = do
Right r -> case iqResultPayload r of Right r -> case iqResultPayload r of
Nothing -> Left DiscoNoQueryElement Nothing -> Left DiscoNoQueryElement
Just p -> case unpickleElem xpQueryInfo p of Just p -> case unpickleElem xpQueryInfo p of
Left e -> Left $ DiscoXMLError p e Left e -> Left $ DiscoXmlError p e
Right r -> Right r Right r -> Right r
where where
queryBody = pickleElem xpQueryInfo (QIR node [] []) queryBody = pickleElem xpQueryInfo (QIR node [] [])
@ -161,7 +161,7 @@ queryItems to node session = do
IQResponseResult r -> case iqResultPayload r of IQResponseResult r -> case iqResultPayload r of
Nothing -> Left DiscoNoQueryElement Nothing -> Left DiscoNoQueryElement
Just p -> case unpickleElem xpQueryItems p of Just p -> case unpickleElem xpQueryItems p of
Left e -> Left $ DiscoXMLError p e Left e -> Left $ DiscoXmlError p e
Right r -> Right r Right r -> Right r
where where
queryBody = pickleElem xpQueryItems (node, []) queryBody = pickleElem xpQueryItems (node, [])

2
source/Text/XML/Stream/Elements.hs → source/Text/Xml/Stream/Elements.hs

@ -1,7 +1,7 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Text.XML.Stream.Elements where module Text.Xml.Stream.Elements where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception import Control.Exception
Loading…
Cancel
Save