From c534456767ac8641d8cbf484968381a2bfff4833 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 26 May 2013 13:32:32 +0200 Subject: [PATCH] Remove unsuitable `Read' instance for `Jid' The way I understand it, the `Show' and `Read' instances are for `String' representations that can be Haskell code. A proper `Show' instance of `Jid' would produce something like `Jid (Just "test") "example.com" Nothing'. A proper `Read' instance of `Jid' would parse something like that `String' value, and would stop parsing when completed. This patch automatically derives the `Show' instance from `Jid'. It also uses the previous `Show' instance to create a pretty printer, `jidToText'. It also provides a (trivial) `jidToTexts'. As an automatically derived `Read' instance could be used to create invalid `Jid' values and affect the correctness of applications using Pontarius XMPP, such a derivation has not been included. This required some changes in the `Jid' marshalling code, which assumed a `Read' instance. Since we provide `jidFromText', I'm assuming that no-one needs a `Read' instance of `Jid'. Fixes #24. --- source/Network/Xmpp.hs | 2 ++ source/Network/Xmpp/IM/Roster.hs | 2 +- source/Network/Xmpp/Marshal.hs | 38 ++++++++++++++++++-------------- source/Network/Xmpp/Sasl.hs | 6 ++--- source/Network/Xmpp/Stream.hs | 2 +- source/Network/Xmpp/Types.hs | 25 ++++++++++++--------- 6 files changed, 43 insertions(+), 32 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 0968b96..f6b7810 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -48,6 +48,8 @@ module Network.Xmpp , isFull , jidFromText , jidFromTexts + , jidToText + , jidToTexts , getJid -- * Stanzas -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 7658bc3..de62bb0 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -164,7 +164,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> (xpWrap isJust (\p -> if p then Just () else Nothing) $ xpOption $ xpAttribute_ "ask" "subscribe") - (xpAttribute "jid" xpPrim) + (xpAttribute "jid" xpJid) (xpAttribute' "name" xpText) (xpAttribute' "subscription" xpPrim) ) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index c88eeae..ff893da 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -47,8 +47,8 @@ xpMessage = ("xpMessage" , "") xpWrap (xp5Tuple (xpDefault Normal $ xpAttr "type" xpPrim) (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag -- TODO: NS? ) @@ -62,8 +62,8 @@ xpPresence = ("xpPresence" , "") xpWrap (xpElem "{jabber:client}presence" (xp5Tuple (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag (xpDefault Available $ xpAttr "type" xpPrim) ) @@ -77,8 +77,8 @@ xpIQRequest = ("xpIQRequest" , "") xpWrap (xpElem "{jabber:client}iq" (xp5Tuple (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag ((xpAttr "type" xpPrim)) ) @@ -92,8 +92,8 @@ xpIQResult = ("xpIQResult" , "") xpWrap (xpElem "{jabber:client}iq" (xp5Tuple (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag ((xpAttrFixed "type" "result")) ) @@ -141,8 +141,8 @@ xpMessageError = ("xpMessageError" , "") xpWrap (xp5Tuple (xpAttrFixed "type" "error") (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) (xpAttrImplied xmlLang xpPrim) -- TODO: NS? ) @@ -158,8 +158,8 @@ xpPresenceError = ("xpPresenceError" , "") xpWrap (xpElem "{jabber:client}presence" (xp5Tuple (xpAttrImplied "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag (xpAttrFixed "type" "error") ) @@ -175,8 +175,8 @@ xpIQError = ("xpIQError" , "") xpWrap (xpElem "{jabber:client}iq" (xp5Tuple (xpAttr "id" xpPrim) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) xpLangTag ((xpAttrFixed "type" "error")) ) @@ -239,8 +239,8 @@ xpStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (xp5Tuple (xpAttr "version" xpId) - (xpAttrImplied "from" xpPrim) - (xpAttrImplied "to" xpPrim) + (xpAttrImplied "from" xpJid) + (xpAttrImplied "to" xpJid) (xpAttrImplied "id" xpId) xpLangTag ) @@ -272,3 +272,9 @@ xpStreamFeatures = ("xpStreamFeatures","") xpWrap xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" (xpAll $ xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) + +xpJid :: PU Text Jid +xpJid = PU { unpickleTree = \input -> case jidFromText input of + Nothing -> UnpickleError $ ErrorMessage "Could not parse JID." + Just jid -> Result jid Nothing + , pickleTree = \input -> pack $ jidToText input } diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 00df024..4dbd19c 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -102,7 +102,7 @@ xmppBind rsrc c = runErrorT $ do case answer of Right IQResult{iqResultPayload = Just b} -> do lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." - let jid = unpickleElem xpJid b + let jid = unpickleElem xpJid' b case jid of Right jid' -> do lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid' @@ -120,8 +120,8 @@ xmppBind rsrc c = runErrorT $ do throwError XmppOtherFailure where -- Extracts the character data in the `jid' element. - xpJid :: PU [Node] Jid - xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) + xpJid' :: PU [Node] Jid + xpJid' = xpBind $ xpElemNodes jidName (xpContent xpJid) jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" -- A `bind' element pickler. diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 6bc9832..6535fb5 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -200,7 +200,7 @@ startStream = runErrorT $ do let to' = lookup "to" children ver' = lookup "version" children xl = lookup xmlLang children - in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') -> + in case () of () | Just Nothing == fmap jidFromText to' -> runErrorT $ closeStreamWithError StreamBadNamespacePrefix Nothing "stream to not a valid JID" diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index d93bb70..f74476e 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -47,6 +47,8 @@ module Network.Xmpp.Types , isFull , jidFromText , jidFromTexts + , jidToText + , jidToTexts , StreamEnd(..) , InvalidXmppXml(..) , SessionConfiguration(..) @@ -886,17 +888,18 @@ data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed -- the entity associated with an XMPP localpart at a domain -- (i.e., @localpart\@domainpart/resourcepart@). , resourcepart :: !(Maybe Text) - } deriving (Eq, Ord) - -instance Show Jid where - show (Jid nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ - maybe "" (('/' :) . Text.unpack) res - -instance Read Jid where - readsPrec _ x = case jidFromText (Text.pack x) of - Nothing -> [] - Just j -> [(j,"")] + } deriving (Eq, Ord, Show) -- A `Read' instance must validate. + +-- | Converts a JID to a Text. +jidToText :: Jid -> String +jidToText (Jid nd dmn res) = + (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +-- | Converts a JID to up to three Text values: (the optional) localpart, the +-- domainpart, and (the optional) resourcepart. +jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text) +jidToTexts (Jid nd dmn res) = (nd, dmn, res) instance IsString Jid where fromString = fromJust . jidFromText . Text.pack