XMPP 0.1.0 → 0.1.1

raw patch · 13 files changed

+264/−97 lines, 13 filesdep +hsdnsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hsdns

API changes (from Hackage documentation)

Files

• COPYING +2/−2
• Network/XMPP.hs +8/−5
• Network/XMPP/Auth.hs +1/−2
• Network/XMPP/MUC.hs +62/−20
• Network/XMPP/Roster.hs +97/−0
• Network/XMPP/Stanzas.hs +43/−6
• Network/XMPP/TCPConnection.hs +26/−5
• Network/XMPP/XMLParse.hs +11/−12
• Network/XMPP/XMPPMonad.hs +4/−4
• README +0/−24
• XMPP.cabal +9/−7
• install.sh +0/−7
• report.txt +1/−3

@@ -1,7 +1,7 @@ Copyright (c) 2007 Magnus Henoch-All rights reserved.- Copyright (c) 2009 Kagami <newanon@yandex.ru>+Copyright (c) 2009 Grigory Holomiev <omever@gmail.com>+All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions

@@ -3,27 +3,27 @@ -- -- > 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+-- >       sendpresence Nothing Nothing -- >       -- ...and do something. -- >       run--- > +-- > -- > run :: XMPP () -- > run = do -- >   -- Wait for an incoming message...@@ -60,6 +60,8 @@             , module Network.XMPP.TCPConnection               -- * Abstract connections             , module Network.XMPP.XMPPConnection+              -- * Roster management+            , module Network.XMPP.Roster             )     where @@ -70,3 +72,4 @@ import Network.XMPP.XMLParse import Network.XMPP.XMPPConnection hiding ( sendStanza ) import Network.XMPP.XMPPMonad+import Network.XMPP.Roster

