diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -17,9 +17,11 @@ module Network.Protocol.XMPP ( module Network.Protocol.XMPP.JID ,module Network.Protocol.XMPP.Client + ,module Network.Protocol.XMPP.Component ,module Network.Protocol.XMPP.Stanzas ) where import Network.Protocol.XMPP.JID import Network.Protocol.XMPP.Client +import Network.Protocol.XMPP.Component import Network.Protocol.XMPP.Stanzas diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -37,7 +37,8 @@ import qualified Network.Protocol.XMPP.SASL as SASL import qualified Network.Protocol.XMPP.Stream as S import Network.Protocol.XMPP.Util (mkElement, mkQName) -import Network.Protocol.XMPP.Stanzas (Stanza, stanzaXML) +import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree) +import Network.Protocol.XMPP.Connection data ConnectedClient = ConnectedClient JID S.Stream @@ -53,7 +54,7 @@ clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient clientConnect jid host port = do handle <- connectTo host port - stream <- S.beginStream jid handle + stream <- S.beginStream jid "jabber:client" handle return $ ConnectedClient jid stream clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client @@ -103,13 +104,6 @@ getTree c return jid -------------------------------------------------------------------------------- - -putTree :: Client -> XmlTree -> IO () -putTree = S.putTree . clientStream - -getTree :: Client -> IO XmlTree -getTree = S.getTree . clientStream - -putStanza :: (Stanza a) => Client -> a -> IO () -putStanza c = (putTree c) . stanzaXML +instance Connection Client where + getTree = S.getTree . clientStream + putTree = S.putTree . clientStream diff --git a/Network/Protocol/XMPP/Stanzas.hs b/Network/Protocol/XMPP/Stanzas.hs --- a/Network/Protocol/XMPP/Stanzas.hs +++ b/Network/Protocol/XMPP/Stanzas.hs @@ -15,13 +15,10 @@ -} module Network.Protocol.XMPP.Stanzas ( - Stanza(..) - ,GenericStanza(..) - ,Message(..) - ,Presence(..) - ,toStanza - ,toMessage - ,toPresence + StanzaType(..) + ,Stanza(..) + ,treeToStanza + ,stanzaToTree ) where import Text.XML.HXT.DOM.Interface (XmlTree) @@ -32,167 +29,117 @@ import Network.Protocol.XMPP.Util (mkElement, mkQName) import qualified Text.XML.HXT.DOM.XmlNode as XN -class Stanza a where - stanzaTo :: a -> Maybe JID - stanzaFrom :: a -> Maybe JID - stanzaID :: a -> String - stanzaType :: a -> String - stanzaLang :: a -> String - stanzaXML :: a -> XmlTree - -data GenericStanza = GenericStanza - { - genericStanzaTo :: Maybe JID - ,genericStanzaFrom :: Maybe JID - ,genericStanzaID :: String - ,genericStanzaType :: String - ,genericStanzaLang :: String - ,genericStanzaXML :: XmlTree - } - -instance Stanza GenericStanza where - stanzaTo = genericStanzaTo - stanzaFrom = genericStanzaFrom - stanzaID = genericStanzaID - stanzaType = genericStanzaType - stanzaLang = genericStanzaLang - stanzaXML = genericStanzaXML - -data Message = Message - { - messageTo :: JID - ,messageFrom :: Maybe JID - ,messageID :: String - ,messageType :: String - ,messageLang :: String - ,messageBody :: String - } +data StanzaType = + MessageNormal + | MessageChat + | MessageGroupChat + | MessageHeadline + | MessageError + + | PresenceUnavailable + | PresenceSubscribe + | PresenceSubscribed + | PresenceUnsubscribe + | PresenceUnsubscribed + | PresenceProbe + | PresenceError + + | IQGet + | IQSet + | IQResult + | IQError deriving (Show, Eq) -data Presence = Presence +data Stanza = Stanza { - presenceTo :: Maybe JID - ,presenceFrom :: Maybe JID - ,presenceID :: String - ,presenceType :: String - ,presenceLang :: String - ,presenceShow :: String - ,presenceStatus :: String + stanzaType :: StanzaType + ,stanzaTo :: Maybe JID + ,stanzaFrom :: Maybe JID + ,stanzaID :: String + ,stanzaLang :: String + ,stanzaPayloads :: [XmlTree] } deriving (Show, Eq) -instance Stanza Message where - stanzaTo = Just . messageTo - stanzaFrom = messageFrom - stanzaID = messageID - stanzaType = messageType - stanzaLang = messageLang - stanzaXML m = let - attrs' = [ - maybeAttr "to" $ (Just . jidFormat =<<) . stanzaTo - ,maybeAttr "from" $ (Just . jidFormat =<<) . stanzaFrom - ,mkAttr "id" $ stanzaID - ,mkAttr "type" $ stanzaType - -- ,mkAttr "lang" $ stanzaLang -- TODO: namespace support? - ] - attrs = concat $ unmap m attrs' - - in mkElement ("jabber:client", "message") - attrs - [mkElement ("jabber:client", "body") [] - [XN.mkText $ messageBody m]] - -instance Stanza Presence where - stanzaTo = presenceTo - stanzaFrom = presenceFrom - stanzaID = presenceID - stanzaType = presenceType - stanzaLang = presenceLang - stanzaXML p = let - attrs' = [ - maybeAttr "to" $ (Just . jidFormat =<<) . stanzaTo - ,maybeAttr "from" $ (Just . jidFormat =<<) . stanzaFrom - ,mkAttr "id" $ stanzaID - ,mkAttr "type" $ stanzaType - -- ,mkAttr "lang" $ stanzaLang -- TODO: namespace support? - ] - attrs = concat $ unmap p attrs' - - showElem = case presenceShow p of - "" -> [] - text -> [mkElement ("jabber:client", "show") [] - [XN.mkText text]] - - statusElem = case presenceStatus p of - "" -> [] - text -> [mkElement ("jabber:client", "status") [] - [XN.mkText text]] - - in mkElement ("jabber:client", "presence") - attrs - (showElem ++ statusElem) - -------------------------------------------------------------------------------- - -toStanza :: XmlTree -> [GenericStanza] -toStanza t = let - getFrom = A.getAttrValue "from" >>> A.arrL (\x -> [jidParse x]) - getTo = A.getAttrValue "to" >>> A.arrL (\x -> [jidParse x]) - getID = A.getAttrValue "id" - getType = A.getAttrValue "type" - getLang = A.getAttrValue "lang" - attrArrow = (getTo &&& getFrom &&& getID &&& getType &&& getLang) - in do - (to, (from, (id', (type', lang)))) <- A.runLA attrArrow t - return $ GenericStanza to from id' type' lang t - -toMessage :: (Stanza a) => a -> [Message] -toMessage s = let - getBody = ( - A.arr stanzaXML - >>> A.hasQName (mkQName "jabber:client" "message") - >>> A.getChildren - >>> A.hasQName (mkQName "jabber:client" "body") - >>> A.getChildren - >>> A.getText - ) - bodyText = concat (A.runLA getBody s) - in case (bodyText, stanzaTo s) of - ("", _) -> [] - (_, Nothing) -> [] - (_, Just to) -> [Message to (stanzaFrom s) - (stanzaID s) (stanzaType s) - (stanzaLang s) bodyText] - -toPresence :: (Stanza a) => a -> [Presence] -toPresence s = let - getChildText qname = (A.getChildren >>> A.hasQName qname >>> - A.getChildren >>> A.getText) - getShow = getChildText $ mkQName "jabber:client" "show" - getStatus = getChildText $ mkQName "jabber:client" "status" - getShowStatus = ( - A.arr stanzaXML - >>> A.hasQName (mkQName "jabber:client" "presence") - >>> A.withDefault getShow [] - &&& A.withDefault getStatus [] - ) - in case A.runLA getShowStatus s of - [(show', status)] -> [Presence (stanzaTo s) (stanzaFrom s) - (stanzaID s) (stanzaType s) - (stanzaLang s) show' status] - _ -> [] +stanzaTypeMap :: [((String, String, String), StanzaType)] +stanzaTypeMap = mkStanzaTypeMap $ [ + ("jabber:client", "message", [ + ("normal", MessageNormal) + ,("chat", MessageChat) + ,("groupchat", MessageGroupChat) + ,("headline", MessageHeadline) + ,("error", MessageError) + ]) + ,("jabber:client", "presence", [ + ("unavailable", PresenceUnavailable) + ,("subscribe", PresenceSubscribe) + ,("subscribed", PresenceSubscribed) + ,("unsubscribe", PresenceUnsubscribe) + ,("unsubscribed", PresenceUnsubscribed) + ,("probe", PresenceProbe) + ,("error", PresenceError) + ]) + ,("jabber:client", "iq", [ + ("get", IQGet) + ,("set", IQSet) + ,("result", IQResult) + ,("error", IQError) + ]) + ] + where mkStanzaTypeMap raw = do + (ns, elementName, typeStrings) <- raw + (typeString, type') <- typeStrings + return ((ns, elementName, typeString), type') +stanzaTypeToStr :: StanzaType -> (String, String, String) +stanzaTypeToStr t = let + step [] = undefined + step ((ret, t'):tms) + | t == t' = ret + | otherwise = step tms + in step stanzaTypeMap -------------------------------------------------------------------------------- +stanzaTypeFromStr :: String -> String -> String -> Maybe StanzaType +stanzaTypeFromStr ns elementName typeString = let + key = (ns, elementName, typeString) + step [] = Nothing + step ((key', ret):tms) + | key == key' = Just ret + | otherwise = step tms + in step stanzaTypeMap -unmap :: a -> [(a -> b)] -> [b] -unmap _ [] = [] -unmap x (f:fs) = (f x):(unmap x fs) +treeToStanza :: XmlTree -> [Stanza] +treeToStanza t = do + to <- return . jidParse =<< A.runLA (A.getAttrValue "to") t + from <- return . jidParse =<< A.runLA (A.getAttrValue "from") t + id' <- A.runLA (A.getAttrValue "id") t + lang <- A.runLA (A.getAttrValue "lang") t + + ns <- A.runLA A.getNamespaceUri t + elementName <- A.runLA A.getLocalPart t + typeString <- A.runLA (A.getAttrValue "type") t + + let payloads = A.runLA (A.getChildren >>> A.isElem) t + + case stanzaTypeFromStr ns elementName typeString of + Nothing -> [] + Just type' -> [Stanza type' to from id' lang payloads] -maybeAttr :: (Stanza a) => String -> (a -> Maybe String) -> a -> [(String, String, String)] -maybeAttr attr f = mkAttr attr (\s -> maybe "" id (f s)) +stanzaToTree :: Stanza -> XmlTree +stanzaToTree s = let + (ns, elementName, typeString) = stanzaTypeToStr (stanzaType s) + + attrs' = [ + autoAttr "to" (maybe "" jidFormat . stanzaTo) + ,autoAttr "from" (maybe "" jidFormat . stanzaFrom) + ,autoAttr "id" stanzaID + ,autoAttr "xml:lang" stanzaLang + ,\_ -> [("", "type", typeString)] + ] + attrs = concatMap ($ s) attrs' + in mkElement (ns, elementName) attrs (stanzaPayloads s) -mkAttr :: (Stanza a) => String -> (a -> String) -> a -> [(String, String, String)] -mkAttr attr f stanza = case f stanza of +autoAttr :: String -> (Stanza -> String) -> Stanza -> [(String, String, String)] +autoAttr attr f stanza = case f stanza of "" -> [] text -> [("", attr, text)] diff --git a/Network/Protocol/XMPP/Stream.hs b/Network/Protocol/XMPP/Stream.hs --- a/Network/Protocol/XMPP/Stream.hs +++ b/Network/Protocol/XMPP/Stream.hs @@ -18,8 +18,10 @@ Stream ( streamLanguage ,streamVersion + ,streamID ,streamFeatures ) + ,XMPPStreamID(XMPPStreamID) ,StreamFeature ( FeatureStartTLS ,FeatureSASL @@ -36,6 +38,7 @@ import qualified System.IO as IO import Data.AssocList (lookupDef) import Data.Char (toUpper) +import Control.Applicative -- XML Parsing import Text.XML.HXT.Arrow ((>>>)) @@ -59,9 +62,11 @@ { streamHandle :: Handle ,streamJID :: JID + ,streamNS :: String ,streamParser :: SAX.Parser ,streamLanguage :: XMLLanguage ,streamVersion :: XMPPVersion + ,streamID :: XMPPStreamID ,streamFeatures :: [StreamFeature] } @@ -80,6 +85,8 @@ data XMPPVersion = XMPPVersion Int Int deriving (Show, Eq) +newtype XMPPStreamID = XMPPStreamID String + data Handle = PlainHandle IO.Handle | SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client) @@ -87,35 +94,40 @@ ------------------------------------------------------------------------------ restartStream :: Stream -> IO Stream -restartStream s = beginStream' (streamJID s) (streamHandle s) +restartStream s = beginStream' (streamJID s) (streamNS s) (streamHandle s) -beginStream :: JID -> IO.Handle -> IO Stream -beginStream jid rawHandle = do +beginStream :: JID -> String -> IO.Handle -> IO Stream +beginStream jid ns rawHandle = do IO.hSetBuffering rawHandle IO.NoBuffering - plainStream <- beginStream' jid (PlainHandle rawHandle) - - putTree plainStream $ Util.mkElement ("", "starttls") - [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] - [] - getTree plainStream + plainStream <- beginStream' jid ns (PlainHandle rawHandle) + + let startTLS = do + putTree plainStream $ Util.mkElement ("", "starttls") + [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] + [] + getTree plainStream - session <- GnuTLS.tlsClient [ - GnuTLS.handle GnuTLS.:= rawHandle - ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509] - ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials - ] - GnuTLS.handshake session - beginStream' jid (SecureHandle rawHandle session) + session <- GnuTLS.tlsClient [ + GnuTLS.handle GnuTLS.:= rawHandle + ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509] + ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials + ] + GnuTLS.handshake session + beginStream' jid ns (SecureHandle rawHandle session) -beginStream' :: JID -> Handle -> IO Stream -beginStream' jid h = do + case streamCanTLS plainStream of + True -> startTLS + False -> return plainStream + +beginStream' :: JID -> String -> Handle -> IO Stream +beginStream' jid ns h = do -- Since only the opening tag should be written, normal XML -- serialization cannot be used. Be careful to escape any embedded -- attributes. let xmlHeader = "\n" ++ - "" @@ -123,13 +135,17 @@ parser <- SAX.mkParser hPutStr h xmlHeader initialEvents <- readEventsUntil startOfStream h parser - featureTree <- getTree' h parser let startStreamEvent = last initialEvents - let (language, version) = parseStartStream startStreamEvent - let features = parseFeatures featureTree + let (language, version, streamID) = parseStartStream startStreamEvent + features <- (case ns of + "jabber:client" -> + parseFeatures <$> getTree' h parser + _ -> + return [] + ) - return $ Stream h jid parser language version features + return $ Stream h jid ns parser language version streamID features where streamName = Util.mkQName "http://etherx.jabber.org/streams" "stream" @@ -139,8 +155,15 @@ streamName == Util.convertQName elemName _ -> False -parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion) -parseStartStream e = (XMLLanguage "en", XMPPVersion 1 0) -- TODO +parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion, XMPPStreamID) +parseStartStream e = (XMLLanguage lang, XMPPVersion 1 0, XMPPStreamID id) + where SAX.BeginElement _ attrs = e + attr name = maybe "" SAX.attributeValue $ + m1 $ filter ((name ==) . SAX.qnameLocalName . SAX.attributeName) attrs + where m1 (x:_) = Just x + m1 _ = Nothing + lang = attr "lang" + id = attr "id" parseFeatures :: DOM.XmlTree -> [StreamFeature] parseFeatures t = @@ -175,6 +198,14 @@ >>> A.getText) t in FeatureSASL $ map (map toUpper) mechanisms + +streamCanTLS :: Stream -> Bool +streamCanTLS = (> 0) . length . + filter (\feature -> + case feature of + FeatureStartTLS _ -> True + _ -> False + ) . streamFeatures ------------------------------------------------------------------------------- diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -1,9 +1,10 @@ name: network-protocol-xmpp -version: 0.1 +version: 0.2 synopsis: Client <-> Server communication over XMPP license: GPL license-file: License.txt -author: John Millikin +author: John Millikin + Stephan Maka maintainer: jmillikin@gmail.com build-type: Simple cabal-version: >=1.6 @@ -12,11 +13,11 @@ bug-reports: mailto:jmillikin@gmail.com source-repository head - type: bzr - location: bzr+ssh://bazaar.launchpad.net/~jmillikin/%2Bjunk/network-protocol-xmpp/ + type: darcs + location: http://patch-tag.com/r/jmillikin/network-protocol-xmpp/pullrepo library - build-depends: base >=3 && < 5, hxt, libxml-sax >= 0.2, hsgnutls, gsasl, network + build-depends: base >=3 && < 5, hxt, libxml-sax >= 0.2, hsgnutls, gsasl, network, bytestring, SHA exposed-modules: Network.Protocol.XMPP Network.Protocol.XMPP.Client