diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 0f0ba03..82077ac 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -13,20 +13,7 @@ import Network.Xmpp.Types data ShowStatus = StatusAway | StatusChat | StatusDnd - | StatusXa - -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 _ _ = [] + | StatusXa deriving (Read, Show) 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" diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 6933543..771d69e 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/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" diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs index b5de0ef..c3af358 100644 --- a/source/Network/Xmpp/IM/Roster/Types.hs +++ b/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 - -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 Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show) data Roster = Roster { ver :: Maybe Text , items :: Map.Map Jid Item } deriving Show diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index a7ff049..c21c975 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/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 diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index fb15668..0687bd1 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/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"