Replace additional `xpPrim' calls

Moved and started using `xpSaslError'.
Added `xpShow' and `xpPriority'.

source/Network/Xmpp/IM/Presence.hs

@@ -13,20 +13,7 @@ import Network.Xmpp.Types
 data ShowStatus = StatusAway
                 | StatusChat
                 | StatusDnd
-                | StatusXa
+                | StatusXa deriving (Read, Show)
-
-instance Show ShowStatus where
-    show StatusAway = "away"
-    show StatusChat = "chat"
-    show StatusDnd  = "dnd"
-    show StatusXa   = "xa"
-
-instance Read ShowStatus where
-    readsPrec _ "away" = [(StatusAway, "")]
-    readsPrec _ "chat" = [(StatusChat, "")]
-    readsPrec _ "dnd"  = [(StatusDnd , "")]
-    readsPrec _ "xa"   = [(StatusXa  , "")]
-    readsPrec _ _      = []
 
 data IMPresence = IMP { showStatus :: Maybe ShowStatus
                       , status     :: Maybe Text
@@ -65,8 +52,25 @@ xpIMPresence = xpUnliftElems .
                xpClean $
                xp3Tuple
                   (xpOption $ xpElemNodes "{jabber:client}show"
-                     (xpContent xpPrim))
+                     (xpContent xpShow))
                   (xpOption $ xpElemNodes "{jabber:client}status"
                      (xpContent xpText))
                   (xpOption $ xpElemNodes "{jabber:client}priority"
                      (xpContent xpPrim))
+
+xpShow :: PU Text ShowStatus
+xpShow = ("xpShow", "") <?>
+        xpPartial ( \input -> case showStatusFromText input of
+                                   Nothing -> Left "Could not parse show status."
+                                   Just j -> Right j)
+                  showStatusToText
+  where
+    showStatusFromText "away" = Just StatusAway
+    showStatusFromText "chat" = Just StatusChat
+    showStatusFromText "dnd" = Just StatusDnd
+    showStatusFromText "xa" = Just StatusXa
+    showStatusFromText _ = Nothing
+    showStatusToText StatusAway = "away"
+    showStatusToText StatusChat = "chat"
+    showStatusToText StatusDnd = "dnd"
+    showStatusToText StatusXa = "xa"

source/Network/Xmpp/IM/Roster.hs

