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)))