diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index 2105b03..99f420f 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -636,7 +636,7 @@ processEvent e = get >>= \ state -> put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } Nothing -> return () - let xml = presenceToXML $ Right presence' + let xml = presenceToXML (Right presence') (fromJust $ langTag "en") lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx return Nothing diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs index 0e66961..935fef0 100644 --- a/Network/XMPP/Stanza.hs +++ b/Network/XMPP/Stanza.hs @@ -70,13 +70,13 @@ iqTo (Right res) = iqResponseTo res -- | -- Returns the @XMLLang@ value of the @IQ@, if any. -iqLangTag :: IQ -> Maybe LangTag +iqLangTag :: IQ -> LangTag iqLangTag (Left req) = iqRequestLangTag req iqLangTag (Right res) = iqResponseLangTag res -iqResponseLangTag :: IQResponse -> Maybe LangTag +iqResponseLangTag :: IQResponse -> LangTag iqResponseLangTag (Left err) = iqErrorLangTag err iqResponseLangTag (Right res) = iqResultLangTag res diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index 8f0cefa..5418e29 100644 --- a/Network/XMPP/Stream.hs +++ b/Network/XMPP/Stream.hs @@ -169,29 +169,126 @@ counter c (Just (EventEndElement _) ) = (c - 1) counter c _ = c -presenceToXML :: InternalPresence -> Element +-- Sending stanzas is done through functions, where LangTag is Maybe. -presenceToXML (Right p) = Element "presence" attribs nodes + +-- Generates an XML element for a presence stanza. The language tag provided is +-- the default language of the stream. + +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) (presenceLangTag p) ++ + attribs = stanzaNodes (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ [("type", [ContentText $ DT.pack $ show $ presenceType p])] + -- Has an arbitrary number of elements as children. nodes :: [Node] nodes = map (\ x -> NodeElement x) (presencePayload p) -presenceToXML (Left p) = Element "presence" attribs nodes + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ presenceLangTag p + +-- 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) (presenceErrorLangTag p) ++ - [("type", [ContentText $ DT.pack "error"])] + attribs = stanzaNodes (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) + stanzaLang ++ [("type", [ContentText $ DT.pack "error"])] + -- Has the error element stanza as its child. + -- TODO: Include sender XML here? nodes :: [Node] - nodes = case presenceErrorPayload p of - Just elem -> map (\ x -> NodeElement x) elem - Nothing -> [] + nodes = [NodeElement $ errorElem streamLang stanzaLang $ presenceErrorStanzaError p] + + -- The stanza language tag, if it's different from the stream language tag. + stanzaLang :: Maybe LangTag + stanzaLang = stanzaLang' streamLang $ presenceErrorLangTag p + +-- Creates the error element that is common for all stanzas. + +errorElem :: LangTag -> Maybe LangTag -> StanzaError -> Element + +errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib + ([defCondElem] ++ textElem ++ appSpecCondElem) + + where + + -- The required stanza error type. + typeAttrib :: [(Name, [Content])] + typeAttrib = [("type", [ContentText $ DT.pack $ show $ stanzaErrorType stanzaError])] + + -- The required defined condition element. + defCondElem :: Node + defCondElem = NodeElement $ Element (Name (DT.pack $ show $ stanzaErrorCondition stanzaError) (Just $ DT.pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] [] + + + -- The optional text element. + textElem :: [Node] + textElem = case stanzaErrorText stanzaError of + Nothing -> [] + Just (textLang, text) -> + [NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text" + (langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError]) + [NodeContent $ ContentText $ DT.pack text]] + + -- The optional application specific condition element. + appSpecCondElem :: [Node] + appSpecCondElem = case stanzaErrorApplicationSpecificCondition stanzaError of + Nothing -> [] + Just elem -> [NodeElement elem] + + +-- Generates the element attribute for an optional language tag. + +langTagAttrib :: Maybe LangTag -> [(Name, [Content])] + +langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ DT.pack $ show lang'])] + + +stanzaLang' :: LangTag -> LangTag -> Maybe LangTag + +stanzaLang' streamLang stanzaLang | streamLang == stanzaLang = Nothing + | otherwise = Just stanzaLang + + +-- Finds the language tag to set on the current element, if any. Makes sure that +-- language tags are not repeated unnecessarily (like on a child element, when +-- the parent has it). The first parameter is the stream language tag, and the +-- list of optional language tags are ordered in their XML element child +-- sequence, parent first, starting with the stanza language tag. + +childLang :: LangTag -> [Maybe LangTag] -> Maybe LangTag + +childLang streamLang optLangTags + + -- The current element does not have a language tag - set nothing. + | (head $ reverse optLangTags) == Nothing = Nothing + + -- All optional language tags are Nothing - set nothing. + | length langTags == 1 = Nothing + + -- The language tag of this element is the same as the closest parent with a + -- language tag - set nothing. + | (head langTags) == (head $ tail langTags) = Nothing + + -- Set the language tag. + | otherwise = Just $ head langTags + + where + + -- Contains the chain of language tags in descending priority order. + -- Contains at least one element - the stream language tag. + langTags = reverse $ [streamLang] ++ (map fromJust $ filter (\ l -> isJust l) optLangTags) + iqToXML :: IQ -> Element diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index 8f69e43..b59665e 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -130,7 +130,7 @@ type IQ = Either IQRequest IQResponse data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID , iqRequestFrom :: Maybe From , iqRequestTo :: Maybe To - , iqRequestLangTag :: Maybe LangTag + , iqRequestLangTag :: LangTag , iqRequestType :: IQRequestType , iqRequestPayload :: Element } deriving (Show) @@ -145,7 +145,7 @@ type IQResponse = Either IQError IQResult data IQResult = IQResult { iqResultID :: Maybe StanzaID , iqResultFrom :: Maybe From , iqResultTo :: Maybe To - , iqResultLangTag :: Maybe LangTag + , iqResultLangTag :: LangTag , iqResultPayload :: Maybe Element } deriving (Show) @@ -153,7 +153,7 @@ data IQResult = IQResult { iqResultID :: Maybe StanzaID data IQError = IQError { iqErrorID :: Maybe StanzaID , iqErrorFrom :: Maybe From , iqErrorTo :: Maybe To - , iqErrorLangTag :: Maybe LangTag + , iqErrorLangTag :: LangTag , iqErrorPayload :: Maybe Element , iqErrorStanzaError :: Maybe StanzaError } deriving (Show) @@ -165,7 +165,7 @@ data IQError = IQError { iqErrorID :: Maybe StanzaID data Message = Message { messageID :: Maybe StanzaID , messageFrom :: Maybe From , messageTo :: Maybe To - , messageXMLLang :: Maybe LangTag + , messageXMLLang :: LangTag , messageType :: MessageType , messagePayload :: [Element] } deriving (Show) @@ -174,7 +174,7 @@ data Message = Message { messageID :: Maybe StanzaID data MessageError = MessageError { messageErrorID :: StanzaID , messageErrorFrom :: Maybe From , messageErrorTo :: Maybe To - , messageErrorXMLLang :: Maybe LangTag + , messageErrorXMLLang :: LangTag , messageErrorPayload :: Maybe [Element] , messageErrorStanzaError :: StanzaError } deriving (Show) @@ -208,7 +208,7 @@ instance Show MessageType where data Presence = Presence { presenceID :: Maybe StanzaID , presenceFrom :: Maybe From , presenceTo :: Maybe To - , presenceLangTag :: Maybe LangTag + , presenceLangTag :: LangTag , presenceType :: Maybe PresenceType , presencePayload :: [Element] } deriving (Show) @@ -217,7 +217,7 @@ data Presence = Presence { presenceID :: Maybe StanzaID data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID , presenceErrorFrom :: Maybe From , presenceErrorTo :: Maybe To - , presenceErrorLangTag :: Maybe LangTag + , presenceErrorLangTag :: LangTag , presenceErrorPayload :: Maybe [Element] , presenceErrorStanzaError :: StanzaError } deriving (Show) @@ -254,9 +254,11 @@ instance Show PresenceType where -- stream looks like . These errors are -- wrapped in the @StanzaError@ type. +-- Sender XML is optional and is not included. + data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition - , stanzaErrorText :: Maybe String + , stanzaErrorText :: Maybe (Maybe LangTag, String) , stanzaErrorApplicationSpecificCondition :: Maybe Element } deriving (Eq, Show) @@ -269,7 +271,15 @@ data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry Modify | -- ^ Change the data and retry Auth | -- ^ Provide credentials and retry Wait -- ^ Error is temporary - wait and retry - deriving (Eq, Show) + deriving (Eq) + + +instance Show StanzaErrorType where + show Cancel = "cancel" + show Continue = "continue" + show Modify = "modify" + show Auth = "auth" + show Wait = "wait" -- | @@ -311,7 +321,32 @@ data StanzaErrorCondition = BadRequest | -- ^ Malformed XML UndefinedCondition | -- ^ Application-specific -- condition UnexpectedRequest -- ^ Badly timed request - deriving (Eq, Show) + deriving (Eq) + + +instance Show StanzaErrorCondition where + show BadRequest = "bad-request" + show Conflict = "conflict" + show FeatureNotImplemented = "feature-not-implemented" + show Forbidden = "forbidden" + show Gone = "gone" + show InternalServerError = "internal-server-error" + show ItemNotFound = "item-not-found" + show JIDMalformed = "jid-malformed" + show NotAcceptable = "not-acceptable" + show NotAllowed = "not-allowed" + show NotAuthorized = "not-authorized" + show PaymentRequired = "payment-required" + show RecipientUnavailable = "recipient-unavailable" + show Redirect = "redirect" + show RegistrationRequired = "registration-required" + show RemoteServerNotFound = "remote-server-not-found" + show RemoteServerTimeout = "remote-server-timeout" + show ResourceConstraint = "resource-constraint" + show ServiceUnavailable = "service-unavailable" + show SubscriptionRequired = "subscription-required" + show UndefinedCondition = "undefined-condition" + show UnexpectedRequest = "unexpected-request" diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs index c056e66..3112f5b 100644 --- a/Network/XMPP/Utilities.hs +++ b/Network/XMPP/Utilities.hs @@ -11,15 +11,18 @@ {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.Utilities ( elementToString - , elementsToString, testElement ) where + , elementsToString ) where import Prelude hiding (concat) import Data.ByteString (ByteString, concat) import Data.ByteString.Char8 (unpack) + import Data.Enumerator (($$), Stream (Chunks), Enumerator, Step (Continue), joinI, run_, returnI) import Data.Enumerator.List (consume) + import Data.XML.Types (Document (..), Element (..), Event (..), Name (..), Prologue (..)) + import Text.XML.Enumerator.Render (renderBytes) import Text.XML.Enumerator.Document (toEvents)