6 files changed, 229 insertions(+), 134 deletions(-)

M Network/Protocol/XMPP/Client.hs
D Network/Protocol/XMPP/Connection.hs
M Network/Protocol/XMPP/Internal/Authentication.hs
M Network/Protocol/XMPP/Internal/Stanza.hs
M Network/Protocol/XMPP/Stanza.hs
M network-protocol-xmpp.cabal

@@ 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"

@@ 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

@@ 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

@@ 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

@@ 29,5 29,9 @@ module Network.Protocol.XMPP.Stanza
 	, MessageType (..)
 	, PresenceType (..)
 	, IQType (..)
+	
+	, emptyMessage
+	, emptyPresence
+	, emptyIQ
 	) where
 import Network.Protocol.XMPP.Internal.Stanza

@@ 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