{- 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/>.
-}moduleNetwork.Protocol.XMPP.Stream(Stream(streamLanguage,streamVersion,streamFeatures),StreamFeature(FeatureStartTLS,FeatureSASL,FeatureRegister,FeatureBind,FeatureSession),beginStream,restartStream,getTree,putTree)whereimportqualifiedSystem.IOasIOimportData.AssocList(lookupDef)importData.Char(toUpper)-- XML ParsingimportText.XML.HXT.Arrow((>>>))importqualifiedText.XML.HXT.ArrowasAimportqualifiedText.XML.HXT.DOM.InterfaceasDOMimportqualifiedText.XML.HXT.DOM.XmlNodeasXNimportqualifiedText.XML.LibXML.SAXasSAX-- TLS supportimportqualifiedNetwork.GnuTLSasGnuTLSimportForeign(allocaBytes)importForeign.C(peekCAStringLen)importNetwork.Protocol.XMPP.JID(JID,jidFormat)importqualifiedNetwork.Protocol.XMPP.UtilasUtilmaxXMPPVersion::XMPPVersionmaxXMPPVersion=XMPPVersion10dataStream=Stream{streamHandle::Handle,streamJID::JID,streamParser::SAX.Parser,streamLanguage::XMLLanguage,streamVersion::XMPPVersion,streamFeatures::[StreamFeature]}dataStreamFeature=FeatureStartTLSBool|FeatureSASL[String]|FeatureRegister|FeatureBind|FeatureSession|FeatureUnknownDOM.XmlTreederiving(Show,Eq)newtypeXMLLanguage=XMLLanguageStringderiving(Show,Eq)dataXMPPVersion=XMPPVersionIntIntderiving(Show,Eq)dataHandle=PlainHandleIO.Handle|SecureHandleIO.Handle(GnuTLS.SessionGnuTLS.Client)------------------------------------------------------------------------------restartStream::Stream->IOStreamrestartStreams=beginStream'(streamJIDs)(streamHandles)beginStream::JID->IO.Handle->IOStreambeginStreamjidrawHandle=doIO.hSetBufferingrawHandleIO.NoBufferingplainStream<-beginStream'jid(PlainHandlerawHandle)putTreeplainStream$Util.mkElement("","starttls")[("","xmlns","urn:ietf:params:xml:ns:xmpp-tls")][]getTreeplainStreamsession<-GnuTLS.tlsClient[GnuTLS.handleGnuTLS.:=rawHandle,GnuTLS.prioritiesGnuTLS.:=[GnuTLS.CrtX509],GnuTLS.credentialsGnuTLS.:=GnuTLS.certificateCredentials]GnuTLS.handshakesessionbeginStream'jid(SecureHandlerawHandlesession)beginStream'::JID->Handle->IOStreambeginStream'jidh=do-- Since only the opening tag should be written, normal XML-- serialization cannot be used. Be careful to escape any embedded-- attributes.letxmlHeader="<?xml version='1.0'?>\n"++"<stream:stream xmlns='jabber:client'"++" to='"++(DOM.attrEscapeXml.jidFormat)jid++"'"++" version='1.0'"++" xmlns:stream='http://etherx.jabber.org/streams'>"parser<-SAX.mkParserhPutStrhxmlHeaderinitialEvents<-readEventsUntilstartOfStreamhparserfeatureTree<-getTree'hparserletstartStreamEvent=lastinitialEventslet(language,version)=parseStartStreamstartStreamEventletfeatures=parseFeaturesfeatureTreereturn$StreamhjidparserlanguageversionfeatureswherestreamName=Util.mkQName"http://etherx.jabber.org/streams""stream"startOfStreamdepthevent=case(depth,event)of(1,(SAX.BeginElementelemName_))->streamName==Util.convertQNameelemName_->FalseparseStartStream::SAX.Event->(XMLLanguage,XMPPVersion)parseStartStreame=(XMLLanguage"en",XMPPVersion10)-- TODOparseFeatures::DOM.XmlTree->[StreamFeature]parseFeaturest=A.runLA(A.getChildren>>>A.hasQNamefeaturesName>>>A.getChildren>>>A.arrL(\t'->[parseFeaturet']))twherefeaturesName=Util.mkQName"http://etherx.jabber.org/streams""features"parseFeature::DOM.XmlTree->StreamFeatureparseFeaturet=lookupDefFeatureUnknownqname[(("urn:ietf:params:xml:ns:xmpp-tls","starttls"),parseFeatureTLS),(("urn:ietf:params:xml:ns:xmpp-sasl","mechanisms"),parseFeatureSASL),(("http://jabber.org/features/iq-register","register"),(\_->FeatureRegister)),(("urn:ietf:params:xml:ns:xmpp-bind","bind"),(\_->FeatureBind)),(("urn:ietf:params:xml:ns:xmpp-session","session"),(\_->FeatureSession))]twhereqname=maybe("","")(\n->(DOM.namespaceUrin,DOM.localPartn))(XN.getNamet)parseFeatureTLS::DOM.XmlTree->StreamFeatureparseFeatureTLSt=FeatureStartTLSTrue-- TODO: detect whether or not requiredparseFeatureSASL::DOM.XmlTree->StreamFeatureparseFeatureSASLt=letmechName=Util.mkQName"urn:ietf:params:xml:ns:xmpp-sasl""mechanism"mechanisms=A.runLA(A.getChildren>>>A.hasQNamemechName>>>A.getChildren>>>A.getText)tinFeatureSASL$map(maptoUpper)mechanisms-------------------------------------------------------------------------------getTree::Stream->IODOM.XmlTreegetTrees=getTree'(streamHandles)(streamParsers)getTree'::Handle->SAX.Parser->IODOM.XmlTreegetTree'hp=doevents<-readEventsUntilfinishedhpreturn$Util.eventsToTreeeventswherefinished0(SAX.EndElement_)=Truefinished__=FalseputTree::Stream->DOM.XmlTree->IO()putTreest=doletroot=XN.mkRoot[][t]leth=streamHandles[text]<-A.runX(A.constAroot>>>A.writeDocumentToString[(A.a_no_xml_pi,"1")])hPutStrhtext-------------------------------------------------------------------------------readEventsUntil::(Int->SAX.Event->Bool)->Handle->SAX.Parser->IO[SAX.Event]readEventsUntildonehparser=readEventsUntil'done0[]$dochar<-hGetCharhSAX.parseparser[char]FalsereadEventsUntil'::(Int->SAX.Event->Bool)->Int->[SAX.Event]->IO[SAX.Event]->IO[SAX.Event]readEventsUntil'donedepthaccumgetEvents=doevents<-getEventslet(done',depth',accum')=readEventsStepdoneeventsdepthaccumifdone'thenreturnaccum'elsereadEventsUntil'donedepth'accum'getEventsreadEventsStep::(Int->SAX.Event->Bool)->[SAX.Event]->Int->[SAX.Event]->(Bool,Int,[SAX.Event])readEventsStep_[]depthaccum=(False,depth,accum)readEventsStepdone(e:es)depthaccum=letdepth'=depth+caseeof(SAX.BeginElement__)->1(SAX.EndElement_)->(-1)_->0accum'=accum++[e]inifdonedepth'ethen(True,depth',accum')elsereadEventsStepdoneesdepth'accum'-------------------------------------------------------------------------------hPutStr::Handle->String->IO()hPutStr(PlainHandleh)=IO.hPutStrhhPutStr(SecureHandle_session)=GnuTLS.tlsSendStringsessionhGetChar::Handle->IOCharhGetChar(PlainHandleh)=IO.hGetCharhhGetChar(SecureHandlehsession)=allocaBytes1$\ptr->dopending<-GnuTLS.tlsCheckPendingsessionifpending==0thendoIO.hWaitForInputh(-1)return()elsereturn()len<-GnuTLS.tlsRecvsessionptr1[char]<-peekCAStringLen(ptr,len)returnchar