packages feed

XMPP (empty) → 0.0.2

raw patch · 16 files changed

+1133/−0 lines, 16 filesdep +basedep +haskell98dep +mtlsetup-changed

Dependencies added: base, haskell98, mtl, network, parsec, random, utf8-string

Files

+ COPYING view
@@ -0,0 +1,28 @@+Copyright (c) 2007 Magnus Henoch+All rights reserved.++Copyright (c) 2009 Kagami <newanon@yandex.ru>++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.
+ Network/XMPP.hs view
@@ -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+-- <http://www.xmpp.org>.+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
+ Network/XMPP/Auth.hs view
@@ -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'
+ Network/XMPP/JID.hs view
@@ -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
+ Network/XMPP/MUC.hs view
@@ -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]]
+ Network/XMPP/MyDebug.hs view
@@ -0,0 +1,4 @@+module Network.XMPP.MyDebug where++myDebug :: String -> IO ()+myDebug msg = return ()
+ Network/XMPP/Stanzas.hs view
@@ -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)
+ Network/XMPP/TCPConnection.hs view
@@ -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 []
+ Network/XMPP/XMLParse.hs view
@@ -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) +                ++ "</" ++ name ++ ">"+            else+                ">"++-----------------------------------------------+-- |Replace special characters to XML entities.+replaceToEntities :: String -> String+replaceToEntities [] = []+replaceToEntities (char:chars) =+    let str = case char of+                '&' -> "&amp;"+                '<' -> "&lt;"+                '>' -> "&gt;"+                '"' -> "&quot;"+                '\'' -> "&apos;"+                _ -> 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')
+ Network/XMPP/XMPPConnection.hs view
@@ -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 ()
+ Network/XMPP/XMPPMonad.hs view
@@ -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+
+ README view
@@ -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 <newanon@yandex.ru>+xmpp:anon0@jabber.ru
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ XMPP.cabal view
@@ -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 <newanon@yandex.ru>+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
+ install.sh view
@@ -0,0 +1,7 @@+#!/bin/sh++runhaskell Setup configure --prefix=$HOME/.cabal --user \+&& \+runhaskell Setup build \+&& \+runhaskell Setup install
+ report.txt view
@@ -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 <stream> tag, and ending (after+the session is over) with a closing </stream> tag.  Between these come+payload elements, called stanzas.  There are three kinds of stanzas,+<message/>, <presence/> and <iq/>.  <message/> is used for sending+information to another entity, not necessarily with any previous+contact.  <iq/> is used for performing a specific request; it always+expects a response.  <presence/> 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.