add support for extended attributes

See RFC6120 §8.4
( http://xmpp.org/rfcs/rfc6120.html#stanzas-extended )

source/Network/Xmpp/Concurrent.hs

@@ -87,14 +87,15 @@ handleIQ iqHands out sta as = do
                 Nothing -> return . Just $ serviceUnavailable iq
                 Just ch -> do
                   sentRef <- newTMVar False
-                  let answerT answer = do
+                  let answerT answer attrs = do
-                          let IQRequest iqid from _to lang _tp bd = iq
+                          let IQRequest iqid from _to lang _tp bd _attrs = iq
                               response = case answer of
                                   Left er  -> IQErrorS $ IQError iqid Nothing
                                                                   from lang er
-                                                                  (Just bd)
+                                                                  (Just bd) attrs
                                   Right res -> IQResultS $ IQResult iqid Nothing
                                                                     from lang res
+                                                                    attrs
                           Ex.bracketOnError (atomically $ takeTMVar sentRef)
                                             (atomically .  tryPutTMVar sentRef)
                                             $ \wasSent -> do
@@ -114,8 +115,8 @@ handleIQ iqHands out sta as = do
                   writeTChan ch $ IQRequestTicket answerT iq as
                   return Nothing
         maybe (return ()) (void . out) res
-    serviceUnavailable (IQRequest iqid from _to lang _tp bd) =
+    serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) =
-        IQErrorS $ IQError iqid Nothing from lang err (Just bd)
+        IQErrorS $ IQError iqid Nothing from lang err (Just bd) []
     err = StanzaError Cancel ServiceUnavailable Nothing Nothing
 
     handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()

source/Network/Xmpp/Concurrent/IQ.hs

@@ -27,9 +27,10 @@ sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response
        -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for
                          -- default)
        -> Element -- ^ The IQ body (there has to be exactly one)
+       -> [ExtendedAttribute] -- ^ Additional stanza attributes
        -> Session
        -> IO (Either XmppFailure (STM (Maybe (Annotated IQResponse))))
-sendIQ timeOut to tp lang body session = do
+sendIQ timeOut to tp lang body attrs session = do
     newId <- idGenerator session
     j <- case to of
         Just t -> return $ Right t
@@ -40,7 +41,8 @@ sendIQ timeOut to tp lang body session = do
         (byNS, byId) <- readTVar (iqHandlers session)
         writeTVar (iqHandlers session) (byNS, Map.insert newId value byId)
         return resRef
-    res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session
+    res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body attrs)
+                      session
     case res of
         Right () -> do
             case timeOut of
@@ -64,10 +66,11 @@ sendIQA' :: Maybe Integer
          -> IQRequestType
          -> Maybe LangTag
          -> Element
+         -> [ExtendedAttribute]
          -> Session
          -> IO (Either IQSendError (Annotated IQResponse))
-sendIQA' timeout to tp lang body session = do
+sendIQA' timeout to tp lang body attrs session = do
-    ref <- sendIQ timeout to tp lang body session
+    ref <- sendIQ timeout to tp lang body attrs session
     either (return . Left . IQSendError) (fmap (maybe (Left IQTimeOut) Right)
                                      . atomically) ref
 
@@ -77,9 +80,11 @@ sendIQ' :: Maybe Integer
         -> IQRequestType
         -> Maybe LangTag
         -> Element
+        -> [ExtendedAttribute]
         -> Session
         -> IO (Either IQSendError IQResponse)
-sendIQ' timeout to tp lang body session = fmap fst <$> sendIQA' timeout to tp lang body session
+sendIQ' timeout to tp lang body attrs session =
+    fmap fst <$> sendIQA' timeout to tp lang body attrs session
 
 -- | Register your interest in inbound IQ stanzas of a specific type and
 -- namespace. The returned STM action yields the received, matching IQ stanzas.
@@ -130,5 +135,6 @@ unlistenIQ tp ns session = do
 -- (False is returned in that case)
 answerIQ :: IQRequestTicket
          -> Either StanzaError (Maybe Element)
