diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index 99f420f..ff425c0 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -653,7 +653,7 @@ processEvent e = get >>= \ state -> put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } Nothing -> return () - let xml = messageToXML $ Right message' + let xml = messageToXML (Right message') (fromJust $ langTag "en") lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx return Nothing @@ -674,7 +674,7 @@ processEvent e = get >>= \ state -> Nothing -> return () -- TODO: Bind ID to callback - let xml = iqToXML iq' + let xml = iqToXML iq' (fromJust $ langTag "en") lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx return Nothing diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index 5418e29..5d86039 100644 --- a/Network/XMPP/Stream.hs +++ b/Network/XMPP/Stream.hs @@ -172,6 +172,50 @@ counter c _ = c -- Sending stanzas is done through functions, where LangTag is Maybe. +-- Generates an XML element for a message stanza. The language tag provided is +-- the default language of the stream. + +messageToXML :: InternalMessage -> LangTag -> Element + +-- Non-error message. + +messageToXML (Right m) streamLang = Element "message" attribs nodes + + where + + -- Has the stanza attributes and the message type. + attribs :: [(Name, [Content])] + attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++ + [("type", [ContentText $ DT.pack $ show $ messageType m])] + + -- Has an arbitrary number of elements as children. + nodes :: [Node] + nodes = map (\ x -> NodeElement x) (messagePayload m) + + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ messageLangTag m + +-- Presence error. + +messageToXML (Left m) streamLang = Element "message" attribs nodes + + where + + -- Has the stanza attributes and the "error" presence type. + attribs :: [(Name, [Content])] + attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m) + stanzaLang ++ [("type", [ContentText $ DT.pack "error"])] + + -- Has the error element stanza as its child. + -- TODO: Include sender XML here? + nodes :: [Node] + nodes = [NodeElement $ errorElem streamLang stanzaLang $ messageErrorStanzaError m] + + -- The stanza language tag, if it's different from the stream language tag. + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ messageErrorLangTag m + + -- Generates an XML element for a presence stanza. The language tag provided is -- the default language of the stream. @@ -180,12 +224,13 @@ presenceToXML :: InternalPresence -> LangTag -> Element -- Non-error presence. presenceToXML (Right p) streamLang = Element "presence" attribs nodes + where -- Has the stanza attributes and the presence type. attribs :: [(Name, [Content])] - attribs = stanzaNodes (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ - [("type", [ContentText $ DT.pack $ show $ presenceType p])] + attribs = stanzaAttribs (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ + typeAttrib -- Has an arbitrary number of elements as children. nodes :: [Node] @@ -194,14 +239,18 @@ presenceToXML (Right p) streamLang = Element "presence" attribs nodes stanzaLang :: Maybe LangTag stanzaLang = stanzaLang' streamLang $ presenceLangTag p + typeAttrib :: [(Name, [Content])] + typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ DT.pack $ show presenceType'])] + -- Presence error. presenceToXML (Left p) streamLang = Element "presence" attribs nodes + where -- Has the stanza attributes and the "error" presence type. attribs :: [(Name, [Content])] - attribs = stanzaNodes (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) + attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) stanzaLang ++ [("type", [ContentText $ DT.pack "error"])] -- Has the error element stanza as its child. @@ -213,6 +262,80 @@ presenceToXML (Left p) streamLang = Element "presence" attribs nodes stanzaLang :: Maybe LangTag stanzaLang = stanzaLang' streamLang $ presenceErrorLangTag p + +-- Generates an XML element for a presence stanza. The language tag provided is +-- the default language of the stream. + +iqToXML :: IQ -> LangTag -> Element + +-- Request IQ. + +iqToXML (Left i) streamLang = Element "iq" attribs nodes + + where + + -- Has the stanza attributes and the IQ request type (`get' or `set'). + attribs :: [(Name, [Content])] + attribs = stanzaAttribs (iqRequestID i) (iqRequestFrom i) (iqRequestTo i) + stanzaLang ++ typeAttrib + + -- Has exactly one payload child element. + nodes :: [Node] + nodes = [NodeElement $ iqRequestPayload i] + + -- The stanza language tag, if it's different from the stream language tag. + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ iqRequestLangTag i + + -- The required type attribute. + typeAttrib :: [(Name, [Content])] + typeAttrib = [("type", [ContentText $ DT.pack $ show $ iqRequestType i])] + +-- Response result IQ. + +iqToXML (Right (Right i)) streamLang = Element "iq" attribs nodes + + where + + -- Has the stanza attributes and the IQ `result' type. + attribs :: [(Name, [Content])] + attribs = stanzaAttribs (iqResultID i) (iqResultFrom i) (iqResultTo i) + stanzaLang ++ typeAttrib + + -- Has one or zero payload child elements. + nodes :: [Node] + nodes = case iqResultPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] + + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ iqResultLangTag i + + -- The required type attribute. + typeAttrib :: [(Name, [Content])] + typeAttrib = [("type", [ContentText $ DT.pack "result"])] + +-- Response error IQ. + +iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes + + where + + -- Has the stanza attributes and the presence type. + attribs :: [(Name, [Content])] + attribs = stanzaAttribs (iqErrorID i) (iqErrorFrom i) (iqErrorTo i) stanzaLang ++ + typeAttrib + + -- Has the error element stanza as its child. + -- TODO: Include sender XML here? + nodes :: [Node] + nodes = [NodeElement $ errorElem streamLang stanzaLang $ iqErrorStanzaError i] + + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i + + typeAttrib :: [(Name, [Content])] + typeAttrib = [("type", [ContentText $ DT.pack "error"])] + + -- Creates the error element that is common for all stanzas. errorElem :: LangTag -> Maybe LangTag -> StanzaError -> Element @@ -290,20 +413,11 @@ childLang streamLang optLangTags langTags = reverse $ [streamLang] ++ (map fromJust $ filter (\ l -> isJust l) optLangTags) +-- Creates the attributes common for all stanzas. -iqToXML :: IQ -> Element - -iqToXML = iqToXML - - -messageToXML :: InternalMessage -> Element - -messageToXML = messageToXML - - -stanzaNodes :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] +stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] -stanzaNodes i f t l = if isJust $ i then [("id", [ContentText $ DT.pack $ show $ fromJust i])] else [] ++ +stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ DT.pack $ show $ fromJust i])] else [] ++ if isJust $ f then [("from", [ContentText $ DT.pack $ show $ fromJust f])] else [] ++ if isJust $ t then [("to", [ContentText $ DT.pack $ show $ fromJust t])] else [] ++ if isJust $ l then [("xml:lang", [ContentText $ DT.pack $ show l])] else [] diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index b59665e..132cbff 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -55,7 +55,8 @@ IQResult (..), IQRequestType (..), PresenceError (..), InternalPresence (..), -InternalMessage (..) +InternalMessage (..), +MessageError (..), ) where import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) @@ -155,7 +156,7 @@ data IQError = IQError { iqErrorID :: Maybe StanzaID , iqErrorTo :: Maybe To , iqErrorLangTag :: LangTag , iqErrorPayload :: Maybe Element - , iqErrorStanzaError :: Maybe StanzaError } + , iqErrorStanzaError :: StanzaError } deriving (Show) @@ -165,16 +166,16 @@ data IQError = IQError { iqErrorID :: Maybe StanzaID data Message = Message { messageID :: Maybe StanzaID , messageFrom :: Maybe From , messageTo :: Maybe To - , messageXMLLang :: LangTag + , messageLangTag :: LangTag , messageType :: MessageType , messagePayload :: [Element] } deriving (Show) -data MessageError = MessageError { messageErrorID :: StanzaID +data MessageError = MessageError { messageErrorID :: Maybe StanzaID , messageErrorFrom :: Maybe From , messageErrorTo :: Maybe To - , messageErrorXMLLang :: LangTag + , messageErrorLangTag :: LangTag , messageErrorPayload :: Maybe [Element] , messageErrorStanzaError :: StanzaError } deriving (Show)