diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -1,7 +1,7 @@ Copyright (c) 2007 Magnus Henoch -All rights reserved. - Copyright (c) 2009 Kagami +Copyright (c) 2009 Grigory Holomiev +All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions diff --git a/Network/XMPP.hs b/Network/XMPP.hs --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -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 diff --git a/Network/XMPP/Auth.hs b/Network/XMPP/Auth.hs --- a/Network/XMPP/Auth.hs +++ b/Network/XMPP/Auth.hs @@ -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" diff --git a/Network/XMPP/MUC.hs b/Network/XMPP/MUC.hs --- a/Network/XMPP/MUC.hs +++ b/Network/XMPP/MUC.hs @@ -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 diff --git a/Network/XMPP/Roster.hs b/Network/XMPP/Roster.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Roster.hs @@ -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 diff --git a/Network/XMPP/Stanzas.hs b/Network/XMPP/Stanzas.hs --- a/Network/XMPP/Stanzas.hs +++ b/Network/XMPP/Stanzas.hs @@ -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 element MUST NOT possess any attributes, with the +-- exception of the 'xml:lang' attribute. Multiple instances of the +-- 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 diff --git a/Network/XMPP/TCPConnection.hs b/Network/XMPP/TCPConnection.hs --- a/Network/XMPP/TCPConnection.hs +++ b/Network/XMPP/TCPConnection.hs @@ -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. diff --git a/Network/XMPP/XMLParse.hs b/Network/XMPP/XMLParse.hs --- a/Network/XMPP/XMLParse.hs +++ b/Network/XMPP/XMLParse.hs @@ -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) ++ "" 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') ----------------------------------------------- diff --git a/Network/XMPP/XMPPMonad.hs b/Network/XMPP/XMPPMonad.hs --- a/Network/XMPP/XMPPMonad.hs +++ b/Network/XMPP/XMPPMonad.hs @@ -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 diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 -xmpp:anon0@jabber.ru diff --git a/XMPP.cabal b/XMPP.cabal --- a/XMPP.cabal +++ b/XMPP.cabal @@ -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 +Author: Magnus Henoch, + Kagami , + Grigory Holomiev 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 diff --git a/install.sh b/install.sh deleted file mode 100644 --- a/install.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -runhaskell Setup configure --prefix=$HOME/.cabal --user \ -&& \ -runhaskell Setup build \ -&& \ -runhaskell Setup install diff --git a/report.txt b/report.txt --- a/report.txt +++ b/report.txt @@ -1,8 +1,6 @@ ----------------------------------------------- -Needs some updates after my patches. --- Kagami +Needs some updates after patches. ----------------------------------------------- - Report: A Monad for Writing XMPP Clients