network-protocol-xmpp 0.1 → 0.2
raw patch · 5 files changed
+175/−200 lines, 5 filesdep +SHAdep +bytestring
Dependencies added: SHA, bytestring
Files
- Network/Protocol/XMPP.hs +2/−0
- Network/Protocol/XMPP/Client.hs +6/−12
- Network/Protocol/XMPP/Stanzas.hs +105/−158
- Network/Protocol/XMPP/Stream.hs +56/−25
- network-protocol-xmpp.cabal +6/−5
Network/Protocol/XMPP.hs view
@@ -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
Network/Protocol/XMPP/Client.hs view
@@ -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
Network/Protocol/XMPP/Stanzas.hs view
@@ -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)]
Network/Protocol/XMPP/Stream.hs view
@@ -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 = "<?xml version='1.0'?>\n" ++- "<stream:stream xmlns='jabber:client'" +++ "<stream:stream xmlns='" ++ DOM.attrEscapeXml ns ++ "'" ++ " to='" ++ (DOM.attrEscapeXml . jidFormat) jid ++ "'" ++ " version='1.0'" ++ " xmlns:stream='http://etherx.jabber.org/streams'>"@@ -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 -------------------------------------------------------------------------------
network-protocol-xmpp.cabal view
@@ -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 <jmillikin@gmail.com>+ Stephan Maka <stephan@spaceboyz.net> 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