M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +185 -89
@@ 1,109 1,205 @@
-{- Copyright (C) 2009 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.Client (
- ConnectedClient
- ,Client
- ,clientConnect
- ,clientAuthenticate
- ,clientBind
- ,clientJID
- ,clientServerJID
- ,putTree
- ,getTree
- ,putStanza
- ) where
+-- 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.Client
+ ( Client
+ , Server (..)
+ , connectClient
+ , bindClient
+ ) where
import Network (HostName, PortID, 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 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 Network.Protocol.XMPP.JID (JID, jidParse, jidResource)
-import qualified Network.Protocol.XMPP.SASL as SASL
+import qualified Network.Protocol.XMPP.Internal.Authentication as A
+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.Util (mkElement, mkQName)
-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)
-import Network.Protocol.XMPP.Connection
+import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
+ , element, qname
+ , readEventsUntil, convertQName
+ )
+import qualified Network.Protocol.XMPP.JID as J
+import Network.Protocol.XMPP.Stanza
-data ConnectedClient = ConnectedClient JID S.Stream
+data Server = Server
+ { serverJID :: J.JID
+ , serverHostname :: HostName
+ , serverPort :: PortID
+ }
-data Client = Client {
- clientJID :: JID
- ,clientServerJID :: JID
- ,clientStream :: S.Stream
+data Client = Client
+ { clientJID :: J.JID
+ , clientServer :: Server
+ , clientStream :: ClientStream
}
-type Username = String
-type Password = String
-
-clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient
-clientConnect jid host port = do
- handle <- connectTo host port
- stream <- S.beginStream jid "jabber:client" handle
- return $ ConnectedClient jid stream
-
-clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client
-clientAuthenticate (ConnectedClient serverJID stream) jid username password = do
- authed <- SASL.authenticate stream jid serverJID username password
- case authed of
- SASL.Failure -> error "Authentication failure"
- _ -> do
- newStream <- S.restartStream stream
- return $ Client jid serverJID newStream
-
-clientBind :: Client -> IO JID
-clientBind c = do
- -- Bind
- let resourceElements = case jidResource . clientJID $ c of
- "" -> []
- resource ->
- [mkElement ("", "resource")
- []
- [XN.mkText resource]]
+data ClientStream = ClientStream
+ { streamJID :: J.JID
+ , streamHandle :: H.Handle
+ , streamFeatures :: [F.Feature]
+ , streamParser :: SAX.Parser
+ }
+
+instance S.Stream Client where
+ getTree = S.getTree . clientStream
+ putTree = S.putTree . clientStream
+
+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 server jid username password = do
+ -- Open a TCP connection
+ let Server sjid host port = server
+ rawHandle <- connectTo host port
+ IO.hSetBuffering rawHandle IO.NoBuffering
+ let handle = H.PlainHandle rawHandle
- putTree c $ mkElement ("", "iq")
- [("", "type", "set")]
- [mkElement ("", "bind")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
- resourceElements]
+ -- Open the initial stream and authenticate
+ stream <- beginClientStream server handle
+ authedStream <- authenticate stream jid sjid username password
+ return $ Client jid server authedStream
+
+authenticate :: ClientStream -> J.JID -> J.JID -> T.Text -> T.Text -> IO ClientStream
+authenticate stream jid sjid username password = do
+ let mechanisms = authenticationMechanisms stream
+ result <- A.authenticate stream mechanisms jid sjid username password
+ case result of
+ -- TODO: throwIO some exception type?
+ A.Failure -> error "Authentication failure"
+ _ -> restartStream stream
+
+authenticationMechanisms :: ClientStream -> [T.Text]
+authenticationMechanisms = step . streamFeatures where
+ step [] = []
+ step (f:fs) = case f of
+ (F.FeatureSASL ms) -> ms
+ _ -> step fs
+
+-- TODO: does it make sense to put this in 'connect'?
+-- Can multiple resources be bound to one client?
+bindClient :: Client -> IO J.JID
+bindClient c = do
+ -- Bind
+ S.putStanza c $ bindStanza . J.jidResource . clientJID $ c
+ bindResult <- S.getStanza c
- bindResult <- getTree c
- let [rawJID] = A.runLA (
- A.deep (A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
+ let jidArrow =
+ A.deep (A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-bind" "jid"))
>>> A.getChildren
- >>> A.getText) bindResult
- let jid = case jidParse rawJID of
- Just x -> x
- _ -> error "Couldn't parse server's returned JID"
+ >>> A.getText
+
+ -- TODO: throwIO with exception
+ let Just jid = do
+ result <- bindResult
+ iq <- case result of
+ ReceivedIQ x -> Just x
+ _ -> Nothing
+
+ case A.runLA jidArrow (iqPayload iq) of
+ [] -> Nothing
+ (str:_) -> J.parseJID (T.pack str)
-- Session
- putTree c $ mkElement ("", "iq")
- [("", "type", "set")]
- [mkElement ("", "session")
- [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]
- []]
+ S.putStanza c sessionStanza
+ S.getStanza c
- getTree c
+ S.putStanza c $ emptyPresence PresenceAvailable
+ S.getStanza c
- putTree c $ mkElement ("", "presence") [] []
- getTree c
return jid
-instance Connection Client where
- getTree = S.getTree . clientStream
- putTree = S.putTree . clientStream
+bindStanza :: Maybe J.Resource -> IQ
+bindStanza resource = emptyIQ IQSet payload where
+ payload = element ("", "bind")
+ [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]
+ requested
+ requested = case fmap J.strResource resource of
+ Nothing -> []
+ Just x -> [element ("", "resource")
+ []
+ [XN.mkText (T.unpack x)]]
+
+sessionStanza :: IQ
+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
+ plain <- newStream jid handle
+ if streamSupportsTLS plain
+ then do
+ S.putTree plain xmlStartTLS
+ S.getTree plain -- TODO: verify
+ H.startTLS handle >>= newStream jid
+ else return plain
+
+restartStream :: ClientStream -> IO ClientStream
+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
+ features <- F.parseFeatures `fmap` getTree h parser
+
+ return $ ClientStream jid h features parser
+
+streamSupportsTLS :: ClientStream -> Bool
+streamSupportsTLS = any isStartTLS . streamFeatures where
+ isStartTLS (F.FeatureStartTLS _) = True
+ isStartTLS _ = False
+
+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"
D Network/Protocol/XMPP/Connection.hs => Network/Protocol/XMPP/Connection.hs +0 -38
@@ 1,38 0,0 @@
-{- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
- 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/>.
--}
-
-module Network.Protocol.XMPP.Connection
- ( Connection
- , getTree
- , putTree
- , putStanza
- ) where
-
-import Text.XML.HXT.DOM.TypeDefs (XmlTree)
-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)
-
--- |Provides the basic operations for XMPP connections.
-class Connection c where
- -- |Receive XML
- getTree :: c -> IO XmlTree
-
- -- |Send XML
- putTree :: c -> XmlTree -> IO ()
-
- -- |Send a stanza, uses putTree by default
- putStanza :: c -> Stanza -> IO ()
- putStanza c = putTree c . stanzaToTree
M Network/Protocol/XMPP/Internal/Authentication.hs => Network/Protocol/XMPP/Internal/Authentication.hs +5 -5
@@ 25,7 25,7 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GSASL as G
import Network.Protocol.XMPP.JID (JID, formatJID)
-import Network.Protocol.XMPP.Internal.XML (mkElement, mkQName)
+import Network.Protocol.XMPP.Internal.XML (element, qname)
import qualified Network.Protocol.XMPP.Internal.Stream as S
data Result = Success | Failure
@@ 58,7 58,7 @@ authenticate stream mechanisms userJID serverJID username password = do
G.propertySet s G.GSASL_HOSTNAME $ T.unpack hostname
(b64text, rc) <- G.step64 s ""
- S.putTree stream $ mkElement ("", "auth")
+ S.putTree stream $ element ("", "auth")
[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")
,("", "mechanism", mechanism)]
[XN.mkText b64text]
@@ 73,13 73,13 @@ saslLoop stream session = do
challengeText <- A.runX (
A.arrIO (\_ -> S.getTree stream)
>>> A.getChildren
- >>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
+ >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")
>>> A.getChildren >>> A.getText)
if null challengeText then return Failure
else do
(b64text, rc) <- G.step64 session (concat challengeText)
- S.putTree stream $ mkElement ("", "response")
+ S.putTree stream $ element ("", "response")
[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]
[XN.mkText b64text]
case rc of
@@ 92,6 92,6 @@ saslFinish stream = do
successElem <- A.runX (
A.arrIO (\_ -> S.getTree stream)
>>> A.getChildren
- >>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
+ >>> A.hasQName (qname "urn:ietf:params:xml:ns:xmpp-sasl" "success"))
return $ if null successElem then Failure else Success
M Network/Protocol/XMPP/Internal/Stanza.hs => Network/Protocol/XMPP/Internal/Stanza.hs +32 -1
@@ 56,6 56,16 @@ data MessageType
| MessageError
deriving (Show, Eq)
+emptyMessage :: MessageType -> Message
+emptyMessage t = Message
+ { messageType = t
+ , messageTo = Nothing
+ , messageFrom = Nothing
+ , messageID = Nothing
+ , messageLang = Nothing
+ , messagePayloads = []
+ }
+
data Presence = Presence
{ presenceType :: PresenceType
, presenceTo :: Maybe JID
@@ 74,7 84,8 @@ instance Stanza Presence where
stanzaToTree = undefined
data PresenceType
- = PresenceUnavailable
+ = PresenceAvailable
+ | PresenceUnavailable
| PresenceSubscribe
| PresenceSubscribed
| PresenceUnsubscribe
@@ 83,6 94,16 @@ data PresenceType
| PresenceError
deriving (Show, Eq)
+emptyPresence :: PresenceType -> Presence
+emptyPresence t = Presence
+ { presenceType = t
+ , presenceTo = Nothing
+ , presenceFrom = Nothing
+ , presenceID = Nothing
+ , presenceLang = Nothing
+ , presencePayloads = []
+ }
+
data IQ = IQ
{ iqType :: IQType
, iqTo :: Maybe JID
@@ 107,5 128,15 @@ data IQType
| IQError
deriving (Show, Eq)
+emptyIQ :: IQType -> XmlTree -> IQ
+emptyIQ t tree = IQ
+ { iqType = t
+ , iqTo = Nothing
+ , iqFrom = Nothing
+ , iqID = Nothing
+ , iqLang = Nothing
+ , iqPayload = tree
+ }
+
treeToStanza :: XmlTree -> Maybe ReceivedStanza
treeToStanza = undefined
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +4 -0
@@ 29,5 29,9 @@ module Network.Protocol.XMPP.Stanza
, MessageType (..)
, PresenceType (..)
, IQType (..)
+
+ , emptyMessage
+ , emptyPresence
+ , emptyIQ
) where
import Network.Protocol.XMPP.Internal.Stanza
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -1
@@ 29,16 29,18 @@ library
, bytestring >= 0.9 && < 1.0
, libxml-sax >= 0.3 && < 0.4
, gsasl >= 0.2 && < 0.3
+ , network >= 2.2 && < 2.3
exposed-modules:
Network.Protocol.XMPP
- -- Network.Protocol.XMPP.Client
+ Network.Protocol.XMPP.Client
Network.Protocol.XMPP.JID
Network.Protocol.XMPP.Stanza
Network.Protocol.XMPP.Stream
other-modules:
Network.Protocol.XMPP.Internal.Authentication
+ Network.Protocol.XMPP.Internal.Features
Network.Protocol.XMPP.Internal.Handle
Network.Protocol.XMPP.Internal.Stanza
Network.Protocol.XMPP.Internal.Stream