~singpolyma/network-protocol-xmpp

e5a8ce049a1914fe1eb2f32c0f06c10f046fdcf7 — John Millikin 13 years ago ee22478
Rename 'Context' to 'Session'.
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +3 -3
@@ 60,9 60,9 @@ module Network.Protocol.XMPP
	, getStanza
	, bindJID
	
	-- ** Context hook
	, Context
	, getContext
	-- ** Resuming sessions
	, Session
	, getSession
	, runXMPP
	) where
import Network.Protocol.XMPP.Client

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +5 -5
@@ 55,7 55,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
	utf8 = TE.encodeUtf8 . T.concat . TL.toChunks
	
	xmpp = do
		ctx <- M.getContext
		ctx <- M.getSession
		res <- liftIO $ Exc.try $ SASL.runSASL $ do
			suggested <- SASL.clientSuggestMechanism mechanisms
			case suggested of


@@ 89,7 89,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			Right x -> return x
			Left err -> saslError $ TL.pack $ show err

saslLoop :: M.Context -> SASL.Session Result
saslLoop :: M.Session -> SASL.Session Result
saslLoop ctx = do
	elemt <- getElement ctx
	let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing


@@ 103,21 103,21 @@ saslLoop ctx = do
		SASL.Complete -> saslFinish ctx
		SASL.NeedsMore -> saslLoop ctx

saslFinish :: M.Context -> SASL.Session Result
saslFinish :: M.Session -> SASL.Session Result
saslFinish ctx = do
	elemt <- getElement ctx
	let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing
	let success = X.isNamed name elemt
	return $ if null success then Failure else Success

putElement :: M.Context -> X.Element -> SASL.Session ()
putElement :: M.Session -> X.Element -> SASL.Session ()
putElement ctx elemt = liftIO $ do
	res <- M.runXMPP ctx $ M.putElement elemt
	case res of
		Left err -> Exc.throwIO $ XmppError err
		Right x -> return x

getElement :: M.Context -> SASL.Session X.Element
getElement :: M.Session -> SASL.Session X.Element
getElement ctx = liftIO $ do
	res <- M.runXMPP ctx M.getElement
	case res of

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +15 -15
@@ 18,13 18,13 @@
module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)
	, Context (..)
	, Session (..)
	, runXMPP
	, startXMPP
	, restartXMPP
	
	, getHandle
	, getContext
	, getSession
	
	, readEvents
	, getElement


@@ 73,9 73,9 @@ data Error
	| NoComponentStreamID
	deriving (Show)

data Context = Context H.Handle Text SAX.Parser
data Session = Session H.Handle Text SAX.Parser

newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Context IO) a }
newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a }

instance Functor XMPP where
	fmap f = XMPP . fmap f . unXMPP


@@ 99,27 99,27 @@ instance A.Applicative XMPP where
instance MonadFix XMPP where
	mfix f = XMPP $ mfix $ unXMPP . f

runXMPP :: Context -> XMPP a -> IO (Either Error a)
runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx
runXMPP :: Session -> XMPP a -> IO (Either Error a)
runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s

startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
	sax <- SAX.newParser
	runXMPP (Context h ns sax) xmpp
	runXMPP (Session h ns sax) xmpp

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Context oldH ns _ <- getContext
	Session oldH ns _ <- getSession
	sax <- liftIO SAX.newParser
	let ctx = Context (maybe oldH id newH) ns sax
	XMPP $ R.local (const ctx) (unXMPP xmpp)
	let s = Session (maybe oldH id newH) ns sax
	XMPP $ R.local (const s) (unXMPP xmpp)

getContext :: XMPP Context
getContext = XMPP R.ask
getSession :: XMPP Session
getSession = XMPP R.ask

getHandle :: XMPP H.Handle
getHandle = do
	Context h _ _ <- getContext
	Session h _ _ <- getSession
	return h

liftTLS :: ErrorT Text IO a -> XMPP a


@@ 143,7 143,7 @@ putStanza = putElement . S.stanzaToElement
readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
readEvents done = xmpp where
	xmpp = do
		Context h _ p <- getContext
		Session h _ p <- getSession
		let nextEvents = do
			-- TODO: read in larger increments
			bytes <- liftTLS $ H.hGetBytes h 1


@@ 172,7 172,7 @@ getElement = xmpp where
getStanza :: XMPP S.ReceivedStanza
getStanza = do
	elemt <- getElement
	Context _ ns _ <- getContext
	Session _ ns _ <- getSession
	case S.elementToStanza ns elemt of
		Just x -> return x
		Nothing -> E.throwError $ InvalidStanza elemt