@@ -177,7 +177,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) ->
                      xpOption $ xpAttribute_ "ask" "subscribe")
             (xpAttribute  "jid" xpJid)
             (xpAttribute' "name" xpText)
-            (xpAttribute' "subscription" xpPrim)
+            (xpAttribute' "subscription" xpSubscription)
           )
           (xpFindMatches $ xpElemText "{jabber:iq:roster}group")
 
@@ -187,3 +187,22 @@ xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ )
           xpElem "{jabber:iq:roster}query"
             (xpAttribute' "ver" xpText)
             xpItems
+
+xpSubscription :: PU Text Subscription
+xpSubscription = ("xpSubscription", "") <?>
+        xpPartial ( \input -> case subscriptionFromText input of
+                                   Nothing -> Left "Could not parse subscription."
+                                   Just j -> Right j)
+                  subscriptionToText
+  where
+    subscriptionFromText "none" = Just None
+    subscriptionFromText "to" = Just To
+    subscriptionFromText "from" = Just From
+    subscriptionFromText "both" = Just Both
+    subscriptionFromText "remove" = Just Remove
+    subscriptionFromText _ = Nothing
+    subscriptionToText None = "none"
+    subscriptionToText To = "to"
+    subscriptionToText From = "from"
+    subscriptionToText Both = "both"
+    subscriptionToText Remove = "remove"

source/Network/Xmpp/IM/Roster/Types.hs

@@ -4,22 +4,7 @@ import qualified Data.Map as Map
 import           Data.Text (Text)
 import           Network.Xmpp.Types
 
-data Subscription = None | To | From | Both | Remove deriving Eq
+data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show)
-
-instance Show Subscription where
-    show None = "none"
-    show To   = "to"
-    show From = "from"
-    show Both = "both"
-    show Remove = "remove"
-
-instance Read Subscription where
-    readsPrec _ "none" = [(None ,"")]
-    readsPrec _ "to"   = [(To   ,"")]
-    readsPrec _ "from" = [(From ,"")]
-    readsPrec _ "both" = [(Both ,"")]
-    readsPrec _ "remove" = [(Remove ,"")]
-    readsPrec _ _ = []
 
 data Roster = Roster { ver :: Maybe Text
                      , items :: Map.Map Jid Item } deriving Show

source/Network/Xmpp/Marshal.hs

@@ -427,36 +427,6 @@ xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") <?>
     stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest
     stanzaErrorConditionFromText _ = Nothing
 
-xpSaslError :: PU Text SaslError
-xpSaslError = ("xpSaslError", "") <?>
-        xpPartial ( \input -> case saslErrorFromText input of
-                                   Nothing -> Left "Could not parse SASL error."
-                                   Just j -> Right j)
-                  saslErrorToText
-  where
-    saslErrorToText SaslAborted              = "aborted"
-    saslErrorToText SaslAccountDisabled      = "account-disabled"
-    saslErrorToText SaslCredentialsExpired   = "credentials-expired"
-    saslErrorToText SaslEncryptionRequired   = "encryption-required"
-    saslErrorToText SaslIncorrectEncoding    = "incorrect-encoding"
-    saslErrorToText SaslInvalidAuthzid       = "invalid-authzid"
-    saslErrorToText SaslInvalidMechanism     = "invalid-mechanism"
-    saslErrorToText SaslMalformedRequest     = "malformed-request"
-    saslErrorToText SaslMechanismTooWeak     = "mechanism-too-weak"
-    saslErrorToText SaslNotAuthorized        = "not-authorized"
-    saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"
-    saslErrorFromText "aborted" = Just SaslAborted
-    saslErrorFromText "account-disabled" = Just SaslAccountDisabled
-    saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired
-    saslErrorFromText "encryption-required" = Just SaslEncryptionRequired
-    saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding
-    saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid
-    saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism
-    saslErrorFromText "malformed-request" = Just SaslMalformedRequest
-    saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak
-    saslErrorFromText "not-authorized" = Just SaslNotAuthorized
-    saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure
-
 xpStreamErrorCondition :: PU Text StreamErrorCondition
 xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>
         xpPartial ( \input -> case streamErrorConditionFromText input of

source/Network/Xmpp/Sasl/Common.hs

@@ -80,10 +80,40 @@ xpFailure = xpWrap
                   (xpContent xpId))
         (xpElemByNamespace
              "urn:ietf:params:xml:ns:xmpp-sasl"
-             xpPrim
+             xpSaslError
              (xpUnit)
              (xpUnit))))
 
+xpSaslError :: PU Text.Text SaslError
+xpSaslError = ("xpSaslError", "") <?>
+        xpPartial ( \input -> case saslErrorFromText input of
+                                   Nothing -> Left "Could not parse SASL error."
+                                   Just j -> Right j)
+                  saslErrorToText
+  where
+    saslErrorToText SaslAborted              = "aborted"
+    saslErrorToText SaslAccountDisabled      = "account-disabled"
+    saslErrorToText SaslCredentialsExpired   = "credentials-expired"
+    saslErrorToText SaslEncryptionRequired   = "encryption-required"
+    saslErrorToText SaslIncorrectEncoding    = "incorrect-encoding"
+    saslErrorToText SaslInvalidAuthzid       = "invalid-authzid"
+    saslErrorToText SaslInvalidMechanism     = "invalid-mechanism"
+    saslErrorToText SaslMalformedRequest     = "malformed-request"
+    saslErrorToText SaslMechanismTooWeak     = "mechanism-too-weak"
+    saslErrorToText SaslNotAuthorized        = "not-authorized"
+    saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"
+    saslErrorFromText "aborted" = Just SaslAborted
+    saslErrorFromText "account-disabled" = Just SaslAccountDisabled
+    saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired
+    saslErrorFromText "encryption-required" = Just SaslEncryptionRequired
+    saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding
+    saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid
+    saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism
+    saslErrorFromText "malformed-request" = Just SaslMalformedRequest
+    saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak
+    saslErrorFromText "not-authorized" = Just SaslNotAuthorized
+    saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure
+
 -- Challenge element pickler.
 xpChallenge :: PU [Node] (Maybe Text.Text)
 xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"