~singpolyma/network-protocol-xmpp

4a7007731a1c1a82af50e240a84f1c02645bc6de — Stephen Paul Weber 2 years ago c26195e
Fix some whitespace
M examples/echo.hs => examples/echo.hs +7 -7
@@ 58,7 58,7 @@ runEcho hostname user password = do
		, serverJID = JID Nothing (jidDomain jid) Nothing
		, serverPort = PortNumber 5222
		}
	

	-- 'runClient' and 'runComponent' open a connection to the remote server and
	-- establish an XMPP session.
	-- 


@@ 77,16 77,16 @@ runEcho hostname user password = do
		-- When running a client session, most servers require the user to
		-- "bind" their JID before sending any stanzas.
		boundJID <- bindJID jid
		

		-- Some servers will close the XMPP connection after some period
		-- of inactivity. For this example, we'll simply send a "ping" every
		-- 60 seconds
		getSession >>= liftIO . forkIO . sendPings 60
		

		-- 'XMPP' is an instance of 'MonadIO', so any IO may be performed
		-- within.
		liftIO $ putStrLn $ "Server bound our session to: " ++ show boundJID
		

		-- This is a simple loop which will echo received messages back to the
		-- sender; additionally, it prints *all* received stanzas to the console.
		forever $ do


@@ 100,7 100,7 @@ runEcho hostname user password = do
					then putStanza (subscribe msg)
					else return ()
				_ -> return ()
	

	-- If 'runClient' terminated due to an XMPP error, propagate it as an exception.
	-- In non-example code, you might want to show this error to the user.
	case res of


