diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -1,7 +1,6 @@ module Main where import Control.Monad.Trans (liftIO) -import Data.List import Network.XMPP import Network.XMPP.IQ @@ -9,25 +8,25 @@ import Network.XMPP.XEP.Version import Network.XMPP.Concurrent import Control.Monad -import qualified Text.XML.HaXml.Pretty as P (content) +-- import qualified Text.XML.HaXml.Pretty as P (content) import Text.XML.HaXml.Xtract.Parse (xtract) iqVersionT1 :: XmppThreadT () iqVersionT1 = do st <- readChanS - liftIO $ putStrLn ("thread1 got message! ") + liftIO $ putStrLn ("thread1 got next message.") when (isVersionReq st) $ do - writeChanS $ presAway "abcd" - liftIO $ putStrLn ("thread1 SENT message!") + writeChanS $ presAway "thread1" + liftIO $ putStrLn ("thread1: it was version request. We sent away presence \"thread1\"") iqVersionT1 iqVersionT2 :: XmppThreadT () iqVersionT2 = do st <- readChanS - liftIO $ putStrLn ("thread2 got message! ") + liftIO $ putStrLn ("thread2 got next message.") when (isVersionReq st) $ do - writeChanS $ presAway "AAAAAAAA!!!!" - liftIO $ putStrLn ("thread2 SENT message!") + writeChanS $ presAway "thread2" + liftIO $ putStrLn ("thread1: it was version request. We sent away presence \"thread2\"") iqVersionT2 iqVersion :: XmppThreadT () @@ -59,7 +58,7 @@ roster <- parseM liftIO $ putStrLn $ show roster -} - -- Set presence to defalt + -- Set presence to default mucJoin (read "testing@conference.jabber.ru/testbot") mucLeave (read "testing@conference.jabber.ru/testbot") diff --git a/haskell-xmpp.cabal b/haskell-xmpp.cabal --- a/haskell-xmpp.cabal +++ b/haskell-xmpp.cabal @@ -1,10 +1,10 @@ Name: haskell-xmpp -Version: 1.0 +Version: 1.0.1 License: BSD3 License-File: LICENSE Author: Dmitry Astapov , pierre Maintainer: Dmitry Astapov -Homepage: http://adept.linux.kiev.ua/repos/xmpp +Homepage: http://patch-tag.com/r/adept/haskell-xmpp/home Category: Network Copyright: (c) 2005-2011 Dmitry Astapov, k.pierre Stability: Stable @@ -30,9 +30,13 @@ description: Build examples default: False +flag debug + description: Enable debugging output + default: False + library Hs-Source-Dirs: ./src - Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.20.2, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string + Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.23.3, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string Exposed-modules: Network.XMPP , Network.XMPP.Sasl , Network.XMPP.Core @@ -53,12 +57,16 @@ , Network.XMPP.XEP.Version , Network.XMPP.Concurrent GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + if flag(debug) + CPP-Options: -DDEBUG Executable haskell-xmpp-test - Hs-Source-Dirs: ./examples + Hs-Source-Dirs: ./src ./examples if flag(examples) build-depends: base > 3 && <=5 else buildable: False + if flag(debug) + CPP-Options: -DDEBUG Main-Is: Test.hs GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -27,14 +27,8 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import Control.Monad.Trans (liftIO) -import Control.Monad import Control.Monad.State import Control.Monad.Reader -import Data.Maybe -import Network.XMPP.XEP.Version -import Network.XMPP.IM.Presence import Network.XMPP.Utils import System.IO @@ -108,7 +102,7 @@ connPersist :: Handle -> IO () connPersist h = do hPutStr h " " - putStrLn "" + debugIO "" threadDelay 30000000 connPersist h diff --git a/src/Network/XMPP/Helpers.hs b/src/Network/XMPP/Helpers.hs --- a/src/Network/XMPP/Helpers.hs +++ b/src/Network/XMPP/Helpers.hs @@ -24,6 +24,7 @@ import Network.BSD import Control.Concurrent (threadDelay, forkIO) import Control.Monad.Trans (liftIO) +import Network.XMPP.Utils -- | Connect to XMPP server on specified host \/ port connectViaTcp :: String -- ^ Server (hostname) to connect to @@ -46,7 +47,7 @@ liftIO $ forkIO $ pinger h return h where dropHeaders h = do l <- hGetLine h - putStrLn $ "Got: " ++ l + debugIO $ "Got: " ++ l if words l /= [] then dropHeaders h else return () pinger h = hPutStr h " " >> threadDelay (30 * 10^6) >> pinger h diff --git a/src/Network/XMPP/IM/Presence.hs b/src/Network/XMPP/IM/Presence.hs --- a/src/Network/XMPP/IM/Presence.hs +++ b/src/Network/XMPP/IM/Presence.hs @@ -56,5 +56,8 @@ (Just 0) -- pPriority :: Maybe Integer [] -- pExt :: [Content Posn] +mkPresenceD :: ShowType -> String -> Stanza mkPresenceD = mkPresence Default + +mkPresenceU :: ShowType -> String -> Stanza mkPresenceU = mkPresence Unavailable diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -23,21 +23,23 @@ import Text.Regex -- | Jabber ID (JID) datatype -data JID = JID { name :: String +data JID = JID { name :: Maybe String -- ^ Account name , server :: String -- ^ Server adress - , resource :: String + , resource :: Maybe String -- ^ Resource name } instance Read JID where -- Reads JID from string (name@server\/resource) - readsPrec a str = case matchRegexAll regex str of - Just (_,_,after,(_:name:_:server:_:_:resource:_:[])) -> [((JID name server resource), after)] + readsPrec _ str = case matchRegexAll regex str of + Just (_,_,after,(_:name:_:server:_:_:resource:_:[])) -> [((JID (toMaybe name) server (toMaybe resource)), after)] Just _ -> [] Nothing -> [] where + toMaybe "" = Nothing + toMaybe s = Just s regex = mkRegex $ "((([^@])+)@)?" ++ "(([^/])+)" ++ @@ -45,7 +47,8 @@ instance Show JID where -- Shows JID - show a = (if (name a) /= "" then (name a)++"@" else "") ++ - (server a)++ - (if (resource a) /= "" then "/"++(resource a) else "") + show jid = concat [name', server jid, resource'] + where name' = maybe "" (++"@") (name jid) + resource' = maybe "" (++"/") (resource jid) + diff --git a/src/Network/XMPP/Print.hs b/src/Network/XMPP/Print.hs --- a/src/Network/XMPP/Print.hs +++ b/src/Network/XMPP/Print.hs @@ -35,7 +35,6 @@ import System.IO import Text.XML.HaXml hiding (tag) import qualified Text.XML.HaXml.Pretty as P -import Text.PrettyPrint.HughesPJ import Network.XMPP.UTF8 import Network.XMPP.Types @@ -51,7 +50,7 @@ hPutXmpp :: Handle -> XmppMessage -> IO () hPutXmpp h msg = do let str = renderXmpp msg - putStrLn $ "Sending: " ++ str + debugIO $ "Sending: " ++ str hPutStr h $ toUTF8 str -- | Render HaXML combinators into string, hacked for XMPP @@ -59,7 +58,7 @@ renderXmpp theXml = case theXml of -- stupid hack for and - xml@(CElem (Elem "stream:stream" _ _) _) -> + xml@(CElem (Elem (N "stream:stream") _ _) _) -> (:) '<' $ takeWhile (/= '<') $ tail $ render $ P.content xml xml -> render $ P.content xml diff --git a/src/Network/XMPP/Sasl.hs b/src/Network/XMPP/Sasl.hs --- a/src/Network/XMPP/Sasl.hs +++ b/src/Network/XMPP/Sasl.hs @@ -104,8 +104,8 @@ where -- | Trim leading '=' and surrounding quotes (if any) from value trim str = case dropWhile (=='=') str of - x@('\"':rest) -> read x - x -> x + x@('\"':_) -> read x + x -> x saslDigestRspAuth chl = let pairs = get_pairs $ B64.decode chl diff --git a/src/Network/XMPP/Stanza.hs b/src/Network/XMPP/Stanza.hs --- a/src/Network/XMPP/Stanza.hs +++ b/src/Network/XMPP/Stanza.hs @@ -21,8 +21,6 @@ import Text.XML.HaXml.Xtract.Parse (xtract) -import Control.Monad.State - import Network.XMPP.Types import Network.XMPP.Print import Network.XMPP.Stream @@ -89,9 +87,9 @@ -- | Converts stanza to XML and outputs it outStanza :: Stanza -> XmppStateT () outStanza s = case s of - a@(Message _ _ _ _ _ _ _ _) -> outMessage a - a@(Presence _ _ _ _ _ _ _ _) -> outPresence a - a@(IQ _ _ _ _ _) -> outIQ a + a@(Message{}) -> outMessage a + a@(Presence{}) -> outPresence a + a@(IQ{}) -> outIQ a outMessage :: Stanza -> XmppStateT () outMessage (Message from' to' id' mtype' subject' body' thread' x') = diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -34,7 +34,6 @@ ) where import Control.Monad.State -import Foreign hiding (new) import System.IO import Text.ParserCombinators.Poly.State (onFail) import Text.XML.HaXml.Lex (xmlLex) @@ -106,9 +105,9 @@ let (starter, rest) = xmlParseWith streamStart ls case starter of Left e -> error e - Right (ElemTag "stream:stream" attrs) -> do modify (\stream -> stream { lexemes=rest }) - return attrs - Right x -> error $ "Unexpected element at the beginning of XMPP stream!" + Right (ElemTag (N "stream:stream") attrs) -> do modify (\stream -> stream { lexemes=rest }) + return attrs + Right _ -> error $ "Unexpected element at the beginning of XMPP stream!" where streamStart = do ( processinginstruction >> return () ) `onFail` return () elemOpenTag @@ -145,8 +144,9 @@ modify (\stream -> stream { idx = i+1 }) return i +lookupAttr :: String -> [Attribute] -> Maybe String lookupAttr k lst = - do x <- lookup k lst + do x <- lookup (N k) lst case x of AttValue [Left str] -> Just str AttValue _ -> Nothing diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -16,6 +16,7 @@ , StreamType(..) , Stanza(..) , MessageType(..), PresenceType(..), IQType(..), ShowType(..) + , RosterItem(..) , defaultStreamBlockSize , isMessage, isPresence, isIQ ) where @@ -27,7 +28,7 @@ import Text.XML.HaXml.Posn (Posn) import Text.XML.HaXml.Lex (Token) -import Text.PrettyPrint.HughesPJ (render, hcat) +import Text.PrettyPrint.HughesPJ (render) import qualified Text.XML.HaXml.Pretty as P (content) import Network.XMPP.JID @@ -67,7 +68,7 @@ -- ^ Entry's JID , subscribtion :: SubscribtionType -- ^ Subscribtion type - , name :: Maybe String + , nickname :: Maybe String -- ^ Entry's nickname , groups :: [String] -- ^ elements @@ -212,13 +213,13 @@ -- | Utility functions isMessage :: Stanza -> Bool -isMessage (Message _ _ _ _ _ _ _ _) = True +isMessage Message{} = True isMessage _ = False isPresence :: Stanza -> Bool -isPresence (Presence _ _ _ _ _ _ _ _) = True +isPresence Presence{} = True isPresence _ = False isIQ :: Stanza -> Bool -isIQ (IQ _ _ _ _ _) = True +isIQ IQ{} = True isIQ _ = False diff --git a/src/Network/XMPP/UTF8.hs b/src/Network/XMPP/UTF8.hs --- a/src/Network/XMPP/UTF8.hs +++ b/src/Network/XMPP/UTF8.hs @@ -49,5 +49,6 @@ import Codec.Binary.UTF8.String +fromUTF8, toUTF8 :: String -> String fromUTF8 = decodeString toUTF8 = encodeString diff --git a/src/Network/XMPP/Utils.hs b/src/Network/XMPP/Utils.hs --- a/src/Network/XMPP/Utils.hs +++ b/src/Network/XMPP/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Utils @@ -29,15 +30,15 @@ , mattr , mattr' , debug + , debugIO , literal -- from HaXML ) where import Control.Monad.State - import Text.XML.HaXml hiding (tag) import Text.XML.HaXml.Posn import qualified Text.XML.HaXml.Pretty as P -import Text.PrettyPrint.HughesPJ (render, hcat) +import Text.PrettyPrint.HughesPJ (hcat) import Text.XML.HaXml.Xtract.Parse (xtract) import Network.XMPP.Types @@ -51,7 +52,7 @@ toFilter x = (\_ -> [x]) noelem = - Elem "root" [] [] + Elem (N "root") [] [] strAttr s d = (s, literal d) sattr = strAttr @@ -71,9 +72,9 @@ isVal str cont = any (== str) . (getVals cont) -- -getText cs@(CString _ s _) = render . P.content $ cs -getText cs@(CRef _ _) = render . P.content $ cs -getText x = error $ "Attempt to extract text from content that is not a string: " ++ render ( P.content x ) +getText cs@(CString{}) = render . P.content $ cs +getText cs@(CRef{}) = render . P.content $ cs +getText x = error $ "Attempt to extract text from content that is not a string: " ++ render ( P.content x ) getText_ = render . hcat . map P.content @@ -81,10 +82,17 @@ mread a = Just $ read a mattr s (Just a) = [ strAttr s (show a) ] -mattr s Nothing = [] +mattr _ Nothing = [] mattr' s (Just a) = [ strAttr s a ] -mattr' s Nothing = [] +mattr' _ Nothing = [] debug :: String -> XmppStateT () +debugIO :: String -> IO () +#ifdef DEBUG debug = liftIO . putStrLn +debugIO = putStrLn +#else +debug _ = return () +debugIO _ = return () +#endif diff --git a/src/Network/XMPP/XEP/Delayed.hs b/src/Network/XMPP/XEP/Delayed.hs --- a/src/Network/XMPP/XEP/Delayed.hs +++ b/src/Network/XMPP/XEP/Delayed.hs @@ -16,11 +16,8 @@ isDelayed ) where -import Network.XMPP.Stanza import Network.XMPP.Stream import Network.XMPP.Types -import Network.XMPP.Print -import Network.XMPP.JID import Text.XML.HaXml.Xtract.Parse (xtract) @@ -28,3 +25,4 @@ isDelayed :: Stanza -> Bool isDelayed (Message _ _ _ _ _ _ _ ext) = any (== "jabber:x:delay") $ map (\x -> getText_ $ xtract id "/x/@xmlns" x) ext +isDelayed _ = False diff --git a/src/Network/XMPP/XEP/MUC.hs b/src/Network/XMPP/XEP/MUC.hs --- a/src/Network/XMPP/XEP/MUC.hs +++ b/src/Network/XMPP/XEP/MUC.hs @@ -20,7 +20,6 @@ ) where import Network.XMPP.Stanza -import Network.XMPP.Stream import Network.XMPP.Types import Network.XMPP.Print import Network.XMPP.JID diff --git a/src/Network/XMPP/XEP/Version.hs b/src/Network/XMPP/XEP/Version.hs --- a/src/Network/XMPP/XEP/Version.hs +++ b/src/Network/XMPP/XEP/Version.hs @@ -16,15 +16,11 @@ , versionAnswer ) where -import Network.XMPP.Stanza -import Network.XMPP.Stream import Network.XMPP.Types import Network.XMPP.Print -import Network.XMPP.JID import Network.XMPP.Utils import Text.XML.HaXml -import Text.XML.HaXml.Posn -- | True, if stanza is a version request isVersionReq :: Stanza -> Bool @@ -34,7 +30,7 @@ -- | Replies to version request versionAnswer :: String -> String -> String -> (Stanza -> [CFilter i]) -versionAnswer name version os s@(IQ { }) = +versionAnswer name version os (IQ { }) = [ ptag "query" [ xmlns "jabber:iq:version" ] [ ptag "name" [] [literal name],