{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE OverloadedStrings #-}-- Copyright (C) 2010-2011 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.Monad(XMPP(..),Error(..),Session(..),runXMPP,startXMPP,restartXMPP,getHandle,getSession,readEvents,getElement,getStanza,putBytes,putElement,putStanza)whereimportqualifiedControl.ApplicativeasAimportqualifiedControl.Concurrent.MVarasMimportControl.Monad(ap)importControl.Monad.Fix(MonadFix,mfix)importControl.Monad.Trans(MonadIO,liftIO)importqualifiedControl.Monad.ErrorasEimportqualifiedControl.Monad.ReaderasRimportqualifiedData.ByteStringimportData.ByteString(ByteString)importData.Text(Text)importData.Text.Encoding(encodeUtf8)importNetwork.Protocol.XMPP.ErrorTimportqualifiedNetwork.Protocol.XMPP.HandleasHimportqualifiedNetwork.Protocol.XMPP.StanzaasSimportqualifiedNetwork.Protocol.XMPP.XMLasXdataError-- | The remote host refused the specified authentication credentials.=AuthenticationFailure-- | There was an error while authenticating with the remote host.|AuthenticationErrorText-- | An unrecognized or malformed 'S.Stanza' was received from the remote-- host.|InvalidStanzaX.Element-- | The remote host sent an invalid reply to a resource bind request.|InvalidBindResultS.ReceivedStanza-- | There was an error with the underlying transport.|TransportErrorText-- | The remote host did not send a stream ID when accepting a component-- connection.|NoComponentStreamIDderiving(Show)dataSession=Session{sessionHandle::H.Handle,sessionNamespace::Text,sessionParser::X.Parser,sessionReadLock::M.MVar(),sessionWriteLock::M.MVar()}newtypeXMPPa=XMPP{unXMPP::ErrorTError(R.ReaderTSessionIO)a}instanceFunctorXMPPwherefmapf=XMPP.fmapf.unXMPPinstanceMonadXMPPwherereturn=XMPP.returnm>>=f=XMPP(unXMPPm>>=unXMPP.f)instanceMonadIOXMPPwhereliftIO=XMPP.liftIOinstanceE.MonadErrorXMPPwheretypeE.ErrorTypeXMPP=ErrorthrowError=XMPP.E.throwErrorcatchErrormh=XMPP(E.catchError(unXMPPm)(unXMPP.h))instanceA.ApplicativeXMPPwherepure=return(<*>)=apinstanceMonadFixXMPPwheremfixf=XMPP(mfix(unXMPP.f))runXMPP::Session->XMPPa->IO(EitherErrora)runXMPPsxmpp=R.runReaderT(runErrorT(unXMPPxmpp))sstartXMPP::H.Handle->Text->XMPPa->IO(EitherErrora)startXMPPhnsxmpp=dosax<-X.newParserreadLock<-M.newMVar()writeLock<-M.newMVar()runXMPP(SessionhnssaxreadLockwriteLock)xmpprestartXMPP::MaybeH.Handle->XMPPa->XMPParestartXMPPnewHxmpp=doSessionoldHns_readLockwriteLock<-getSessionsax<-liftIOX.newParserlets=Session(maybeoldHidnewH)nssaxreadLockwriteLockXMPP(R.local(consts)(unXMPPxmpp))withLock::(Session->M.MVar())->XMPPa->XMPPawithLockgetLockxmpp=dos<-getSessionletmvar=getLocksres<-liftIO(M.withMVarmvar(\_->runXMPPsxmpp))caseresofLefterr->E.throwErrorerrRightx->returnxgetSession::XMPPSessiongetSession=XMPPR.askgetHandle::XMPPH.HandlegetHandle=fmapsessionHandlegetSessionliftTLS::ErrorTTextIOa->XMPPaliftTLSio=dores<-liftIO(runErrorTio)caseresofLefterr->E.throwError(TransportErrorerr)Rightx->returnxputBytes::ByteString->XMPP()putBytesbytes=doh<-getHandleliftTLS(H.hPutByteshbytes)putElement::X.Element->XMPP()putElement=putBytes.encodeUtf8.X.serialiseElementputStanza::S.Stanzaa=>a->XMPP()putStanza=withLocksessionWriteLock.putElement.S.stanzaToElementreadEvents::(Integer->X.Event->Bool)->XMPP[X.Event]readEventsdone=xmppwherexmpp=doSessionh_p__<-getSessionletnextEvents=do-- TODO: read in larger incrementsbytes<-liftTLS(H.hGetBytesh1)leteof=Data.ByteString.nullbytesparsed<-liftIO(X.parsepbyteseof)caseparsedofLefterr->E.throwError(TransportErrorerr)Rightevents->returneventsX.readEventsdonenextEventsgetElement::XMPPX.ElementgetElement=xmppwherexmpp=doevents<-readEventsendOfTreecaseX.eventsToElementeventsofJustx->returnxNothing->E.throwError(TransportError"getElement: invalid event list")endOfTree0(X.EventEndElement_)=TrueendOfTree__=FalsegetStanza::XMPPS.ReceivedStanzagetStanza=withLocksessionReadLock$doelemt<-getElementSession_ns___<-getSessioncaseS.elementToStanzanselemtofJustx->returnxNothing->E.throwError(InvalidStanzaelemt)