From fbf0f0b1d51638c3a4ffcb70c97b8e3294af058d Mon Sep 17 00:00:00 2001 From: John Millikin Date: Mon, 29 Mar 2010 02:35:55 +0000 Subject: [PATCH] Cleaned up the 'Component' module --- Network/Protocol/XMPP.hs | 10 +- Network/Protocol/XMPP/Client.hs | 64 ++------ Network/Protocol/XMPP/Component.hs | 155 +++++++++++------- Network/Protocol/XMPP/Internal/Connections.hs | 61 +++++++ network-protocol-xmpp.cabal | 3 + 5 files changed, 186 insertions(+), 107 deletions(-) create mode 100644 Network/Protocol/XMPP/Internal/Connections.hs diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs index a9c6b00..2982cba 100644 --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -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 diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index 32161de..70c570f 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -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 - [ "\n" - , "" - ] - -qnameStream :: DOM.QName -qnameStream = qname "http://etherx.jabber.org/streams" "stream" diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs index a358afe..046c6aa 100644 --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -1,77 +1,112 @@ -{- Copyright (C) 2010 Stephan Maka - - 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 . --} +-- Copyright (C) 2010 Stephan Maka +-- Copyright (C) 2010 John Millikin +-- +-- 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 . - -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 diff --git a/Network/Protocol/XMPP/Internal/Connections.hs b/Network/Protocol/XMPP/Internal/Connections.hs new file mode 100644 index 0000000..2df61e3 --- /dev/null +++ b/Network/Protocol/XMPP/Internal/Connections.hs @@ -0,0 +1,61 @@ +-- Copyright (C) 2010 John Millikin +-- +-- 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 . + +{-# 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 + [ "\n" + , "" + ] + +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" diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal index 0ee6864..dc078fb 100644 --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -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 -- 2.38.5