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

@@ -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

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)
           )

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 "from" xpJid)
-             (xpAttrImplied "to"   xpPrim)
+             (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 "from" xpJid)
-              (xpAttrImplied "to"   xpPrim)
+              (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 "from" xpJid)
-             (xpAttrImplied "to"   xpPrim)
+             (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 "from" xpJid)
-             (xpAttrImplied "to"   xpPrim)
+             (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 "from" xpJid)
-              (xpAttrImplied "to"   xpPrim)
+              (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 "from" xpJid)
-              (xpAttrImplied "to"   xpPrim)
+              (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 "from" xpJid)
-              (xpAttrImplied "to"   xpPrim)
+              (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 "from" xpJid)
-         (xpAttrImplied "to" xpPrim)
+         (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 }

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' :: PU [Node] Jid
-    xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim)
+    xpJid' = xpBind $ xpElemNodes jidName (xpContent xpJid)
     jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"
 
 -- A `bind' element pickler.

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"

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)
+               } deriving (Eq, Ord, Show) -- A `Read' instance must validate.
 
-instance Show Jid where
+-- | Converts a JID to a Text.
-  show (Jid nd dmn res) =
+jidToText :: Jid -> String
-      maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++
+jidToText (Jid nd dmn res) =
+    (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++
         maybe "" (('/' :) . Text.unpack) res
 
-instance Read Jid where
+-- | Converts a JID to up to three Text values: (the optional) localpart, the
-  readsPrec _ x = case jidFromText (Text.pack x) of
+-- domainpart, and (the optional) resourcepart.
-      Nothing -> []
+jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)
-      Just j -> [(j,"")]
+jidToTexts (Jid nd dmn res) = (nd, dmn, res)
 
 instance IsString Jid where
   fromString = fromJust . jidFromText . Text.pack