From 4bb213688b6ccd4789e577e3593d284fdde7006a Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 6 Mar 2014 15:59:38 +0100 Subject: [PATCH] add support for extended attributes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit See RFC6120 ยง8.4 ( http://xmpp.org/rfcs/rfc6120.html#stanzas-extended ) --- source/Network/Xmpp/Concurrent.hs | 11 ++-- source/Network/Xmpp/Concurrent/IQ.hs | 30 +++++---- source/Network/Xmpp/Concurrent/Types.hs | 1 + source/Network/Xmpp/IM/Roster.hs | 13 ++-- source/Network/Xmpp/Marshal.hs | 88 ++++++++++++++++--------- source/Network/Xmpp/Stanza.hs | 5 +- source/Network/Xmpp/Stream.hs | 2 +- source/Network/Xmpp/Types.hs | 14 +++- 8 files changed, 105 insertions(+), 59 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index c176877..124409f 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/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 IQRequest iqid from _to lang _tp bd = iq + let answerT answer attrs = do + 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) = - IQErrorS $ IQError iqid Nothing from lang err (Just bd) + serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) = + IQErrorS $ IQError iqid Nothing from lang err (Just bd) [] err = StanzaError Cancel ServiceUnavailable Nothing Nothing handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO () diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 38a7e9b..68a755f 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/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 @@ -60,14 +62,15 @@ sendIQ timeOut to tp lang body session = do -- | Like 'sendIQ', but waits for the answer IQ. sendIQA' :: Maybe Integer - -> Maybe Jid - -> IQRequestType - -> Maybe LangTag - -> Element - -> Session - -> IO (Either IQSendError (Annotated IQResponse)) -sendIQA' timeout to tp lang body session = do - ref <- sendIQ timeout to tp lang body session + -> Maybe Jid + -> IQRequestType + -> Maybe LangTag + -> Element + -> [ExtendedAttribute] + -> Session + -> IO (Either IQSendError (Annotated IQResponse)) +sendIQA' timeout to tp lang body attrs session = do + 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 diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 1cc670a..10b72d1 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/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 diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index d50e16b..4abdeaa 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/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) = - IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) + badRequest (IQRequest iqid from _to lang _tp bd _attrs) = + IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) [] errBR = StanzaError Cancel BadRequest Nothing Nothing - result (IQRequest iqid from _to lang _tp _bd) = - IQResultS $ IQResult iqid Nothing from lang Nothing + result (IQRequest iqid from _to lang _tp _bd _attrs) = + 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 diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 2c9ea01..0a9eadb 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -10,12 +10,14 @@ module Network.Xmpp.Marshal where -import Data.XML.Pickle -import Data.XML.Types +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 +import Network.Xmpp.Types xpNonemptyText :: PU Text NonemptyText xpNonemptyText = ("xpNonemptyText" , "") xpWrap Nonempty fromNonempty xpText @@ -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) - (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) + (\((tp, qid, from, to, lang, attrs), ext) -> Message qid from to lang tp ext attrs) + (\(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) - (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) + (\((qid, from, to, lang, tp, attr), 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) - (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) + (\((qid, from, to, lang, tp, attr),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) - (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) + (\((qid, from, to, lang, _tp, attr),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)) -> - MessageError qid from to lang err ext) - (\(MessageError qid from to lang err ext) -> - (((), qid, from, to, lang), (err, ext))) + (\((_, qid, from, to, lang, attr), (err, ext)) -> + MessageError qid from to lang err ext attr) + (\(MessageError qid from to lang err ext attr) -> + (((), 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)) -> - PresenceError qid from to lang err ext) - (\(PresenceError qid from to lang err ext) -> - ((qid, from, to, lang, ()), (err, ext))) + (\((qid, from, to, lang, _, attr),(err, ext)) -> + PresenceError qid from to lang err ext attr) + (\(PresenceError qid from to lang err ext attr) -> + ((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)) -> - IQError qid from to lang err body) - (\(IQError qid from to lang err body) -> - ((qid, from, to, lang, ()), (err, body))) + (\((qid, from, to, lang, _tp, attr),(err, body)) -> + IQError qid from to lang err body attr) + (\(IQError qid from to lang err body attr) -> + ((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)) ) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs index 3b7019d..a7c6b16 100644 --- a/source/Network/Xmpp/Stanza.hs +++ b/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 iqid Nothing from' lang' (mkStanzaError condition) Nothing +iqError condition (IQRequest iqid from' _to lang' _tp _bd _attr) = + 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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index d465f31..7f0723f 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index c62b5bc..8f87eab 100644 --- a/source/Network/Xmpp/Types.hs +++ b/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