M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +9 -1
@@ 15,11 15,19 @@
module Network.Protocol.XMPP
- ( module Network.Protocol.XMPP.JID
+ ( module Network.Protocol.XMPP.Client
+ , module Network.Protocol.XMPP.Component
+ , module Network.Protocol.XMPP.JID
, module Network.Protocol.XMPP.Stanza
, module Network.Protocol.XMPP.Stream
+ , Server (..)
) where
+import Network.Protocol.XMPP.Client
+import Network.Protocol.XMPP.Component
import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Stanza
import Network.Protocol.XMPP.Stream
+
+
+import Network.Protocol.XMPP.Internal.Connections
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +18 -46
@@ 16,42 16,34 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Client
( Client
- , Server (..)
+ , clientJID
, connectClient
, bindClient
) where
-import Network (HostName, PortID, connectTo)
+import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified System.IO as IO
-import qualified Data.ByteString as B
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import qualified Text.XML.LibXML.SAX as SAX
import qualified Network.Protocol.XMPP.Internal.Authentication as A
+import qualified Network.Protocol.XMPP.Internal.Connections as C
import qualified Network.Protocol.XMPP.Internal.Features as F
import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Internal.Stream as S
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
- , element, qname
- , readEventsUntil, convertQName
- )
+ , element, qname
+ , readEventsUntil
+ )
import qualified Network.Protocol.XMPP.JID as J
import Network.Protocol.XMPP.Stanza
-data Server = Server
- { serverJID :: J.JID
- , serverHostname :: HostName
- , serverPort :: PortID
- }
-
data Client = Client
{ clientJID :: J.JID
- , clientServer :: Server
, clientStream :: ClientStream
}
@@ 70,18 62,22 @@ instance S.Stream ClientStream where
getTree s = getTree (streamHandle s) (streamParser s)
putTree s = putTree (streamHandle s)
-connectClient :: Server -> J.JID -> T.Text -> T.Text -> IO Client
+connectClient :: C.Server
+ -> J.JID -- ^ Client JID
+ -> T.Text -- ^ Username
+ -> T.Text -- ^ Password
+ -> IO Client
connectClient server jid username password = do
-- Open a TCP connection
- let Server sjid host port = server
+ let C.Server sjid host port = server
rawHandle <- connectTo host port
IO.hSetBuffering rawHandle IO.NoBuffering
let handle = H.PlainHandle rawHandle
-- Open the initial stream and authenticate
- stream <- beginClientStream server handle
+ stream <- beginStream sjid handle
authedStream <- authenticate stream jid sjid username password
- return $ Client jid server authedStream
+ return $ Client jid authedStream
authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream
authenticate stream jid sjid username password = do
@@ 148,9 144,8 @@ sessionStanza = emptyIQ IQSet $ element ("", "session")
[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
[]
-beginClientStream :: Server -> H.Handle -> IO ClientStream
-beginClientStream server handle = do
- let jid = serverJID server
+beginStream :: J.JID -> H.Handle -> IO ClientStream
+beginStream jid handle = do
plain <- newStream jid handle
if streamSupportsTLS plain
then do
@@ 164,14 159,9 @@ restartStream s = newStream (streamJID s) (streamHandle s)
newStream :: J.JID -> H.Handle -> IO ClientStream
newStream jid h = do
- let startOfStream depth event = case (depth, event) of
- (1, (SAX.BeginElement elemName _)) ->
- qnameStream == convertQName elemName
- _ -> False
-
parser <- SAX.mkParser
- H.hPutBytes h $ xmlHeader "jabber:client" jid
- readEventsUntil startOfStream h parser
+ H.hPutBytes h $ C.xmlHeader "jabber:client" jid
+ readEventsUntil C.startOfStream h parser
features <- F.parseFeatures `fmap` getTree h parser
return $ ClientStream jid h features parser
@@ 185,21 175,3 @@ xmlStartTLS :: DOM.XmlTree
xmlStartTLS = element ("", "starttls")
[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]
[]
-
--- Since only the opening tag should be written, normal XML
--- serialization cannot be used. Be careful to escape any embedded
--- attributes.
-xmlHeader :: T.Text -> J.JID -> B.ByteString
-xmlHeader ns jid = TE.encodeUtf8 header where
- escape = T.pack . DOM.attrEscapeXml . T.unpack -- TODO: optimize?
- attr x = T.concat ["\"", escape x, "\""]
- header = T.concat
- [ "<?xml version='1.0'?>\n"
- , "<stream:stream xmlns=" , attr ns
- , " to=", attr (J.formatJID jid)
- , " version=\"1.0\""
- , " xmlns:stream=\"http://etherx.jabber.org/streams\">"
- ]
-
-qnameStream :: DOM.QName
-qnameStream = qname "http://etherx.jabber.org/streams" "stream"
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +95 -60
@@ 1,77 1,112 @@
-{- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
-
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
--}
+-- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
+-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-module Network.Protocol.XMPP.Component (
- ConnectedComponent
- ,Component
- ,componentConnect
- ,componentAuthenticate
- ,componentJID
+{-# LANGUAGE OverloadedStrings #-}
+module Network.Protocol.XMPP.Component
+ ( Component
+ , componentJID
+ , componentStreamID
+ , connectComponent
) where
-import Control.Monad (when)
-import Network (HostName, PortID, connectTo)
+import Network (connectTo)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
-import Text.XML.HXT.DOM.TypeDefs (XmlTree)
+import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Digest.Pure.SHA as SHA
+import qualified System.IO as IO
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Text.XML.LibXML.SAX as SAX
-import Network.Protocol.XMPP.JID (JID, jidParse, jidResource)
-import qualified Network.Protocol.XMPP.SASL as SASL
+import qualified Network.Protocol.XMPP.Internal.Connections as C
+import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
-import Network.Protocol.XMPP.Util (mkElement, mkQName)
-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)
-import Network.Protocol.XMPP.Connection
-import qualified Data.ByteString.Lazy.Char8 as B (pack)
-
-data ConnectedComponent = ConnectedComponent JID S.Stream
+import qualified Network.Protocol.XMPP.Internal.Stream as S
+import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
+ , element, qname
+ , readEventsUntil
+ )
+import Network.Protocol.XMPP.JID (JID)
-data Component = Component {
- componentJID :: JID
- ,componentStream :: S.Stream
+data Component = Component
+ { componentJID :: JID
+ , componentHandle :: H.Handle
+ , componentParser :: SAX.Parser
+ , componentStreamID :: T.Text
}
-type Password = String
-
-componentConnect :: JID -> HostName -> PortID -> IO ConnectedComponent
-componentConnect jid host port = do
- handle <- connectTo host port
- stream <- S.beginStream jid "jabber:component:accept" handle
- return $ ConnectedComponent jid stream
-
-componentAuthenticate :: ConnectedComponent -> Password -> IO Component
-componentAuthenticate (ConnectedComponent jid stream) password
- = do let c = Component jid stream
+instance S.Stream Component where
+ getTree s = getTree (componentHandle s) (componentParser s)
+ putTree s = putTree (componentHandle s)
- let S.XMPPStreamID sid = S.streamID stream
- hash = SHA.showDigest . SHA.sha1 . B.pack $ sid ++ password
- putTree c $ mkElement ("", "handshake") [] [XN.mkText hash]
+connectComponent :: C.Server
+ -> T.Text -- ^ Password
+ -> IO Component
+connectComponent server password = do
+ let C.Server jid host port = server
+ rawHandle <- connectTo host port
+ IO.hSetBuffering rawHandle IO.NoBuffering
+ let handle = H.PlainHandle rawHandle
+
+ stream <- beginStream jid handle
+ authenticate stream password
+ return stream
- result <- getTree c
- when (A.runLA (A.getChildren
- >>> A.hasQName (mkQName "jabber:component:accept" "handshake")
- ) result == []) $
- error "Component handshake failed"
+beginStream :: JID -> H.Handle -> IO Component
+beginStream jid h = do
+ parser <- SAX.mkParser
+ H.hPutBytes h $ C.xmlHeader "jabber:component:accept" jid
+ events <- readEventsUntil C.startOfStream h parser
+ let streamID' = case parseStreamID $ last events of
+ Nothing -> error "No component stream ID defined"
+ Just x -> x
+ return $ Component jid h parser streamID'
- return c
+parseStreamID :: SAX.Event -> Maybe T.Text
+parseStreamID (SAX.BeginElement _ attrs) = sid where
+ sid = case idAttrs of
+ (x:_) -> Just . T.pack . SAX.attributeValue $ x
+ _ -> Nothing
+ idAttrs = filter (matchingName . SAX.attributeName) attrs
+ matchingName n = and
+ [ SAX.qnameNamespace n == "jabber:component:accept"
+ , SAX.qnameLocalName n == "id"
+ ]
+parseStreamID _ = Nothing
--------------------------------------------------------------------------------
+authenticate :: Component -> T.Text -> IO ()
+authenticate stream password = do
+ let bytes = buildSecret (componentStreamID stream) password
+ let digest = SHA.showDigest $ SHA.sha1 $ BL.fromChunks [bytes]
+ S.putTree stream $ element ("", "handshake") [] [XN.mkText digest]
+ result <- S.getTree stream
+ let accepted = A.runLA $
+ A.getChildren
+ >>> A.hasQName (qname "jabber:component:accept" "handshake")
+ if null (accepted result)
+ then error "Component handshake failed" -- TODO: throwIO
+ else return ()
-instance Connection Component where
- getTree = S.getTree . componentStream
- putTree = S.putTree . componentStream
+buildSecret :: T.Text -> T.Text -> B.ByteString
+buildSecret sid password = bytes where
+ bytes = TE.encodeUtf8 $ T.pack escaped
+ escaped = DOM.attrEscapeXml $ sid' ++ password'
+ sid' = T.unpack sid
+ password' = T.unpack password
A Network/Protocol/XMPP/Internal/Connections.hs => Network/Protocol/XMPP/Internal/Connections.hs +61 -0
@@ 0,0 1,61 @@
+-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE OverloadedStrings #-}
+module Network.Protocol.XMPP.Internal.Connections
+ ( Server (..)
+ , xmlHeader
+ , startOfStream
+ , qnameStream
+ ) where
+import Network (HostName, PortID)
+import Data.ByteString (ByteString)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Text.XML.HXT.DOM.Interface as DOM
+import qualified Text.XML.LibXML.SAX as SAX
+
+import Network.Protocol.XMPP.JID (JID, formatJID)
+import Network.Protocol.XMPP.Internal.XML (qname, convertQName)
+
+data Server = Server
+ { serverJID :: JID
+ , serverHostname :: HostName
+ , serverPort :: PortID
+ }
+
+-- Since only the opening tag should be written, normal XML
+-- serialization cannot be used. Be careful to escape any embedded
+-- attributes.
+xmlHeader :: T.Text -> JID -> ByteString
+xmlHeader ns jid = encodeUtf8 header where
+ escape = T.pack . DOM.attrEscapeXml . T.unpack -- TODO: optimize?
+ attr x = T.concat ["\"", escape x, "\""]
+ header = T.concat
+ [ "<?xml version='1.0'?>\n"
+ , "<stream:stream xmlns=" , attr ns
+ , " to=", attr (formatJID jid)
+ , " version=\"1.0\""
+ , " xmlns:stream=\"http://etherx.jabber.org/streams\">"
+ ]
+
+startOfStream :: Int -> SAX.Event -> Bool
+startOfStream depth event = case (depth, event) of
+ (1, (SAX.BeginElement elemName _)) ->
+ qnameStream == convertQName elemName
+ _ -> False
+
+qnameStream :: DOM.QName
+qnameStream = qname "http://etherx.jabber.org/streams" "stream"
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -0
@@ 30,16 30,19 @@ library
, libxml-sax >= 0.3 && < 0.4
, gsasl >= 0.2 && < 0.3
, network >= 2.2 && < 2.3
+ , SHA >= 1.4 && < 1.5
exposed-modules:
Network.Protocol.XMPP
Network.Protocol.XMPP.Client
+ Network.Protocol.XMPP.Component
Network.Protocol.XMPP.JID
Network.Protocol.XMPP.Stanza
Network.Protocol.XMPP.Stream
other-modules:
Network.Protocol.XMPP.Internal.Authentication
+ Network.Protocol.XMPP.Internal.Connections
Network.Protocol.XMPP.Internal.Features
Network.Protocol.XMPP.Internal.Handle
Network.Protocol.XMPP.Internal.Stanza