From 2f2cd141c32e115a5aa16834e7f01e0f94c61d49 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Thu, 18 Jun 2009 23:04:21 +0000 Subject: [PATCH] Cleaned unused and duplicate imports, and added some type declarations. --- Network/Protocol/XMPP/Client.hs | 13 +++--- Network/Protocol/XMPP/IncrementalXML.hs | 2 +- Network/Protocol/XMPP/JID.hs | 9 +++-- Network/Protocol/XMPP/Stream.hs | 54 +++++++++++++------------ Network/Protocol/XMPP/Util.hs | 8 +++- 5 files changed, 46 insertions(+), 40 deletions(-) diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index b408460..0d0c546 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -20,23 +20,22 @@ module Network.Protocol.XMPP.Client ( ,clientConnect ,clientAuthenticate ,clientBind + ,clientJID + ,clientServerJID ,putTree ,getTree ) where -import System.IO (hSetBuffering, BufferMode(NoBuffering), Handle) import Codec.Binary.Base64.String (encode) import Network (HostName, PortID, connectTo) import Text.XML.HXT.Arrow ((>>>)) import qualified Text.XML.HXT.Arrow as A import Text.XML.HXT.DOM.TypeDefs (XmlTree) import qualified Text.XML.HXT.DOM.XmlNode as XN -import qualified Text.XML.HXT.DOM.QualifiedName as QN import Network.Protocol.XMPP.JID (JID, jidParse) import Network.Protocol.XMPP.SASL (Mechanism, bestMechanism) import qualified Network.Protocol.XMPP.Stream as S -import Network.Protocol.XMPP.Stanzas (Stanza) import Network.Protocol.XMPP.Util (mkElement, mkQName) data ConnectedClient = ConnectedClient JID S.Stream @@ -53,8 +52,6 @@ type Password = String clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient clientConnect jid host port = do handle <- connectTo host port - hSetBuffering handle NoBuffering - stream <- S.beginStream jid handle return $ ConnectedClient jid stream @@ -100,7 +97,7 @@ clientBind c = do >>> A.getText) bindResult let jid = case jidParse rawJID of Just x -> x - otherwise -> error "Couldn't parse server's returned JID" + _ -> error "Couldn't parse server's returned JID" -- Session putTree c $ mkElement ("", "iq") @@ -109,7 +106,7 @@ clientBind c = do [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")] []] - sessionResult <- getTree c + getTree c putTree c $ mkElement ("", "presence") [] [] getTree c @@ -119,7 +116,7 @@ advertisedMechanisms :: [S.StreamFeature] -> [Mechanism] advertisedMechanisms [] = [] advertisedMechanisms (f:fs) = case f of (S.FeatureSASL ms) -> ms - otherwise -> advertisedMechanisms fs + _ -> advertisedMechanisms fs ------------------------------------------------------------------------------- diff --git a/Network/Protocol/XMPP/IncrementalXML.hs b/Network/Protocol/XMPP/IncrementalXML.hs index 281c205..2c77aec 100644 --- a/Network/Protocol/XMPP/IncrementalXML.hs +++ b/Network/Protocol/XMPP/IncrementalXML.hs @@ -63,7 +63,7 @@ incrementalParse (Parser autoptr) s = do checkReturn :: CInt -> [Event] -> [Event] checkReturn r es = es ++ case r of 0 -> [] - otherwise -> [ParseError (show r)] + _ -> [ParseError (show r)] withFunPtr :: a -> (a -> IO (F.FunPtr a)) -> (F.FunPtr a -> IO b) -> IO b withFunPtr f mkPtr block = bracket (mkPtr f) F.freeHaskellFunPtr block diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs index 15bdfbc..95953f6 100644 --- a/Network/Protocol/XMPP/JID.hs +++ b/Network/Protocol/XMPP/JID.hs @@ -89,9 +89,12 @@ jidFormat (JID node (JIDDomain domain) resource) = let resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource in concat [nodeStr, domain, resourceStr] +split :: (Eq a) => [a] -> a -> ([a], [a]) split xs final = let (before, rawAfter) = span (/= final) xs - after = case rawAfter of - [] -> [] - xs -> tail xs + after = safeTail rawAfter in (before, after) + +safeTail :: [a] -> [a] +safeTail [] = [] +safeTail (_:xs) = xs diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs index 1f9c39e..29544c3 100644 --- a/Network/Protocol/XMPP/Stream.hs +++ b/Network/Protocol/XMPP/Stream.hs @@ -34,16 +34,14 @@ module Network.Protocol.XMPP.Stream ( ) where import qualified System.IO as IO -import qualified Network.Protocol.XMPP.IncrementalXML as XML import Data.AssocList (lookupDef) -import qualified Text.XML.HXT.DOM.QualifiedName as QN -import qualified Text.XML.HXT.DOM.XmlNode as XN -import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import Text.XML.HXT.DOM.FormatXmlTree (formatXmlTree) -import Text.XML.HXT.DOM.Util (attrEscapeXml) -import Text.XML.HXT.Arrow ((>>>), (>>.)) -import Data.Tree.NTree.TypeDefs (NTree(NTree)) + +-- XML Parsing +import Text.XML.HXT.Arrow ((>>>)) import qualified Text.XML.HXT.Arrow as A +import qualified Text.XML.HXT.DOM.Interface as DOM +import qualified Text.XML.HXT.DOM.XmlNode as XN +import qualified Network.Protocol.XMPP.IncrementalXML as XML -- TLS support import qualified Network.GnuTLS as GnuTLS @@ -54,6 +52,7 @@ import Network.Protocol.XMPP.JID (JID) import Network.Protocol.XMPP.SASL (Mechanism, findMechanism) import Network.Protocol.XMPP.Util (eventsToTree, mkQName, mkElement) +maxXMPPVersion :: XMPPVersion maxXMPPVersion = XMPPVersion 1 0 data Stream = Stream @@ -72,8 +71,7 @@ data StreamFeature = | FeatureRegister | FeatureBind | FeatureSession - | FeatureUnknown XmlTree - | FeatureDebug String + | FeatureUnknown DOM.XmlTree deriving (Show, Eq) newtype XMLLanguage = XMLLanguage String @@ -93,6 +91,8 @@ restartStream s = beginStream' (streamJID s) (streamHandle s) beginStream :: JID -> IO.Handle -> IO Stream beginStream jid rawHandle = do + IO.hSetBuffering rawHandle IO.NoBuffering + plainStream <- beginStream' jid (PlainHandle rawHandle) putTree plainStream $ mkElement ("", "starttls") @@ -116,13 +116,13 @@ beginStream' jid h = do let xmlHeader = "\n" ++ "" parser <- XML.newParser hPutStr h xmlHeader - [startStreamEvent] <- readEventsUntil startOfStream h parser 1000 + [startStreamEvent] <- readEventsUntil startOfStream h parser featureTree <- getTree' h parser let (language, version) = parseStartStream startStreamEvent @@ -134,13 +134,13 @@ beginStream' jid h = do streamName = mkQName "http://etherx.jabber.org/streams" "stream" startOfStream depth event = case (depth, event) of - (1, (XML.BeginElement streamName _)) -> True - otherwise -> False + (1, (XML.BeginElement elemName _)) -> streamName == elemName + _ -> False parseStartStream :: XML.Event -> (XMLLanguage, XMPPVersion) parseStartStream e = (XMLLanguage "en", XMPPVersion 1 0) -- TODO -parseFeatures :: XmlTree -> [StreamFeature] +parseFeatures :: DOM.XmlTree -> [StreamFeature] parseFeatures t = A.runLA (A.getChildren >>> A.hasQName featuresName @@ -149,7 +149,7 @@ parseFeatures t = where featuresName = mkQName "http://etherx.jabber.org/streams" "features" -parseFeature :: XmlTree -> StreamFeature +parseFeature :: DOM.XmlTree -> StreamFeature parseFeature t = lookupDef FeatureUnknown qname [ (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS) ,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL) @@ -158,12 +158,12 @@ parseFeature t = lookupDef FeatureUnknown qname [ ,(("urn:ietf:params:xml:ns:xmpp-session", "session"), (\_ -> FeatureSession)) ] t where - qname = maybe ("", "") (\n -> (QN.namespaceUri n, QN.localPart n)) (XN.getName t) + qname = maybe ("", "") (\n -> (DOM.namespaceUri n, DOM.localPart n)) (XN.getName t) -parseFeatureTLS :: XmlTree -> StreamFeature +parseFeatureTLS :: DOM.XmlTree -> StreamFeature parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required -parseFeatureSASL :: XmlTree -> StreamFeature +parseFeatureSASL :: DOM.XmlTree -> StreamFeature parseFeatureSASL t = let mechName = mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism" rawMechanisms = A.runLA ( @@ -178,18 +178,18 @@ parseFeatureSASL t = let ------------------------------------------------------------------------------- -getTree :: Stream -> IO XmlTree +getTree :: Stream -> IO DOM.XmlTree getTree s = getTree' (streamHandle s) (streamParser s) -getTree' :: Handle -> XML.Parser -> IO XmlTree +getTree' :: Handle -> XML.Parser -> IO DOM.XmlTree getTree' h p = do - events <- readEventsUntil finished h p 1000 + events <- readEventsUntil finished h p return $ eventsToTree events where finished 0 (XML.EndElement _) = True finished _ _ = False -putTree :: Stream -> XmlTree -> IO () +putTree :: Stream -> DOM.XmlTree -> IO () putTree s t = do let root = XN.mkRoot [] [t] let h = streamHandle s @@ -200,11 +200,12 @@ putTree s t = do ------------------------------------------------------------------------------- -readEventsUntil :: (Int -> XML.Event -> Bool) -> Handle -> XML.Parser -> Int -> IO [XML.Event] -readEventsUntil done h parser timeout = readEventsUntil' done 0 [] $ do +readEventsUntil :: (Int -> XML.Event -> Bool) -> Handle -> XML.Parser -> IO [XML.Event] +readEventsUntil done h parser = readEventsUntil' done 0 [] $ do char <- hGetChar h XML.incrementalParse parser [char] +readEventsUntil' :: (Int -> XML.Event -> Bool) -> Int -> [XML.Event] -> IO [XML.Event] -> IO [XML.Event] readEventsUntil' done depth accum getEvents = do events <- getEvents let (done', depth', accum') = readEventsStep done events depth accum @@ -212,12 +213,13 @@ readEventsUntil' done depth accum getEvents = do then return accum' else readEventsUntil' done depth' accum' getEvents +readEventsStep :: (Int -> XML.Event -> Bool) -> [XML.Event] -> Int -> [XML.Event] -> (Bool, Int, [XML.Event]) readEventsStep _ [] depth accum = (False, depth, accum) readEventsStep done (e:es) depth accum = let depth' = depth + case e of (XML.BeginElement _ _) -> 1 (XML.EndElement _) -> (- 1) - otherwise -> 0 + _ -> 0 accum' = accum ++ [e] in if done depth' e then (True, depth', accum') else readEventsStep done es depth' accum' diff --git a/Network/Protocol/XMPP/Util.hs b/Network/Protocol/XMPP/Util.hs index e605ab2..5c7e75e 100644 --- a/Network/Protocol/XMPP/Util.hs +++ b/Network/Protocol/XMPP/Util.hs @@ -43,6 +43,9 @@ eventsToTrees es = map blockToTree (splitBlocks es) splitBlocks :: [XML.Event] -> [[XML.Event]] splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es +splitBlocks' :: (Int, [XML.Event], [[XML.Event]]) + -> XML.Event + -> (Int, [XML.Event], [[XML.Event]]) splitBlocks' (depth, accum, allAccum) e = if depth' == 0 then (depth', [], allAccum ++ [accum']) @@ -53,9 +56,10 @@ splitBlocks' (depth, accum, allAccum) e = depth' = depth + case e of (XML.BeginElement _ _) -> 1 (XML.EndElement _) -> (- 1) - otherwise -> 0 + _ -> 0 blockToTree :: [XML.Event] -> XmlTree +blockToTree [] = error "No blocks" blockToTree (begin:rest) = let end = (last rest) in case (begin, end) of (XML.BeginElement qname attrs, XML.EndElement _) -> XN.mkElement qname (map convertAttr attrs) (eventsToTrees (init rest)) @@ -82,4 +86,4 @@ mkAttr ns localpart text = XN.mkAttr (mkQName ns localpart) [XN.mkText text] mkQName :: String -> String -> QN.QName mkQName ns localpart = case ns of "" -> QN.mkName localpart - otherwise -> QN.mkNsName localpart ns + _ -> QN.mkNsName localpart ns -- 2.38.4