+         -> [ExtendedAttribute]
          -> IO (Maybe (Either XmppFailure ()))
-answerIQ ticket = answerTicket ticket
+answerIQ = answerTicket

source/Network/Xmpp/Concurrent/Types.hs

@@ -151,6 +151,7 @@ data IQRequestTicket = IQRequestTicket
     {   -- | Send an answer to an IQ request once. Subsequent calls will do
         -- nothing and return Nothing
       answerTicket :: Either StanzaError (Maybe Element)
+                      -> [ExtendedAttribute]
                       -> IO (Maybe (Either XmppFailure ()))
       -- | The actual IQ request that created this ticket.
     , iqRequestBody :: IQRequest

source/Network/Xmpp/IM/Roster.hs

@@ -36,7 +36,7 @@ timeout = Just 3000000 -- 3 seconds
 rosterPush :: Item -> Session -> IO (Either IQSendError (Annotated IQResponse))
 rosterPush item session = do
     let el = pickleElem xpQuery (Query Nothing [fromItem item])
-    sendIQA' timeout Nothing Set Nothing el session
+    sendIQA' timeout Nothing Set Nothing el [] session
 
 -- | Add or update an item to the roster.
 --
@@ -55,7 +55,7 @@ rosterAdd j n gs session = do
                                             , qiSubscription = Nothing
                                             , qiGroups = nub gs
                                             }])
-    sendIQA' timeout Nothing Set Nothing el session
+    sendIQA' timeout Nothing Set Nothing el [] session
 
 -- | Remove an item from the roster. Return 'True' when the item is sucessfully
 -- removed or if it wasn't in the roster to begin with.
@@ -112,11 +112,11 @@ handleRoster ref out sta _ = case sta of
             Just Remove -> Map.delete (qiJid update) is
             _ -> Map.insert (qiJid update) (toItem update) is
 
-    badRequest (IQRequest iqid from _to lang _tp bd) =
+    badRequest (IQRequest iqid from _to lang _tp bd _attrs) =
-        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd)
+        IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) []
     errBR = StanzaError Cancel BadRequest Nothing Nothing
-    result (IQRequest iqid from _to lang _tp _bd) =
+    result (IQRequest iqid from _to lang _tp _bd _attrs) =
-        IQResultS $ IQResult iqid Nothing from lang Nothing
+        IQResultS $ IQResult iqid Nothing from lang Nothing []
 
 retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
 retrieveRoster mbOldRoster sess = do
@@ -128,6 +128,7 @@ retrieveRoster mbOldRoster sess = do
                 else Nothing
     res <- sendIQ' timeout Nothing Get Nothing
                    (pickleElem xpQuery (Query version []))
+                   []
                    sess
     case res of
         Left e -> do

source/Network/Xmpp/Marshal.hs

@@ -13,7 +13,9 @@ module Network.Xmpp.Marshal where
 import           Data.XML.Pickle
 import           Data.XML.Types
 
-import Data.Text
+import qualified Control.Exception as Ex
+import           Data.Text (Text)
+import qualified Data.Text as Text
 
 import           Network.Xmpp.Types
 
@@ -23,6 +25,16 @@ xpNonemptyText = ("xpNonemptyText" , "") <?+> xpWrap Nonempty fromNonempty xpTex
 xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
 xpStreamStanza = xpEither xpStreamError xpStanza
 