@@ 113,12 113,12 @@ echo :: Message -> Message
echo msg = Message
	{ messageType = MessageNormal
	, messageTo = messageFrom msg
	

	-- Note: Conforming XMPP servers populate the "from" attribute on
	-- stanzas, to prevent clients from spoofing it. Therefore, the
	-- 'messageFrom' field's value is irrelevant when sending stanzas.
	, messageFrom = Nothing
	

	, messageID = Nothing
	, messageLang = Nothing
	, messagePayloads = messagePayloads msg

M lib/Network/Protocol/XMPP.hs => lib/Network/Protocol/XMPP.hs +8 -8
@@ 14,20 14,20 @@
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP
	( 
	(
	-- * JIDs
	  JID (..)
	, Node
	, Domain
	, Resource
	

	, strNode
	, strDomain
	, strResource
	

	, parseJID
	, formatJID
	

	-- * Stanzas
	, Stanza
		( stanzaTo


@@ 36,7 36,7 @@ module Network.Protocol.XMPP
		, stanzaLang
		, stanzaPayloads
		)
	

	, ReceivedStanza (..)
	, Message (..)
	, Presence (..)


@@ 44,11 44,11 @@ module Network.Protocol.XMPP
	, MessageType (..)
	, PresenceType (..)
	, IQType (..)
	

	, emptyMessage
	, emptyPresence
	, emptyIQ
	

	-- * The XMPP monad
	, XMPP
	, Server (..)


@@ 58,7 58,7 @@ module Network.Protocol.XMPP
	, putStanza
	, getStanza
	, bindJID
	

	-- ** Resuming sessions
	, Session
	, getSession

M lib/Network/Protocol/XMPP/Client.hs => lib/Network/Protocol/XMPP/Client.hs +7 -7
@@ 50,7 50,7 @@ runClient server jid username password xmpp = do
	rawHandle <- connectTo host port
	IO.hSetBuffering rawHandle IO.NoBuffering
	let handle = H.PlainHandle rawHandle
	

	-- Open the initial stream and authenticate
	M.startXMPP handle "jabber:client" $ do
		features <- newStream sjid


@@ 100,28 100,28 @@ bindJID jid = do
		>=> X.elementNodes
		>=> X.isContent
		>=> return . X.contentText
	

	let maybeJID = do
		iq <- case bindResult of
			ReceivedIQ x -> Just x
			_ -> Nothing
		payload <- iqPayload iq
		

		case getJID payload of
			[] -> Nothing
			(str:_) -> J.parseJID str
	

	returnedJID <- case maybeJID of
		Just x -> return x
		Nothing -> throwError (M.InvalidBindResult bindResult)
	

	-- Session
	M.putStanza sessionStanza
	void M.getStanza
	

	M.putStanza (emptyPresence PresenceAvailable)
	void M.getStanza
	

	return returnedJID

bindStanza :: Maybe J.Resource -> IQ

M lib/Network/Protocol/XMPP/Client/Authentication.hs => lib/Network/Protocol/XMPP/Client/Authentication.hs +8 -8
@@ 53,7 53,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
	mechanisms = map SASL.Mechanism xmppMechanisms
	authz = formatJID (userJID { jidResource = Nothing })
	hostname = formatJID serverJID
	

	xmpp = do
		ctx <- M.getSession
		res <- liftIO . Exc.try . SASL.runSASL $ do


@@ 66,7 66,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			Right (Failure e) -> E.throwError (M.AuthenticationFailure e)
			Left (XmppError err) -> E.throwError err
			Left (SaslError err) -> E.throwError (M.AuthenticationError err)
	

	authSasl ctx mechanism = do
		let (SASL.Mechanism mechBytes) = mechanism
		sessionResult <- SASL.runClient mechanism $ do


@@ 75,16 75,16 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			SASL.setProperty SASL.PropertyPassword (encodeUtf8 password)
			SASL.setProperty SASL.PropertyService "xmpp"
			SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname)
			

			(b64text, rc) <- SASL.step64 ""
			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
				[("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))]
				[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
			

			case rc of
				SASL.Complete -> saslFinish ctx
				SASL.NeedsMore -> saslLoop ctx
			

		case sessionResult of
			Right x -> return x
			Left err -> saslError (show err)


@@ 106,7 106,7 @@ saslLoop ctx = do
			case rc of
				SASL.Complete -> saslFinish ctx
				SASL.NeedsMore -> saslLoop ctx
		

		-- The server has authenticated this client, but the client-side
		-- SASL protocol wants more data from the server.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}success" -> do


@@ 115,10 115,10 @@ saslLoop ctx = do
			case rc of
				SASL.Complete -> return Success
				SASL.NeedsMore -> saslError "Server didn't provide enough SASL data."
		

		-- The server has rejected this client's credentials.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)
		

		_ -> saslError ("Server sent unexpected element during authentication.")

saslFinish :: M.Session -> SASL.Session Result

M lib/Network/Protocol/XMPP/JID.hs => lib/Network/Protocol/XMPP/JID.hs +1 -1
@@ 21,7 21,7 @@ module Network.Protocol.XMPP.JID
	, Node (..)
	, Domain (..)
	, Resource (..)
	

	, parseJID
	, parseJID_
	, formatJID

M lib/Network/Protocol/XMPP/Monad.hs => lib/Network/Protocol/XMPP/Monad.hs +9 -9
@@ 23,15 23,15 @@ module Network.Protocol.XMPP.Monad
	, runXMPP
	, startXMPP
	, restartXMPP
	

	, getHandle
	, getSession
	, sessionIsSecure
	

	, readEvents
	, getElement
	, getStanza
	

	, putBytes
	, putElement
	, putStanza


@@ 62,20 62,20 @@ data Error
	-- provided. It may contain additional information about why
	-- authentication failed.
	= AuthenticationFailure X.Element
	

	-- | There was an error while authenticating with the remote host.
	| AuthenticationError Text
	

	-- | An unrecognized or malformed 'S.Stanza' was received from the remote
	-- host.
	| InvalidStanza X.Element
	

	-- | The remote host sent an invalid reply to a resource bind request.
	| InvalidBindResult S.ReceivedStanza
	

	-- | There was an error with the underlying transport.
	| TransportError Text
	

	-- | The remote host did not send a stream ID when accepting a component
	-- connection.
	| NoComponentStreamID


@@ 189,7 189,7 @@ getElement = xmpp where
		case X.eventsToElement events of
			Just x -> return x
			Nothing -> E.throwError (TransportError "getElement: invalid event list")
	

	endOfTree 0 (X.EventEndElement _) = True
	endOfTree _ _ = False


M lib/Network/Protocol/XMPP/Stanza.hs => lib/Network/Protocol/XMPP/Stanza.hs +6 -6
@@ 17,7 17,7 @@

module Network.Protocol.XMPP.Stanza
	( Stanza (..)
	

	, ReceivedStanza (..)
	, Message (..)
	, Presence (..)


@@ 25,11 25,11 @@ module Network.Protocol.XMPP.Stanza
	, MessageType (..)
	, PresenceType (..)
	, IQType (..)
	

	, emptyMessage
	, emptyPresence
	, emptyIQ
	

	, elementToStanza
	) where



@@ 204,7 204,7 @@ elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza
elementToStanza ns elemt = do
	let elemNS = X.nameNamespace (X.elementName elemt)
	when (elemNS /= Just ns) Nothing
	

	let elemName = X.nameLocalName (X.elementName elemt)
	case elemName of
		"message" -> ReceivedMessage `fmap` parseMessage elemt


@@ 241,7 241,7 @@ parsePresence elemt = do
		"probe"        -> Just PresenceProbe
		"error"        -> Just PresenceError
		_              -> Nothing
		

	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" elemt
	let msgID = X.attributeText "id" elemt


@@ 258,7 258,7 @@ parseIQ elemt = do
		"result" -> Just IQResult
		"error"  -> Just IQError
		_        -> Nothing
	

	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" elemt
	let msgID = X.attributeText "id" elemt

M lib/Network/Protocol/XMPP/XML.hs => lib/Network/Protocol/XMPP/XML.hs +11 -11
@@ 17,22 17,22 @@

module Network.Protocol.XMPP.XML
	( module Data.XML.Types
	

	-- * Constructors
	, element
	

	-- * Misc
	, contentText
	, escape
	, serialiseElement
	, readEvents
	

	-- * libxml-sax-0.4 API imitation
	, Parser
	, newParser
	, parse
	, eventsToElement
	

	) where

import           Control.Monad (when)


@@ 82,7 82,7 @@ serialiseElement e = text where
		Nothing -> []
		Just ns -> [mkattr "xmlns" ns]
	contents = Data.Text.concat (map serialiseNode (elementNodes e))
	

	serialiseNode (NodeElement e') = serialiseElement e'
	serialiseNode (NodeContent c) = escape (contentText c)
	serialiseNode (NodeComment _) = ""


@@ 96,21 96,21 @@ newParser :: IO Parser
newParser = do
	ref <- newIORef (Right [])
	p <- SAX.newParserIO Nothing
	

	let addEvent e = do
		x <- readIORef ref
		case x of
			Left _ -> return ()
			Right es -> writeIORef ref (Right (e:es))
		return True
	

	SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))
	SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement)
	SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText)
	SAX.setCallback p SAX.parsedComment (addEvent . EventComment)
	SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction)
	SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False)
	

	return (Parser p ref)

parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event])


@@ 134,7 134,7 @@ readEvents done nextEvents = readEvents' 0 [] where
		if done'
			then return acc'
			else readEvents' depth' acc'
	

	step [] depth acc = (False, depth, acc)
	step (e:es) depth acc = let
		depth' = depth + case e of


@@ 162,7 162,7 @@ eventsToNodes = concatMap blockToNodes . splitBlocks
splitBlocks :: [Event] -> [[Event]]
splitBlocks es = ret where
	(_, _, ret) = foldl splitBlocks' (0, [], []) es
	

	splitBlocks' (depth, accum, allAccum) e = split where
		split = if depth' == 0
			then (depth', [], allAccum ++ [accum'])


@@ 182,5 182,5 @@ blockToNodes (begin:rest) = nodes where
		(EventBeginElement name attrs, EventEndElement _) -> [node name attrs]
		(EventContent c, _) -> [NodeContent c]
		_ -> []
	

	node n as = NodeElement (Element n as (eventsToNodes (init rest)))