@@ -10,9 +10,8 @@           -> String             -- ^Server (part after \@ in JID)           -> String             -- ^Password           -> String             -- ^Resource (unique identifier for this connection)-          -> Integer            -- ^Resource priority           -> XMPP Integer       -- ^Error number. Zero if authentication succeeded.-startAuth username server password resource priority = do+startAuth username server password resource = do   response <- sendIqWait server "get" [XML "query"                                        [("xmlns","jabber:iq:auth")]                                        [XML "username"

@@ -2,10 +2,7 @@ -- 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+import Network.XMPP  -- |Return true if the stanza is from a JID whose \"username\@server\" -- part matches the given string.@@ -13,24 +10,17 @@ matchesBare bare = attributeMatches "from" ((==bare).getBareJid)  -- |Join groupchat.-joinGroupchat :: String       -- ^Nickname to use+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.+              -> Maybe String -- ^Room password+              -> XMPP () 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+    sendStanza $ XML "presence"+                   [("to",room++"/"++nick)]+                   [XML "x" [("xmlns","http://jabber.org/protocol/muc")]+                     passNode]+  where+    passNode = maybe [] (\pass -> [XML "password" [] [CData pass]]) password  -- |Leave groupchat. leaveGroupchat :: String -> XMPP ()@@ -66,3 +56,55 @@                    [("to",room++"/"++nick),                     ("type","chat")]                    [XML "body" [] [CData body]]++--- Subject++getMessageSubject :: XMLElem -> Maybe String+getMessageSubject =+    getCdata . maybe (XML [] [] []) id . xmlPath ["subject"]++--- Occupants++-- | Occupant data strucuture.+data Occupant+  = Occupant+    { occRole :: Role+    , occAffiliation :: Affiliation+    , occNick :: String+    , occJid :: Maybe String+    }++data Role = RModerator | RParticipant | RNone | RVisitor+data Affiliation = AOwner | AAdmin | AMember | ANone++-- | Create occupant from stanza.+-- TODO: kick/ban/change status//change nick/etc parse+doOccupant :: XMLElem -> Occupant+doOccupant stanza =+    Occupant role aff nick jid+  where+    items = xmlPath' ["x", "item"] [stanza]+    item | length items == 0 = XML [] [] []+         | otherwise         = head items+    role = case getAttr "role" item of+             Just "moderator"   -> RModerator+             Just "participant" -> RParticipant+             Just "visitor"     -> RVisitor+             _                  -> RNone+    aff = case getAttr "affiliation" item of+            Just "owner"  -> AOwner+            Just "admin"  -> AAdmin+            Just "member" -> AMember+            _             -> ANone+    nick = snd $ getJidRes stanza+    jid = getAttr "jid" item++-- | Handler for groupchat events (join/leave/kicks/bans/etc).+isGroupchatPresence :: StanzaPredicate+isGroupchatPresence stanza =+    (isPresence stanza) && (not $ null xs')+  where+    xs = xmlPath' ["x"] [stanza]+    xs' = filter+            (attributeMatches "xmlns" (=="http://jabber.org/protocol/muc#user"))+            xs

@@ -0,0 +1,97 @@+module Network.XMPP.Roster (+    RosterItem(..),+    Subscription(..),+    getRoster,+    Presence(..),+    Status(..),+    StatusType(..),+    doPresence+) where++import Network.XMPP.XMPPMonad+import Network.XMPP.XMLParse+import Network.XMPP.Stanzas++-- TODO: add/delete roster items (via sending IQs)+--       add/delete subscriptions+++data RosterItem = RosterItem+    { itemName :: String+    , itemJid :: String+    , itemSubscription :: Subscription+    , itemGroups :: [String]+    } deriving Show++-- "There are nine possible subscription states"+-- It's horrible.+data Subscription = SBoth | SFrom | STo | SNone | SUnknown+                    deriving Show+++getRoster :: XMPP [RosterItem]+getRoster = do+    stanza <- sendIqWait "" "get" [XML "query" [("xmlns", "jabber:iq:roster")] []]+    let items = xmlPath' ["query", "item"] [stanza]+    return $ map getItem items+  where+    getItem item =+      let getAttr' attr = maybe "" id $ getAttr attr item++          name = getAttr' "name"+          jid = getAttr' "jid"+          groups = map cdata $ xmlPath' ["group"] [item]+          subs = case getAttr' "subscription" of+                   "to" -> STo+                   "from" -> SFrom+                   "both" -> SBoth+                   "none" -> SNone+                   _ -> SUnknown+      in RosterItem name jid subs groups+++--- Presences++data Presence = Available Status+              | Unavailable Status+              | Subscribe+              | Subscribed+              | Unsubscribe+              | Unsubscribed+              | Probe+              | Error++data Status = Status StatusType [String]++data StatusType = StatusOnline+                | StatusAway+                | StatusChat+                | StatusDND+                | StatusXA+                | StatusOffline+++-- | Read presence stanza.+doPresence :: XMLElem -> Presence+doPresence stanza =+    let stanzaType = getAttr "type" stanza+        statuses = map cdata $ xmlPath' ["status"] [stanza]+        statusType = case cdata' $ xmlPath ["show"] stanza of+                       Just "away" -> StatusAway+                       Just "chat" -> StatusChat+                       Just "dnd" -> StatusDND+                       Just "xa" -> StatusXA+                       _ -> StatusOnline+    in case stanzaType of+         Nothing -> Available (Status statusType statuses)+         Just "unavailable" -> Unavailable (Status StatusOffline statuses)+         Just "subscribe" -> Subscribe+         Just "subscribed" -> Subscribed+         Just "unsubscribe" -> Unsubscribe+         Just "unsubscribed" -> Unsubscribed+         Just "probe" -> Probe+         Just "error" -> Error+         _ -> Error++---+cdata' = getCdata . maybe (XML "" [] []) id

@@ -18,11 +18,15 @@                , handleVersion                , getErrorCode                , hasNodeName+               , getMessageStamp+               , getJidRes+               , cdata                )     where  import Network.XMPP.XMPPMonad import Network.XMPP.XMLParse+import Network.XMPP.JID import System.Random import Maybe @@ -104,12 +108,25 @@ --- Presence  -- |Send ordinary online presence.-sendPresence :: Maybe (String, Maybe String) -> Maybe Integer -> XMPP ()-sendPresence status prio = -    let priority = XML "priority" [] [CData $ show $ maybe 0 id prio] in-    case status of-        Nothing -> sendStanza $ XML "presence" [] [priority]-        Just (sh, s) -> sendStanza $ XML "presence" [] [priority, XML "show" [] [CData sh], XML "status" [] [CData $ maybe "" id s]]+-- If status is not ommited, then it should be one of the valid "show"+-- instances of the RFC3921 (first String in tuple), and if there+-- should be description of the status (status text) then the second+-- parameter in the tuple must be defined.+-- TODO: xml:lang+-- "The <status/> element MUST NOT possess any attributes, with the+-- exception of the 'xml:lang' attribute. Multiple instances of the+-- <status/> element MAY be included but only if each instance+-- possesses an 'xml:lang' attribute with a distinct language value."+sendPresence :: Maybe (String, [String]) -> Maybe Integer -> XMPP ()+sendPresence status priority =+    sendStanza $ XML "presence" [] (status'++priority')+  where+    priority' = maybe [] (\p -> [XML "priority" [] [CData $ show p]]) priority+    status' = case status of+        Just (sh, ss) -> (XML "show" [] [CData sh]):(statuses ss)+        _             -> []+    statuses = map (\s -> XML "status" [] [CData s])+ --- Stanza predicates  -- |Conjunction (\"and\") of two predicates.@@ -199,3 +216,23 @@       Just "error" -> read $ maybe "-1" id (getAttr "code" errorNode) :: Integer       _ -> 0     where errorNode = maybe (XML [] [] []) id (xmlPath ["error"] stanza)++-- |Get the stamp of message, if has any.+getMessageStamp :: XMLElem -> Maybe String+getMessageStamp stanza =+    let xs = xmlPath' ["x"] [stanza]+        xs' = filter (attributeMatches "xmlns" (=="jabber:x:delay")) xs+        stamps = map (getAttr "stamp") xs'+    in case stamps of+         [stamp@(Just s)] -> stamp+         _ -> Nothing++-- |Get the jid and the resource of stanza.+getJidRes :: XMLElem -> (String, String)+getJidRes stanza =+    let sender = maybe "" id (getAttr "from" stanza)+    in (getBareJid sender, getResource sender)++-- |Small helper function.+cdata :: XMLElem -> String+cdata = maybe "" id . getCdata

@@ -14,18 +14,22 @@ import Data.IORef import Control.Monad import Codec.Binary.UTF8.String+import ADNS + -- |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.+-- |Open a TCP connection to the named server, port 5222 (or others+-- found in SRV), and send a stream header. openStream :: String -> IO TCPConnection openStream server =     do-      h <- connectTo server (PortNumber 5222)-      hSetBuffering h NoBuffering-      hPutStr h $ xmlToString False $ +      -- here we do service lookup (via SRV or A)+      svcs <- getSvcServer server++      h <- connectStream svcs+      hPutStr h $ xmlToString False $               XML "stream:stream"                       [("to",server),                        ("xmlns","jabber:client"),@@ -33,6 +37,23 @@                       []       buffer <- newIORef ""       return $ TCPConnection h buffer++getSvcServer :: String -> IO [(String, PortID)]+getSvcServer domain =+    initResolver [] $ \resolver -> do+        a <- querySRV resolver ("_xmpp-client._tcp." ++ domain)+        return $ (maybe [] id a) ++ [(domain, PortNumber $ toEnum 5222)]++connectStream :: [(String, PortID)] -> IO Handle+connectStream [] = error "can't connect: no suitable servers found"+connectStream (x:xs) =+    catch (connectStream' x) (\e -> connectStream xs)++connectStream' :: (String, PortID) -> IO Handle+connectStream' (host, port) = do+    s <- connectTo host port+    hSetBuffering s NoBuffering+    return s  -- |Get the stream header that the server sent.  This needs to be -- called before doing anything else with the stream.

@@ -1,7 +1,7 @@ -- |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 +module Network.XMPP.XMLParse     ( XMLElem(..)     , xmlPath     , getAttr@@ -62,7 +62,7 @@ xmlToString close (XML name attrs subels) =     "<" ++ name ++ attrsToString attrs ++         if close then-            ">" ++ (concat $ map (xmlToString True) subels) +            ">" ++ (concat $ map (xmlToString True) subels)                 ++ "</" ++ name ++ ">"             else                 ">"@@ -196,18 +196,17 @@       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' :: [String] -> [XMLElem] -> [XMLElem]+xmlPath' [] [] = []+xmlPath' [] els = 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-+        filter_elem (XML _ _ els) =+            filter (\stanza ->+                     case stanza of+                       (XML n _ _) -> name==n+                       _ -> False+                   ) els     in xmlPath' names (concat elems')  -----------------------------------------------

@@ -30,8 +30,8 @@ -- 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 => +data XMPP a =+    XMPP { xmppFn :: XMPPConnection c =>                      (c -> XMPPState -> IO (XMPPState, XMPPRes a)) } type XMPPState =     [(StanzaPredicate,          -- predicate@@ -64,7 +64,7 @@ modifyState fn = XMPP $ \_ state -> return (fn state, XMPPJust ())  instance MonadIO XMPP where-    liftIO iofn = XMPP $ \c state -> do +    liftIO iofn = XMPP $ \c state -> do                         iores <- iofn                         return (state, XMPPJust iores) @@ -158,7 +158,7 @@ findHandler ((pred, handler, keep):table) stanza =     case pred stanza of       True ->-          let table' = if keep +          let table' = if keep                        then                            ((pred, handler, keep):table)                        else

@@ -1,24 +0,0 @@-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

@@ -1,18 +1,19 @@ Name:                XMPP-Version:             0.1.0+Version:             0.1.1 Synopsis:            XMPP library Category:            Network Description:         XMPP library License:             BSD3 License-file:        COPYING-Author:              Magnus Henoch, Kagami <newanon@yandex.ru>+Author:              Magnus Henoch,+                     Kagami <newanon@yandex.ru>,+                     Grigory Holomiev <omever@gmail.com> Maintainer:          newanon@yandex.ru-Homepage:            http://www.dtek.chalmers.se/~henoch/text/hsxmpp.html+Homepage:            http://kagami.touhou.ru/projects/show/matsuri Build-Type:          Simple Cabal-Version:       >=1.2 -Data-Files:          README, report.txt-Extra-Source-Files:  install.sh+Data-Files:          report.txt  Library   Exposed-Modules:   Network.XMPP, Network.XMPP.MUC@@ -20,7 +21,8 @@   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+                     Network.XMPP.XMPPMonad, Network.XMPP.MyDebug,+                     Network.XMPP.Roster    Build-depends:     base >= 4.0 && < 5, haskell98, random, utf8-string,-                     network, parsec, mtl+                     network, parsec, mtl, hsdns >= 1.4.1

@@ -1,7 +0,0 @@-#!/bin/sh--runhaskell Setup configure --prefix=$HOME/.cabal --user \-&& \-runhaskell Setup build \-&& \-runhaskell Setup install

@@ -1,8 +1,6 @@ ------------------------------------------------Needs some updates after my patches.--- Kagami+Needs some updates after patches. ------------------------------------------------   Report: A Monad for Writing XMPP Clients