+xpExtendedAttrs :: PU [Attribute] [ExtendedAttribute]
+xpExtendedAttrs = ("xpAttrVerbatim" , "") <?+>
+                    xpIso (map (\(name, cs) -> (name, flattenContents cs)))
+                          (map (\(name, c) -> (name, [ContentText c])))
+  where
+    flattenContents = Text.concat . filterContentText
+    filterContentText = map (\c -> case c of
+        ContentText t -> t
+        ContentEntity{} -> Ex.throw UnresolvedEntityException )
+
 xpStanza :: PU [Node] Stanza
 xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel
     [ xpWrap IQRequestS     (\(IQRequestS     x) -> x) xpIQRequest
@@ -46,15 +58,16 @@ xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel
 
 xpMessage :: PU [Node] (Message)
 xpMessage = ("xpMessage" , "") <?+> xpWrap
-    (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)
+    (\((tp, qid, from, to, lang, attrs), ext) -> Message qid from to lang tp ext attrs)
-    (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))
+    (\(Message qid from to lang tp ext attrs) -> ((tp, qid, from, to, lang, attrs), ext))
     (xpElem "{jabber:client}message"
-         (xp5Tuple
+         (xp6Tuple
              (xpDefault Normal $ xpAttr "type" xpMessageType)
              (xpAttrImplied "id"   xpId)
              (xpAttrImplied "from" xpJid)
              (xpAttrImplied "to"   xpJid)
              xpLangTag
+             xpExtendedAttrs
              -- TODO: NS?
          )
          (xpAll xpElemVerbatim)
@@ -62,45 +75,54 @@ xpMessage = ("xpMessage" , "") <?+> xpWrap
 
 xpPresence :: PU [Node] Presence
 xpPresence = ("xpPresence" , "") <?+> xpWrap
-    (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)
+    (\((qid, from, to, lang, tp, attr), ext)
-    (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))
+        -> Presence qid from to lang tp ext attr)
+    (\(Presence qid from to lang tp ext attr)
+       -> ((qid, from, to, lang, tp, attr), ext))
     (xpElem "{jabber:client}presence"
-         (xp5Tuple
+         (xp6Tuple
               (xpAttrImplied "id"   xpId)
               (xpAttrImplied "from" xpJid)
               (xpAttrImplied "to"   xpJid)
               xpLangTag
               (xpDefault Available $ xpAttr "type" xpPresenceType)
+              xpExtendedAttrs
          )
          (xpAll xpElemVerbatim)
     )
 
 xpIQRequest :: PU [Node] IQRequest
 xpIQRequest = ("xpIQRequest" , "") <?+> xpWrap
-    (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body)
+    (\((qid, from, to, lang, tp, attr),body)
-    (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))
+       -> IQRequest qid from to lang tp body attr)
+    (\(IQRequest qid from to lang tp body attr)
+        -> ((qid, from, to, lang, tp, attr), body))
     (xpElem "{jabber:client}iq"
-         (xp5Tuple
+         (xp6Tuple
              (xpAttr        "id"   xpId)
              (xpAttrImplied "from" xpJid)
              (xpAttrImplied "to"   xpJid)
              xpLangTag
              ((xpAttr        "type" xpIQRequestType))
+             xpExtendedAttrs
          )
          xpElemVerbatim
     )
 
 xpIQResult :: PU [Node] IQResult
 xpIQResult = ("xpIQResult" , "") <?+> xpWrap
-    (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)
+    (\((qid, from, to, lang, _tp, attr),body)
-    (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))
+        -> IQResult qid from to lang body attr)
+    (\(IQResult qid from to lang body attr)
+        -> ((qid, from, to, lang, (), attr ), body))
     (xpElem "{jabber:client}iq"
-         (xp5Tuple
+         (xp6Tuple
              (xpAttr        "id"   xpId)
              (xpAttrImplied "from" xpJid)
              (xpAttrImplied "to"   xpJid)
              xpLangTag
              ((xpAttrFixed "type" "result"))
+             xpExtendedAttrs
          )
          (xpOption xpElemVerbatim)
     )
@@ -206,52 +228,54 @@ xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap
 
 xpMessageError :: PU [Node] (MessageError)
 xpMessageError = ("xpMessageError" , "") <?+> xpWrap
-    (\((_, qid, from, to, lang), (err, ext)) ->
+    (\((_, qid, from, to, lang, attr), (err, ext)) ->
-        MessageError qid from to lang err ext)
+        MessageError qid from to lang err ext attr)
-    (\(MessageError qid from to lang err ext) ->
+    (\(MessageError qid from to lang err ext attr) ->
-        (((), qid, from, to, lang), (err, ext)))
+        (((), qid, from, to, lang, attr), (err, ext)))
     (xpElem "{jabber:client}message"
-         (xp5Tuple
+         (xp6Tuple
               (xpAttrFixed   "type" "error")
               (xpAttrImplied "id"   xpId)
               (xpAttrImplied "from" xpJid)
               (xpAttrImplied "to"   xpJid)
               (xpAttrImplied xmlLang xpLang)
-              -- TODO: NS?
+              xpExtendedAttrs
          )
          (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
     )
 
 xpPresenceError :: PU [Node] PresenceError
 xpPresenceError = ("xpPresenceError" , "") <?+> xpWrap
-    (\((qid, from, to, lang, _),(err, ext)) ->
+    (\((qid, from, to, lang, _, attr),(err, ext)) ->
-        PresenceError qid from to lang err ext)
+        PresenceError qid from to lang err ext attr)
-    (\(PresenceError qid from to lang err ext) ->
+    (\(PresenceError qid from to lang err ext attr) ->
-        ((qid, from, to, lang, ()), (err, ext)))
+        ((qid, from, to, lang, (), attr), (err, ext)))
     (xpElem "{jabber:client}presence"
-         (xp5Tuple
+         (xp6Tuple
               (xpAttrImplied "id"   xpId)
               (xpAttrImplied "from" xpJid)
               (xpAttrImplied "to"   xpJid)
               xpLangTag
               (xpAttrFixed "type" "error")
+              xpExtendedAttrs
          )
          (xp2Tuple xpStanzaError (xpAll xpElemVerbatim))
     )
 
 xpIQError :: PU [Node] IQError
 xpIQError = ("xpIQError" , "") <?+> xpWrap
-    (\((qid, from, to, lang, _tp),(err, body)) ->
+    (\((qid, from, to, lang, _tp, attr),(err, body)) ->
-        IQError qid from to lang err body)
+        IQError qid from to lang err body attr)
-    (\(IQError qid from to lang err body) ->
+    (\(IQError qid from to lang err body attr) ->
-        ((qid, from, to, lang, ()), (err, body)))
+        ((qid, from, to, lang, (), attr), (err, body)))
     (xpElem "{jabber:client}iq"
-         (xp5Tuple
+         (xp6Tuple
               (xpAttr        "id"   xpId)
               (xpAttrImplied "from" xpJid)
               (xpAttrImplied "to"   xpJid)
               xpLangTag
               ((xpAttrFixed "type" "error"))
+              xpExtendedAttrs
          )
          (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
     )

source/Network/Xmpp/Stanza.hs

@@ -74,8 +74,8 @@ mkStanzaError condition = StanzaError (associatedErrorType condition)
 -- error type is derived from the condition using 'associatedErrorType' and
 -- both text and the application specific condition are left empty
 iqError :: StanzaErrorCondition -> IQRequest -> IQError
-iqError condition (IQRequest iqid from' _to lang' _tp _bd) =
+iqError condition (IQRequest iqid from' _to lang' _tp _bd _attr) =
-    IQError iqid Nothing from' lang' (mkStanzaError condition) Nothing
+    IQError iqid Nothing from' lang' (mkStanzaError condition) Nothing []
 
 
 -- | Create an IQ Result matching an IQ request
@@ -86,6 +86,7 @@ iqResult pl iqr = IQResult
               , iqResultTo   = view from iqr
               , iqResultLangTag = view lang iqr
               , iqResultPayload = pl
+              , iqResultAttributes = []
               }
 
 -- | The RECOMMENDED error type associated with an error condition. The

source/Network/Xmpp/Stream.hs

@@ -771,7 +771,7 @@ pushIQ :: Text
        -> IO (Either XmppFailure (Either IQError IQResult))
 pushIQ iqID to tp lang body stream = runErrorT $ do
     ErrorT $ pushStanza
-        (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream
+        (IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream
     res <- lift $ pullStanza stream
     case res of
         Left e -> throwError e

source/Network/Xmpp/Types.hs

@@ -25,6 +25,7 @@ module Network.Xmpp.Types
     , langTagFromText
     , langTagToText
     , parseLangTag
+    , ExtendedAttribute
     , Message(..)
     , message
     , MessageError(..)
@@ -89,7 +90,7 @@ import           Data.String (IsString, fromString)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Typeable(Typeable)
-import           Data.XML.Types
+import           Data.XML.Types as XML
 #if WITH_TEMPLATE_HASKELL
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Quote
@@ -138,6 +139,8 @@ data Stanza = IQRequestS     !IQRequest
             | PresenceErrorS !PresenceError
               deriving (Eq, Show)
 
+type ExtendedAttribute = (XML.Name, Text)
+
 -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as
 -- type. It always contains an xml payload.
 data IQRequest = IQRequest { iqRequestID      :: !Text
@@ -146,6 +149,7 @@ data IQRequest = IQRequest { iqRequestID      :: !Text
                            , iqRequestLangTag :: !(Maybe LangTag)
                            , iqRequestType    :: !IQRequestType
                            , iqRequestPayload :: !Element
+                           , iqRequestAttributes :: ![ExtendedAttribute]
                            } deriving (Eq, Show)
 
 -- | The type of IQ request that is made.
@@ -163,6 +167,7 @@ data IQResult = IQResult { iqResultID      :: !Text
                          , iqResultTo      :: !(Maybe Jid)
                          , iqResultLangTag :: !(Maybe LangTag)
                          , iqResultPayload :: !(Maybe Element)
+                         , iqResultAttributes :: ![ExtendedAttribute]
                          } deriving (Eq, Show)
 
 -- | The answer to an IQ request that generated an error.
@@ -172,6 +177,7 @@ data IQError = IQError { iqErrorID          :: !Text
                        , iqErrorLangTag     :: !(Maybe LangTag)
                        , iqErrorStanzaError :: !StanzaError
                        , iqErrorPayload     :: !(Maybe Element) -- should this be []?
+                       , iqErrorAttributes  :: ![ExtendedAttribute]
                        } deriving (Eq, Show)
 
 -- | The message stanza. Used for /push/ type communication.
@@ -181,6 +187,7 @@ data Message = Message { messageID      :: !(Maybe Text)
                        , messageLangTag :: !(Maybe LangTag)
                        , messageType    :: !MessageType
                        , messagePayload :: ![Element]
+                       , messageAttributes :: ![ExtendedAttribute]
                        } deriving (Eq, Show)
 
 -- | An empty message
@@ -201,6 +208,7 @@ message = Message { messageID      = Nothing
                   , messageLangTag = Nothing
                   , messageType    = Normal
                   , messagePayload = []
+                  , messageAttributes = []
                   }
 
 -- | Empty message stanza
@@ -219,6 +227,7 @@ data MessageError = MessageError { messageErrorID          :: !(Maybe Text)
                                  , messageErrorLangTag     :: !(Maybe LangTag)
                                  , messageErrorStanzaError :: !StanzaError
                                  , messageErrorPayload     :: ![Element]
+                                 , messageErrorAttributes  :: ![ExtendedAttribute]
                                  } deriving (Eq, Show)
 
 
@@ -266,6 +275,7 @@ data Presence = Presence { presenceID      :: !(Maybe Text)
                          , presenceLangTag :: !(Maybe LangTag)
                          , presenceType    :: !PresenceType
                          , presencePayload :: ![Element]
+                         , presenceAttributes :: ![ExtendedAttribute]
                          } deriving (Eq, Show)
 
 -- | An empty presence.
@@ -276,6 +286,7 @@ presence = Presence { presenceID       = Nothing
                     , presenceLangTag  = Nothing
                     , presenceType     = Available
                     , presencePayload  = []
+                    , presenceAttributes = []
                     }
 
 -- | Empty presence stanza
@@ -292,6 +303,7 @@ data PresenceError = PresenceError { presenceErrorID          :: !(Maybe Text)
                                    , presenceErrorLangTag     :: !(Maybe LangTag)
                                    , presenceErrorStanzaError :: !StanzaError
                                    , presenceErrorPayload     :: ![Element]
+                                   , presenceErrorAttributes  :: ![ExtendedAttribute]
                                    } deriving (Eq, Show)
 
 -- | @PresenceType@ holds Xmpp presence types. The "error" message type is left