made a nice function to convert an internal presence to an xml element, including presence errors

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
 

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

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) ++
+        attribs = stanzaNodes (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p)
-                  [("type", [ContentText $ DT.pack "error"])]
+                  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
+        nodes = [NodeElement $ errorElem streamLang stanzaLang $ presenceErrorStanzaError p]
-                    Just elem -> map (\ x -> NodeElement x) elem
+
-                    Nothing -> []
+        -- 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

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 <stanza-kind to='sender' type='error'>. 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"
 
 
 

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)