diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,28 @@ +Copyright (c) 2007 Magnus Henoch +All rights reserved. + +Copyright (c) 2009 Kagami + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors and contributors may not be used to endorse + or promote products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Network/XMPP.hs b/Network/XMPP.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP.hs @@ -0,0 +1,71 @@ +-- |This library aims to make writing XMPP clients (in particular +-- bots) easy and fun. Here is a small example: +-- +-- > import Network +-- > import Network.XMPP +-- > +-- > -- The bot's JID is "bot@example.com" +-- > botUsername = "bot" +-- > botServer = "example.com" +-- > botPassword = "secret" +-- > botResource = "bot" +-- > +-- > main :: IO () +-- > main = withSocketsDo $ +-- > do +-- > -- Connect to server... +-- > c <- openStream botServer +-- > getStreamStart c +-- > +-- > runXMPP c $ do +-- > -- ...authenticate... +-- > startAuth botUsername botServer botPassword botResource +-- > sendpresence +-- > -- ...and do something. +-- > run +-- > +-- > run :: XMPP () +-- > run = do +-- > -- Wait for an incoming message... +-- > msg <- waitForStanza (isChat `conj` hasBody) +-- > let sender = maybe "" id (getAttr "from" msg) +-- > len = length $ maybe "" id (getMessageBody msg) +-- > -- ...answer... +-- > sendMessage sender ("Your message was "++(show len)++" characters long.") +-- > -- ...and repeat. +-- > run +-- +-- XMPP is a protocol for streaming XML also known as Jabber. It is +-- described in RFCs 3920 and 3921, and in a series of XMPP Extension +-- Protocols (XEPs). All of this can be found at +-- . +module Network.XMPP ( + -- * The XMPP monad + module Network.XMPP.XMPPMonad + -- * XML functions + , XMLElem(..) + , xmlPath + , xmlPath' + , getAttr + , getCdata + , xmlToString + -- * Stanza manipulation + , module Network.XMPP.Stanzas + -- * JID functions + , module Network.XMPP.JID + -- * Authentication + , module Network.XMPP.Auth + -- * TCP connections + , module Network.XMPP.TCPConnection + -- * Abstract connections + , module Network.XMPP.XMPPConnection + ) + where + +import Network.XMPP.Auth +import Network.XMPP.JID +import Network.XMPP.Stanzas +import Network.XMPP.TCPConnection +import Network.XMPP.XMLParse +import Network.XMPP.XMPPConnection hiding ( sendStanza ) +import Network.XMPP.XMPPMonad diff --git a/Network/XMPP/Auth.hs b/Network/XMPP/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Auth.hs @@ -0,0 +1,34 @@ +module Network.XMPP.Auth where + +import Network.XMPP.XMLParse +import Network.XMPP.XMPPMonad +import Network.XMPP.Stanzas +import Network.XMPP.MyDebug + +-- |Non-SASL authentication, following XEP-0078. +startAuth :: String -- ^Username (part before \@ in JID) + -> String -- ^Server (part after \@ in JID) + -> String -- ^Password + -> String -- ^Resource (unique identifier for this connection) + -> XMPP Integer -- ^Error number. Zero if authentication succeeded. +startAuth username server password resource = do + response <- sendIqWait server "get" [XML "query" + [("xmlns","jabber:iq:auth")] + [XML "username" + [] + [CData username]]] + case xmlPath ["query","password"] response of + Nothing -> return 1 -- plaintext authentication not supported by server + -- http://xmpp.org/extensions/attic/jep-0078-1.7.html + -- "If there is no such username, the server SHOULD NOT return an error" + -- So server can return error here, if username is wrong. + Just _ -> do + response' <- sendIqWait server "set" [XML "query" + [("xmlns","jabber:iq:auth")] + [XML "username" [] + [CData username], + XML "password" [] + [CData password], + XML "resource" [] + [CData resource]]] + return $ getErrorCode response' diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/JID.hs @@ -0,0 +1,21 @@ +module Network.XMPP.JID where + +-- |Get username part of JID, i.e. the part before the \@ sign. +-- Return @\"\"@ if the JID contains no \@ sign. +getUsername :: String -> String +getUsername jid = + case break (=='@') jid of + (username,'@':_) -> username + _ -> "" + +-- |Get resource part of JID, i.e. the part after \/. +-- Return @\"\"@ if the JID has no resource. +getResource :: String -> String +getResource jid = + case dropWhile (/='/') jid of + '/':resource -> resource + _ -> "" + +-- |Get the bare JID, i.e. everything except the resource. +getBareJid :: String -> String +getBareJid jid = takeWhile (/='/') jid diff --git a/Network/XMPP/MUC.hs b/Network/XMPP/MUC.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/MUC.hs @@ -0,0 +1,68 @@ +-- |Implementation of Multi-User Chat, according to XEP-0045. This +-- API needs more thought and will change. +module Network.XMPP.MUC where + +import Network.XMPP.XMPPMonad +import Network.XMPP.Stanzas +import Network.XMPP.XMLParse +import Network.XMPP.JID + +-- |Return true if the stanza is from a JID whose \"username\@server\" +-- part matches the given string. +matchesBare :: String -> StanzaPredicate +matchesBare bare = attributeMatches "from" ((==bare).getBareJid) + +-- |Join groupchat. +joinGroupchat :: String -- ^Nickname to use + -> String -- ^JID of room + -> String -- ^Password of room. Use empty if no. + -> XMPP Integer -- ^Error number. Zero if joining room succeeded. +joinGroupchat nick room password = do + let joinStanza' = if null password then joinStanza + else joinPassStanza + joinStanza = XML "presence" + [("to",room++"/"++nick)] + [XML "x" [("xmlns","http://jabber.org/protocol/muc")] []] + joinPassStanza = XML "presence" + [("to",room++"/"++nick)] + [XML "x" [("xmlns","http://jabber.org/protocol/muc")] + [XML "password" [] [CData password]]] + sendStanza joinStanza' + -- response <- waitForStanza $ isPresence `conj` matchesBare room + -- FIXME: this presence go to first opened runXMPP + return $ 0 --getErrorCode response + +-- |Leave groupchat. +leaveGroupchat :: String -> XMPP () +leaveGroupchat room = sendStanza $ XML "presence" + [("to",room),("type","unavailable")] [] + +-- |Return true if the stanza is a message of type \"groupchat\". +isGroupchatMessage :: StanzaPredicate +isGroupchatMessage = isMessage `conj` attributeMatches "type" (=="groupchat") + +-- |Return true if the stanza is a private message in the named room. +isGroupchatPrivmsg :: String -> StanzaPredicate +isGroupchatPrivmsg room = matchesBare room `conj` attributeMatches "type" (=="chat") + `conj` attributeMatches "from" ((/="") . getResource) + +-- |Send a groupchat message. +sendGroupchatMessage :: String -- ^JID of chat room + -> String -- ^Text of message + -> XMPP () +sendGroupchatMessage room body = + sendStanza $ XML "message" + [("to",room), + ("type","groupchat")] + [XML "body" [] [CData body]] + +-- |Send a private message in a chat room. +sendGroupchatPrivateMessage :: String -- ^Nick of recipient + -> String -- ^JID of chat room + -> String -- ^Text of message + -> XMPP () +sendGroupchatPrivateMessage nick room body = + sendStanza $ XML "message" + [("to",room++"/"++nick), + ("type","chat")] + [XML "body" [] [CData body]] diff --git a/Network/XMPP/MyDebug.hs b/Network/XMPP/MyDebug.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/MyDebug.hs @@ -0,0 +1,4 @@ +module Network.XMPP.MyDebug where + +myDebug :: String -> IO () +myDebug msg = return () diff --git a/Network/XMPP/Stanzas.hs b/Network/XMPP/Stanzas.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Stanzas.hs @@ -0,0 +1,197 @@ +module Network.XMPP.Stanzas + ( sendIq + , sendIqWait + , hasBody + , getMessageBody + , sendMessage + , sendPresence + , conj + , attributeMatches + , isMessage + , isPresence + , isIq + , isChat + , isFrom + , iqXmlns + , iqGet + , iqSet + , handleVersion + , getErrorCode + ) + where + +import Network.XMPP.XMPPMonad +import Network.XMPP.XMLParse +import System.Random +import Maybe + +--- Sending info requests and responses + +-- |Send an IQ request, returning the randomly generated ID. +sendIq :: String -- ^JID of recipient + -> String -- ^Type of IQ, either \"get\" or \"set\" + -> [XMLElem] -- ^Payload elements + -> XMPP String -- ^ID of sent stanza +sendIq to iqtype payload = + do + iqid <- liftIO $ (randomIO::IO Int) + sendStanza $ XML "iq" + [("to", to), + ("type", iqtype), + ("id", show iqid)] + payload + return $ show iqid + +-- |Send an IQ request and wait for the response, without blocking +-- other activity. +sendIqWait :: String -- ^JID of recipient + -> String -- ^Type of IQ, either \"get\" or \"set\" + -> [XMLElem] -- ^Payload elements + -> XMPP XMLElem -- ^Response stanza +sendIqWait to iqtype payload = + do + iqid <- sendIq to iqtype payload + waitForStanza $ (hasNodeName "iq") `conj` (attributeMatches "id" (==iqid)) + +-- |Send a response to a received IQ stanza. +sendIqResponse :: XMLElem -- ^Original stanza, from which id and + -- recipient are taken + -> String -- ^Type of response, either + -- \"result\" or \"error\" + -> [XMLElem] -- ^Payload elements + -> XMPP (Maybe ()) -- ^Just () if original stanza had + -- a \"from\" attribute +sendIqResponse inResponseTo iqtype payload = + case getAttr "from" inResponseTo of + Nothing -> + -- "from" attribute missing? + return Nothing + Just sender -> + let iqid = maybe "" id (getAttr "id" inResponseTo) + in do + sendStanza $ XML "iq" + [("to", sender), + ("type", iqtype), + ("id", iqid)] + payload + return $ Just () + +--- Messages + +-- |Return true if the message stanza has body text. +hasBody :: StanzaPredicate +hasBody stanza = isJust $ getMessageBody stanza + +-- |Get the body text of the message stanza, if any. +getMessageBody :: XMLElem -> Maybe String +getMessageBody stanza = + do + bodyTag <- xmlPath ["body"] stanza + getCdata bodyTag + +-- |Send an ordinary \"chat\" type message. +sendMessage :: String -- ^JID of recipient + -> String -- ^Text of message + -> XMPP () +sendMessage to body = + sendStanza $ XML "message" + [("to", to), + ("type", "chat")] + [XML "body" [] + [CData body]] + +--- Presence + +-- |Send ordinary online presence. +sendPresence :: XMPP () +sendPresence = sendStanza $ XML "presence" [] [] + +--- Stanza predicates + +-- |Conjunction (\"and\") of two predicates. +conj :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +conj a b = \x -> a x && b x + +-- |Return true if the tag has the given name. +hasNodeName :: String -> StanzaPredicate +hasNodeName name (XML name' _ _) = name == name' + +-- The three basic stanza types + +-- |Return true if the tag is a message stanza. +isMessage :: StanzaPredicate +isMessage = hasNodeName "message" + +-- |Return true if the tag is a presence stanza. +isPresence :: StanzaPredicate +isPresence = hasNodeName "presence" + +-- |Return true if the tag is an IQ stanza. +isIq :: StanzaPredicate +isIq = hasNodeName "iq" + +-- |Return true if the tag is a chat message. +isChat :: StanzaPredicate +isChat = isMessage `conj` attributeMatches "type" (=="chat") + +-- |Apply the predicate to the named attribute. Return false if the +-- tag has no such attribute. +attributeMatches :: String -- ^Attribute name + -> (String -> Bool) -- ^Attribute value predicate + -> StanzaPredicate +attributeMatches attr p (XML _ attrs _) = + maybe False p (lookup attr attrs) + +-- |Return true if the stanza is from the given JID. +isFrom :: String -> StanzaPredicate +isFrom jid = attributeMatches "from" (==jid) + +-- |Return true if the stanza is an IQ stanza in the given namespace. +iqXmlns :: String -> StanzaPredicate +iqXmlns xmlns (XML "iq" _ els) = + case listToMaybe [x | x <- els, case x of + XML _ _ _ -> True + _ -> False] of + Just x -> + attributeMatches "xmlns" (==xmlns) x + Nothing -> + False +iqXmlns _ _ = False + +-- |Return true if the stanza is a \"get\" request in the given namespace. +iqGet :: String -> StanzaPredicate +iqGet xmlns = (attributeMatches "type" (=="get")) `conj` (iqXmlns xmlns) + +-- |Return true if the stanza is a \"set\" request in the given namespace. +iqSet :: String -> StanzaPredicate +iqSet xmlns = (attributeMatches "type" (=="set")) `conj` (iqXmlns xmlns) + +--- Handlers for common requests + +-- |Establish a handler for answering to version requests with the +-- given information. See XEP-0092: Software Version. +handleVersion :: String -- ^Client name + -> String -- ^Client version + -> String -- ^Operating system + -> XMPP () +handleVersion name version os = + addHandler (iqGet "jabber:iq:version") + (\stanza -> + do + sendIqResponse stanza "result" + $ [XML "query" + [("xmlns", "jabber:iq:version")] + [XML "name" [] [CData name], + XML "version" [] [CData version], + XML "os" [] [CData os]]] + return ()) + True + +-- |Return stanza's error code or -1 (if can't parse error node). +-- Zero if no error. +getErrorCode :: XMLElem -> Integer +getErrorCode stanza = + case getAttr "type" stanza of + Just "error" -> read $ maybe "-1" id (getAttr "code" errorNode) :: Integer + _ -> 0 + where errorNode = maybe (XML [] [] []) id (xmlPath ["error"] stanza) diff --git a/Network/XMPP/TCPConnection.hs b/Network/XMPP/TCPConnection.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/TCPConnection.hs @@ -0,0 +1,79 @@ +module Network.XMPP.TCPConnection + ( TCPConnection + , openStream + , getStreamStart + ) + where + +import Network.XMPP.XMLParse +import Network.XMPP.XMPPConnection +import Network.XMPP.MyDebug + +import Network +import System.IO +import Data.IORef +import Control.Monad +import Codec.Binary.UTF8.String + +-- |An XMPP connection over TCP. +data TCPConnection = TCPConnection Handle (IORef String) + +-- |Open a TCP connection to the named server, port 5222, and send a +-- stream header. This should really check SRV records. +openStream :: String -> IO TCPConnection +openStream server = + do + h <- connectTo server (PortNumber 5222) + hSetBuffering h NoBuffering + hPutStr h $ xmlToString False $ + XML "stream:stream" + [("to",server), + ("xmlns","jabber:client"), + ("xmlns:stream","http://etherx.jabber.org/streams")] + [] + buffer <- newIORef "" + return $ TCPConnection h buffer + +-- |Get the stream header that the server sent. This needs to be +-- called before doing anything else with the stream. +getStreamStart :: TCPConnection -> IO XMLElem +getStreamStart c = + parseBuffered c xmppStreamStart + +instance XMPPConnection TCPConnection where + getStanzas c = parseBuffered c deepTags + sendStanza (TCPConnection h _) x = + let str = xmlToString True x in + do + myDebug $ "sent '" ++ str ++ "'" + hPutStr h (encodeString str) + closeConnection (TCPConnection h _) = + hClose h + +parseBuffered :: TCPConnection -> Parser a -> IO a +parseBuffered c@(TCPConnection h bufvar) parser = do + buffer <- readIORef bufvar + input' <- getString h + let input = decodeString input' + myDebug $ "got '" ++ buffer ++ input ++ "'" + case parse (getRest parser) "" (buffer++input) of + Right (result, rest) -> + do + writeIORef bufvar rest + return result + Left e -> + do + myDebug $ "An error? Hopefully doesn't matter.\n"++(show e) + parseBuffered c parser + +getString :: Handle -> IO String +getString h = + do + hWaitForInput h (-1) + getEverything + where getEverything = + do + r <- hReady h + if r + then liftM2 (:) (hGetChar h) getEverything + else return [] diff --git a/Network/XMPP/XMLParse.hs b/Network/XMPP/XMLParse.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/XMLParse.hs @@ -0,0 +1,210 @@ +-- |The difference between this XML parsers and all other XML parsers +-- is that this one can parse an XML document that is only partially +-- received, returning the parts that have arrived so far. +module Network.XMPP.XMLParse + ( XMLElem(..) + , xmlPath + , getAttr + , getCdata + , xmlToString + , attrsToString + , getRest + , xmppStreamStart + , shallowTag + , deepTag + , deepTags + , Text.ParserCombinators.Parsec.parse + , Text.ParserCombinators.Parsec.Parser + , xmlPath' + ) + where + +import Text.ParserCombinators.Parsec +import List + +-- |A data structure representing an XML element. +data XMLElem = XML String [(String,String)] [XMLElem] + -- ^Tags have a name, a list of attributes, and a list of + -- child elements. + | CData String + -- ^Character data just contains a string. + deriving (Show, Eq) + +-- |Follow a \"path\" of named subtags in an XML tree. For every +-- element in the given list, find the subtag with that name and +-- proceed recursively. +xmlPath :: [String] -> XMLElem -> Maybe XMLElem +xmlPath [] el = return el +xmlPath (name:names) (XML _ _ els) = + do + el <- find (\stanza -> + case stanza of + (XML n _ _) -> name==n + _ -> False) els + xmlPath names el + +-- |Get the value of an attribute in the given tag. +getAttr :: String -> XMLElem -> Maybe String +getAttr attr (XML _ attrs _) = lookup attr attrs + +-- |Get the character data subelement of the given tag. +getCdata :: XMLElem -> Maybe String +getCdata (XML _ _ els) = + case els of + [CData s] -> Just s + _ -> Nothing + +-- |Convert the tag back to XML. If the first parameter is true, +-- close the tag. +xmlToString :: Bool -> XMLElem -> String +xmlToString _ (CData s) = replaceToEntities s +xmlToString close (XML name attrs subels) = + "<" ++ name ++ attrsToString attrs ++ + if close then + ">" ++ (concat $ map (xmlToString True) subels) + ++ "" + else + ">" + +----------------------------------------------- +-- |Replace special characters to XML entities. +replaceToEntities :: String -> String +replaceToEntities [] = [] +replaceToEntities (char:chars) = + let str = case char of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> char:[] + in str ++ (replaceToEntities chars) +----------------------------------------------- + +attrsToString :: [(String,String)] -> String +attrsToString [] = "" +attrsToString ((name,value):attrs) = + " "++name++"='"++value++"'" ++ attrsToString attrs + +getRest :: Parser a -> Parser (a, String) +getRest f = do x <- try f + p <- getInput + return (x, p) + +xmppStreamStart :: Parser XMLElem +xmppStreamStart = + do + many $ try processingInstruction + streamTag <- shallowTag + return streamTag + +shallowTag :: Parser XMLElem +shallowTag = + do + tag <- tagStart + char '>' + return tag + +deepTags :: Parser [XMLElem] +deepTags = many $ try deepTag + +deepTag :: Parser XMLElem +deepTag = + do + (XML name attrs _) <- tagStart + subels <- + (try $ do + char '/' + char '>' + return []) + <|> + do + char '>' + els <- many $ (try deepTag) <|> cdata + char '<' + char '/' + string name + char '>' + return els + return $ XML name attrs subels + +tagStart :: Parser XMLElem +tagStart = + do + char '<' + name <- many1 tokenChar + many space + attrs <- many $ + do + attr <- attribute + many space + return attr + return $ XML name attrs [] + +attribute :: Parser (String, String) +attribute = + do + name <- many1 tokenChar + char '=' + quote <- char '\'' <|> char '"' + value <- many $ satisfy (/=quote) + char quote + return (name, value) + +----------------------------------------------- +-- cdata :: Parser XMLElem +-- cdata = +-- do +-- text <- many1 plainCdata +-- return $ CData text +-- where plainCdata = satisfy (\c -> c/='<') + +cdata :: Parser XMLElem +cdata = + do + text <- many1 $ plainCdata <|> predefinedEntity + return $ CData text + where plainCdata = satisfy (\c -> c/='<' && c/='&') + predefinedEntity = do + char '&' + entity <- try (string "amp") + <|> try (string "lt") + <|> try (string "gt") + <|> try (string "quot") + <|> string "apos" + char ';' + return $ case entity of + "amp" -> '&' + "lt" -> '<' + "gt" -> '>' + "quot" -> '"' + "apos" -> '\'' +----------------------------------------------- + +tokenChar :: Parser Char +tokenChar = letter <|> char ':' <|> char '-' + +processingInstruction :: Parser () +processingInstruction = + do + char '<' + char '?' + many $ satisfy (/='?') + char '?' + char '>' + return () + +----------------------------------------------- +-- |Default xmlPath doesn't find subtag2 if we have +-- tag1/subtag1 and tag1/subtag2 in xml stanza. +xmlPath' :: [String] -> [XMLElem] -> Maybe XMLElem +xmlPath' [] [] = Nothing +xmlPath' [] els = Just $ head els +xmlPath' (name:names) elems = + let elems' = map filter_elem elems + filter_elem (XML _ _ els) = filter (\stanza -> + case stanza of + (XML n _ _) -> name==n + _ -> False) els + + in xmlPath' names (concat elems') diff --git a/Network/XMPP/XMPPConnection.hs b/Network/XMPP/XMPPConnection.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/XMPPConnection.hs @@ -0,0 +1,12 @@ +module Network.XMPP.XMPPConnection (XMPPConnection(..)) where + +import Network.XMPP.XMLParse + +-- |A class for various kinds of XMPP connections. +class XMPPConnection c where + -- |Get incoming stanzas from the connection. + getStanzas :: c -> IO [XMLElem] + -- |Send a stanza on the connection. + sendStanza :: c -> XMLElem -> IO () + -- |Close the connection. + closeConnection :: c -> IO () diff --git a/Network/XMPP/XMPPMonad.hs b/Network/XMPP/XMPPMonad.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/XMPPMonad.hs @@ -0,0 +1,172 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- this could be {-# LANGUAGE FlexibleInstances #-} +module Network.XMPP.XMPPMonad + ( XMPP + , runXMPP + , sendStanza + , addHandler + , waitForStanza + , quit + , StanzaPredicate + , StanzaHandler + , Control.Monad.State.liftIO + ) + where + +import Control.Monad.State + +import Network.XMPP.XMLParse +import Network.XMPP.XMPPConnection hiding ( sendStanza ) +import qualified Network.XMPP.XMPPConnection as XMPPConnection +import Network.XMPP.MyDebug + +-- |A stanza predicate. +type StanzaPredicate = (XMLElem -> Bool) +type StanzaHandlerPart a = (XMLElem -> XMPP a) +-- |A handler function for a stanza. +type StanzaHandler = (XMLElem -> XMPP ()) + +-- |A function in the XMPP monad behaves a bit like a thread in a +-- cooperative threading system: when it decides to wait for more +-- input, it \"sleeps\", letting other \"threads\" run, until input +-- matching a certain predicate arrives. +data XMPP a = + XMPP { xmppFn :: XMPPConnection c => + (c -> XMPPState -> IO (XMPPState, XMPPRes a)) } +type XMPPState = + [(StanzaPredicate, -- predicate + StanzaHandler, -- handler + Bool)] -- more than once? + +data XMPPRes a = XMPPJust a + | WaitingFor StanzaPredicate (StanzaHandlerPart a) Bool + +instance Monad XMPP where + f >>= g = XMPP $ + \c state -> + do + (state', result) <- xmppFn f c state + case result of + XMPPJust a -> + xmppFn (g a) c state' + WaitingFor pred mangler keep -> + return $ (state', + WaitingFor pred + (\stanza -> (mangler stanza) >>= g) keep) + return a = XMPP $ \_ state -> return (state, XMPPJust a) + +-- This used to use MonadState, but there is no point. +getState :: XMPP XMPPState +getState = XMPP $ \_ state -> return (state, XMPPJust state) +putState :: XMPPState -> XMPP () +putState state = XMPP $ \_ _ -> return (state, XMPPJust ()) +modifyState :: (XMPPState -> XMPPState) -> XMPP () +modifyState fn = XMPP $ \_ state -> return (fn state, XMPPJust ()) + +instance MonadIO XMPP where + liftIO iofn = XMPP $ \c state -> do + iores <- iofn + return (state, XMPPJust iores) + +initialState :: XMPPState +initialState = [] + +-- |Run a function in the XMPP monad using the given XMPP connection. +-- After that, keep looping as long as there are handlers waiting for +-- incoming stanzas. +runXMPP :: XMPPConnection c => c -> XMPP () -> IO () +runXMPP c x = runXMPP' initialState c [x] [] + where runXMPP' :: XMPPConnection c => XMPPState -> c -> [XMPP ()] -> [XMLElem] -> IO () + runXMPP' [] c [] _ = + -- if there are no functions and no handlers, there is + -- nothing left to do. + return () + runXMPP' s c (x:xs) stanzas = + -- if we have functions waiting to be run, run the first of them + -- (actually, the list will always contain 0 or 1 element) + do + (s', result) <- xmppFn x c s + let s'' = (case result of + XMPPJust () -> + s' + WaitingFor pred mangler keep -> + (pred,mangler,keep):s' + ) + runXMPP' s'' c xs stanzas + runXMPP' s c [] (stanza:stanzas) = + -- if there are unprocessed stanzas, process the first of them + runXMPP' s c [actOnStanza stanza] stanzas + runXMPP' s c [] [] = + -- if there are no more functions to run, but there are + -- handlers left, wait for incoming stanzas + do + myDebug $ show (length s) ++ " handlers left" + newStanzas <- getStanzas c + myDebug $ show (length newStanzas) ++ " new stanzas" + runXMPP' s c [] newStanzas + +-- |Send an XMPP stanza. +sendStanza :: XMLElem -> XMPP () +sendStanza stanza = + XMPP $ \c state -> do + XMPPConnection.sendStanza c stanza + return (state, XMPPJust ()) + +-- |When a stanza matching the predicate arrives, call the given +-- handler. This is analogous to spawning a new thread, except that +-- the \"thread\" is only run if and when a matching stanza arrives. +-- +-- Stanza handlers can be one-shot or permanent, as indicated by the +-- third argument. +addHandler :: StanzaPredicate -- ^Stanza predicate. + -> StanzaHandler -- ^Stanza handler. + -> Bool -- ^Catch more than one stanza? + -> XMPP () +addHandler pred handler keep = + modifyState ((pred, handler, keep):) + +-- |Suspend execution of current function while waiting for a stanza +-- matching the predicate. +waitForStanza :: StanzaPredicate -> XMPP XMLElem +waitForStanza pred = + XMPP $ \c state -> return (state, WaitingFor pred return False) + +-- |Terminate the loop as soon as the current function exits. This +-- works by removing all stanza handlers, which makes 'runXMPP' exit. +quit :: XMPP () +quit = + putState [] + +actOnStanza :: XMLElem -> XMPP () +actOnStanza stanza = + do + table <- getState + liftIO $ myDebug $ "checking " ++ show (length table) ++ " active handlers" + case findHandler table stanza of + Just (table', handler) -> + do + putState table' + liftIO $ myDebug $ show (length table') ++ " handlers left" + handler stanza + Nothing -> + return () + +-- Find handler whose predicate matches the stanza, possibly removing +-- the entry from the table. +findHandler :: [(StanzaPredicate, StanzaHandler, Bool)] -> XMLElem -> + Maybe ([(StanzaPredicate, StanzaHandler, Bool)], StanzaHandler) +findHandler ((pred, handler, keep):table) stanza = + case pred stanza of + True -> + let table' = if keep + then + ((pred, handler, keep):table) + else + table + in return (table', handler) + False -> + do + (table', handler') <- findHandler table stanza + return ((pred, handler, keep):table', handler') +findHandler [] _ = Nothing + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,24 @@ +This is an XMPP library for Haskell. Install it this: + +% runhaskell Setup configure --prefix=$HOME/.cabal --user +% runhaskell Setup build +% runhaskell Setup install + +Or simple: + +% ./install.sh + +Build the documentation with: + +% runhaskell Setup.hs haddock + +The documentation is also available on the web page. + +http://www.dtek.chalmers.se/~henoch/text/hsxmpp.html +http://www.dtek.chalmers.se/~henoch/darcs/hsxmpp/ +mailto:henoch@dtek.chalmers.se +xmpp:legoscia@jabber.cd.chalmers.se + + +Some patches by Kagami +xmpp:anon0@jabber.ru diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/XMPP.cabal b/XMPP.cabal new file mode 100644 --- /dev/null +++ b/XMPP.cabal @@ -0,0 +1,26 @@ +Name: XMPP +Version: 0.0.2 +Synopsis: XMPP library +Category: Network +Description: XMPP library +License: BSD3 +License-file: COPYING +Author: Magnus Henoch, Kagami +Maintainer: newanon@yandex.ru +Homepage: http://www.dtek.chalmers.se/~henoch/text/hsxmpp.html +Build-Type: Simple +Cabal-Version: >=1.2 + +Data-Files: README, report.txt +Extra-Source-Files: install.sh + +Library + Exposed-Modules: Network.XMPP, Network.XMPP.MUC + + Other-modules: Network.XMPP.Auth, Network.XMPP.JID, + Network.XMPP.Stanzas, Network.XMPP.TCPConnection, + Network.XMPP.XMLParse, Network.XMPP.XMPPConnection, + Network.XMPP.XMPPMonad, Network.XMPP.MyDebug + + Build-depends: base >= 4.0 && < 5, haskell98, random, utf8-string, + network, parsec, mtl diff --git a/install.sh b/install.sh new file mode 100644 --- /dev/null +++ b/install.sh @@ -0,0 +1,7 @@ +#!/bin/sh + +runhaskell Setup configure --prefix=$HOME/.cabal --user \ +&& \ +runhaskell Setup build \ +&& \ +runhaskell Setup install diff --git a/report.txt b/report.txt new file mode 100644 --- /dev/null +++ b/report.txt @@ -0,0 +1,178 @@ +----------------------------------------------- +Needs some updates after my patches. +-- Kagami +----------------------------------------------- + + + +Report: A Monad for Writing XMPP Clients +Magnus Henoch + +The original goal of the project was to write a library for writing +XMPP IM clients, with the flow of the program codified in an XMPP +monad. My idea was to completely separate the application logic from +the actual sending and receiving of stanzas (the equivalent of +messages or packets in other protocols), but I found that this way of +doing it made the bind function and the run function quite +cumbersome. Instead I embedded the IO monad into the XMPP monad. +Continuations (which in this context means waiting for a certain +packet to arrive without blocking the rest of the program) were only a +tentative part of the original plan, but turned out to be easier than +I thought, once I succeeded in wrapping my head around it. + +Though my experience with the library is so far limited, it seems to +be a nice fit for the request-response model of XMPP programming. +Sending a request and waiting for a response in the same function is +quite convenient, as the "polling" and response-matching is taken care +of behind the back of the programmer. + +* What is XMPP? + +XMPP is a protocol for streaming XML defined in RFCs 3920 and 3921, so +far mostly used for instant messaging. Its main transport method is a +TCP connection starting with a opening tag, and ending (after +the session is over) with a closing tag. Between these come +payload elements, called stanzas. There are three kinds of stanzas, +, and . is used for sending +information to another entity, not necessarily with any previous +contact. is used for performing a specific request; it always +expects a response. is used to signal the availability of +an entity. + +* XMPPConnection.hs + +This module contains the XMPPConnection class. There are different +ways to make an XMPP connection, but all of these should be able to +implement the three methods: getStanzas (i.e. get stanzas in receive +buffer), sendStanza, and closeConnection. + +* TCPConnection.hs + +TCPConnection is an instance of XMPPConnection, so far the only one. +It uses the XMLParse module to be able to parse partial input. +getStanzas is ultimately implemented in terms of getString. I wanted +getString to sleep until there is any input, but I found no way of +doing that. Instead, it checks for input once every second. + +* XMLParse.hs + +This module implements a simple XML parser. Unlike most other XML +parsing libraries, it doesn't require that the XML document is +complete when starting to parse it. In theory a SAX parser could +satisfy this constraint, but in practice the ones I found didn't and +are therefore unsuitable for an XMPP application. + +The interesting part of the parser is the getRest function. It takes +a parser function as an argument, attempts to parse the input with it, +and returns the result along with the part of the input that couldn't +be parsed. This means that the caller doesn't have to ensure that a +complete stanza has arrived over the network before calling the +parser. Unfortunately, it also means that invalid XML will not be +reported as an error, since it is indistinguishable from incomplete +input. Using a real SAX parser would fix this problem; however, this +isn't very important for an XMPP client, as it only receives data that +has already been parsed by the server. + +The XML data is parsed into the XMLElem data type, which has two +alternatives, one for XML elements and one for character data. The +functions getAttr and getCdata provide convenient access to various +parts of an element. The xmlPath function takes a list of strings and +an element, and for each string descends to the subelement of the +current element with that name. + +* XMPP.hs + +This module contains the XMPP monad. The XMPP monad has two purposes: +it hides the XMPPConnection from the application code, as it is passed +along behind the scenes; and it lets the application code "stop and +wait" for a stanza fulfilling certain criteria. + +The latter feature is what sets my XMPP library apart from others. +Most libraries (including mine) allow the programmer to define +callbacks for certain events, e.g. a service discovery request. This +is fine for requests which only require a single response, but in the +case of a more elaborate conversation, keeping state becomes +necessary. Using closures is a convenient way to keep that state. + +Specifically, the bind function of the XMPP monad can, depending on +the return value of the first function, either just execute the next +function (keeping the list of stanza handlers as a state variable), or +package the next function as a continuation to be executed when a +stanza fulfilling a certain criterion arrives. + +The actual execution of functions in the XMPP monad is done by the +runXMPP function, which queries the given connection for new stanzas +and calls the corresponding handlers. + +* Stanzas.hs + +This module contains helper functions that isolate common idioms. +These are of three kinds: functions for sending stanzas, stanza +predicates, and entire handlers for simple XMPP functions. + +sendMessage takes two arguments, a recipient and a message text, and +sends the text as a chat message to the recipient. sendPresence sends +the simplest possible presence stanza, which tells the server that the +client is "available". sendIq sends an infoquery request with a +randomly generated ID and returns that ID; in most cases sendIqWait +would be used, as it waits for a response to the request and returns +that response. Finally, sendIqResponse sends a response to a received +request. + +The stanza predicates are simply functions of type XMLElem -> Bool; +some of them take additional arguments. They can be combined with the +conj function, which takes two predicates and returns a predicate that +returns true if both composing predicates return true. Most of them +are quite self-explaining. One combination that I've found +particularly useful is "hasBody `conj` isFrom sender" - in a +conversation, this gets the next message from the contact that +actually has text in it, ignoring various meta messages. + +The function handleVersion implements the Software Version extension, +through which an entity can tell the name and version of its +implementation, and the operating system it is running on. The +handleVersion function thus takes these three values as arguments, and +installs a handler for requests in the "jabber:iq:version" namespace. +Some XMPP functions could be implemented as simply as this one, while +others would need more integration with the rest of the program. + +* Auth.hs + +This module contains the startAuth function, which tries to +authenticate given a username, a server and a password. If it fails, +it calls 'error'. + +This code currently sends passwords in plain text over the network. +It should be replaced with code that authenticates using SASL. + +* JID.hs + +A JID (Jabber ID) looks like: + +[username@]server[/resource] + +The functions getUsername and getResource return the respective parts +of the given JID, or an empty string if that part is absent. + +A "bare JID" is a JID without a resource. getBareJid converts any JID +to a bare JID. + +* MUC.hs + +MUC stands for "Multi-User Chat", an XMPP extension for IRC-like chat +rooms. The functions in this module provide a somewhat unpolished +interface to such rooms. + +The joinGroupchat function takes a nickname and a room JID, and tries +to join it. If it succeeds, it returns a function that at any time +can list the room participants; if it fails, it returns Nothing. The +functions isGroupchatMessage, isGroupchatPrivmsg, sendGroupchatMessage +and sendGroupchatPrivateMessage do what their names say. + +This module illustrates a problem with the event model I have chosen. +The joinGroupchat function installs a handler to register when people +enter and leave the chatroom, so that this information is always +available to the program, but this precludes the program from adding +its own handler to those events. It would be nice if the MUC module +could somehow send its own high-level events, independent of the +underlying stanza events.