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 -- > -- ...and do something. -- > run --- > +-- > -- > run :: XMPP () -- > run = do -- > -- Wait for an incoming message... 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/Presence.hs b/Network/XMPP/Presence.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Presence.hs @@ -0,0 +1,53 @@ +module Network.XMPP.Presence ( + Presence(..), + Status(..), + StatusType(..), + doPresence +) where + +import Network.XMPP + + +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 + + +-- | Parse 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/Roster.hs b/Network/XMPP/Roster.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Roster.hs @@ -0,0 +1,41 @@ +module Network.XMPP.Roster ( + RosterItem(..), + Subscription(..), + getRoster +) where + +import Network.XMPP + + +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 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,8 +108,8 @@ --- Presence -- |Send ordinary online presence. -sendPresence :: Integer -> XMPP () -sendPresence priority = sendStanza $ XML "presence" [] [XML "priority" [] [CData $ show priority]] +sendPresence :: XMPP () +sendPresence = sendStanza $ XML "presence" [] [] --- Stanza predicates @@ -196,3 +200,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/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 @@ -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) diff --git a/XMPP.cabal b/XMPP.cabal --- a/XMPP.cabal +++ b/XMPP.cabal @@ -1,5 +1,5 @@ Name: XMPP -Version: 0.0.3 +Version: 0.0.4 Synopsis: XMPP library Category: Network Description: XMPP library @@ -15,7 +15,8 @@ Extra-Source-Files: install.sh Library - Exposed-Modules: Network.XMPP, Network.XMPP.MUC + Exposed-Modules: Network.XMPP, Network.XMPP.MUC, Network.XMPP.Roster, + Network.XMPP.Presence Other-modules: Network.XMPP.Auth, Network.XMPP.JID, Network.XMPP.Stanzas, Network.XMPP.TCPConnection,