~singpolyma/network-protocol-xmpp

82b00c68cde42b5452a94353c531f39efa1475f7 — John Millikin 12 years ago 915f7db
Cleaned up the Client module, which opens streams in the jabber:client namespace.
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