diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index a08a972..f230e8f 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -171,7 +171,9 @@ module Network.Xmpp -- * Threads , dupSession -- * Miscellaneous - , LangTag(..) + , LangTag + , langTagFromText + , langTagToText , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index f594783..a7ff049 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -47,8 +47,8 @@ xpMessage = ("xpMessage" , "") xpWrap (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) (xpElem "{jabber:client}message" (xp5Tuple - (xpDefault Normal $ xpAttr "type" xpPrim) - (xpAttrImplied "id" xpPrim) + (xpDefault Normal $ xpAttr "type" xpMessageType) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -63,11 +63,11 @@ xpPresence = ("xpPresence" , "") xpWrap (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag - (xpDefault Available $ xpAttr "type" xpPrim) + (xpDefault Available $ xpAttr "type" xpPresenceType) ) (xpAll xpElemVerbatim) ) @@ -78,11 +78,11 @@ xpIQRequest = ("xpIQRequest" , "") xpWrap (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag - ((xpAttr "type" xpPrim)) + ((xpAttr "type" xpIQRequestType)) ) xpElemVerbatim ) @@ -93,7 +93,7 @@ xpIQResult = ("xpIQResult" , "") xpWrap (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -112,7 +112,7 @@ xpErrorCondition = ("xpErrorCondition" , "") xpWrap (\cond -> (cond, (), ())) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-stanzas" - xpPrim + xpStanzaErrorCondition xpUnit xpUnit ) @@ -122,11 +122,11 @@ xpStanzaError = ("xpStanzaError" , "") xpWrap (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (xpElem "{jabber:client}error" - (xpAttr "type" xpPrim) + (xpAttr "type" xpStanzaErrorType) (xp3Tuple xpErrorCondition (xpOption $ xpElem "{jabber:client}text" - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied xmlLang xpLang) (xpContent xpId) ) (xpOption xpElemVerbatim) @@ -142,10 +142,10 @@ xpMessageError = ("xpMessageError" , "") xpWrap (xpElem "{jabber:client}message" (xp5Tuple (xpAttrFixed "type" "error") - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) - (xpAttrImplied xmlLang xpPrim) + (xpAttrImplied xmlLang xpLang) -- TODO: NS? ) (xp2Tuple xpStanzaError (xpAll xpElemVerbatim)) @@ -159,7 +159,7 @@ xpPresenceError = ("xpPresenceError" , "") xpWrap ((qid, from, to, lang, ()), (err, ext))) (xpElem "{jabber:client}presence" (xp5Tuple - (xpAttrImplied "id" xpPrim) + (xpAttrImplied "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -176,7 +176,7 @@ xpIQError = ("xpIQError" , "") xpWrap ((qid, from, to, lang, ()), (err, body))) (xpElem "{jabber:client}iq" (xp5Tuple - (xpAttr "id" xpPrim) + (xpAttr "id" xpStanzaID) (xpAttrImplied "from" xpJid) (xpAttrImplied "to" xpJid) xpLangTag @@ -198,7 +198,7 @@ xpStreamError = ("xpStreamError" , "") xpWrap (xp3Tuple (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-streams" - xpPrim + xpStreamErrorCondition xpUnit xpUnit ) @@ -212,7 +212,14 @@ xpStreamError = ("xpStreamError" , "") xpWrap ) xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim +xpLangTag = xpAttrImplied xmlLang xpLang + +xpLang :: PU Text LangTag +xpLang = ("xpLang", "") + xpPartial ( \input -> case langTagFromText input of + Nothing -> Left "Could not parse language tag." + Just j -> Right j) + langTagToText xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") @@ -284,3 +291,227 @@ xpJid = ("xpJid", "") Nothing -> Left "Could not parse JID." Just j -> Right j) jidToText + +xpStanzaID :: PU Text StanzaID +xpStanzaID = ("xpStanzaID", "") + xpPartial ( \input -> case stanzaIDFromText input of + Nothing -> Left "Could not parse StanzaID." + Just j -> Right j) + stanzaIDToText + where + stanzaIDFromText t = Just $ StanzaID t + stanzaIDToText (StanzaID s) = s + +xpIQRequestType :: PU Text IQRequestType +xpIQRequestType = ("xpIQRequestType", "") + xpPartial ( \input -> case iqRequestTypeFromText input of + Nothing -> Left "Could not parse IQ request type." + Just j -> Right j) + iqRequestTypeToText + where + iqRequestTypeFromText "get" = Just Get + iqRequestTypeFromText "set" = Just Set + iqRequestTypeFromText _ = Nothing + iqRequestTypeToText Get = "get" + iqRequestTypeToText Set = "set" + +xpMessageType :: PU Text MessageType +xpMessageType = ("xpMessageType", "") + xpPartial ( \input -> case messageTypeFromText input of + Nothing -> Left "Could not parse message type." + Just j -> Right j) + messageTypeToText + where + messageTypeFromText "chat" = Just Chat + messageTypeFromText "groupchat" = Just GroupChat + messageTypeFromText "headline" = Just Headline + messageTypeFromText "normal" = Just Normal + messageTypeFromText _ = Just Normal + messageTypeToText Chat = "chat" + messageTypeToText GroupChat = "groupchat" + messageTypeToText Headline = "headline" + messageTypeToText Normal = "normal" + +xpPresenceType :: PU Text PresenceType +xpPresenceType = ("xpPresenceType", "") + xpPartial ( \input -> case presenceTypeFromText input of + Nothing -> Left "Could not parse presence type." + Just j -> Right j) + presenceTypeToText + where + presenceTypeFromText "" = Just Available + presenceTypeFromText "available" = Just Available + presenceTypeFromText "unavailable" = Just Unavailable + presenceTypeFromText "subscribe" = Just Subscribe + presenceTypeFromText "subscribed" = Just Subscribed + presenceTypeFromText "unsubscribe" = Just Unsubscribe + presenceTypeFromText "unsubscribed" = Just Unsubscribed + presenceTypeFromText "probe" = Just Probe + presenceTypeToText Available = "available" + presenceTypeToText Unavailable = "unavailable" + presenceTypeToText Subscribe = "subscribe" + presenceTypeToText Subscribed = "subscribed" + presenceTypeToText Unsubscribe = "unsubscribe" + presenceTypeToText Unsubscribed = "unsubscribed" + presenceTypeToText Probe = "probe" + +xpStanzaErrorType :: PU Text StanzaErrorType +xpStanzaErrorType = ("xpStanzaErrorType", "") + xpPartial ( \input -> case stanzaErrorTypeFromText input of + Nothing -> Left "Could not parse stanza error type." + Just j -> Right j) + stanzaErrorTypeToText + where + stanzaErrorTypeFromText "auth" = Just Auth + stanzaErrorTypeFromText "cancel" = Just Cancel + stanzaErrorTypeFromText "continue" = Just Continue + stanzaErrorTypeFromText "modify" = Just Modify + stanzaErrorTypeFromText "wait" = Just Wait + stanzaErrorTypeFromText _ = Nothing + stanzaErrorTypeToText Auth = "auth" + stanzaErrorTypeToText Cancel = "cancel" + stanzaErrorTypeToText Continue = "continue" + stanzaErrorTypeToText Modify = "modify" + stanzaErrorTypeToText Wait = "wait" + +xpStanzaErrorCondition :: PU Text StanzaErrorCondition +xpStanzaErrorCondition = ("xpStanzaErrorCondition", "") + xpPartial ( \input -> case stanzaErrorConditionFromText input of + Nothing -> Left "Could not parse stanza error condition." + Just j -> Right j) + stanzaErrorConditionToText + where + stanzaErrorConditionToText BadRequest = "bad-request" + stanzaErrorConditionToText Conflict = "conflict" + stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented" + stanzaErrorConditionToText Forbidden = "forbidden" + stanzaErrorConditionToText Gone = "gone" + stanzaErrorConditionToText InternalServerError = "internal-server-error" + stanzaErrorConditionToText ItemNotFound = "item-not-found" + stanzaErrorConditionToText JidMalformed = "jid-malformed" + stanzaErrorConditionToText NotAcceptable = "not-acceptable" + stanzaErrorConditionToText NotAllowed = "not-allowed" + stanzaErrorConditionToText NotAuthorized = "not-authorized" + stanzaErrorConditionToText PaymentRequired = "payment-required" + stanzaErrorConditionToText RecipientUnavailable = "recipient-unavailable" + stanzaErrorConditionToText Redirect = "redirect" + stanzaErrorConditionToText RegistrationRequired = "registration-required" + stanzaErrorConditionToText RemoteServerNotFound = "remote-server-not-found" + stanzaErrorConditionToText RemoteServerTimeout = "remote-server-timeout" + stanzaErrorConditionToText ResourceConstraint = "resource-constraint" + stanzaErrorConditionToText ServiceUnavailable = "service-unavailable" + stanzaErrorConditionToText SubscriptionRequired = "subscription-required" + stanzaErrorConditionToText UndefinedCondition = "undefined-condition" + stanzaErrorConditionToText UnexpectedRequest = "unexpected-request" + stanzaErrorConditionFromText "bad-request" = Just BadRequest + stanzaErrorConditionFromText "conflict" = Just Conflict + stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented + stanzaErrorConditionFromText "forbidden" = Just Forbidden + stanzaErrorConditionFromText "gone" = Just Gone + stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError + stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound + stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed + stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable + stanzaErrorConditionFromText "not-allowed" = Just NotAllowed + stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized + stanzaErrorConditionFromText "payment-required" = Just PaymentRequired + stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable + stanzaErrorConditionFromText "redirect" = Just Redirect + stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired + stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound + stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout + stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint + stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable + stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired + stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition + 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 + Nothing -> Left "Could not parse stream error condition." + Just j -> Right j) + streamErrorConditionToText + where + streamErrorConditionToText StreamBadFormat = "bad-format" + streamErrorConditionToText StreamBadNamespacePrefix = "bad-namespace-prefix" + streamErrorConditionToText StreamConflict = "conflict" + streamErrorConditionToText StreamConnectionTimeout = "connection-timeout" + streamErrorConditionToText StreamHostGone = "host-gone" + streamErrorConditionToText StreamHostUnknown = "host-unknown" + streamErrorConditionToText StreamImproperAddressing = "improper-addressing" + streamErrorConditionToText StreamInternalServerError = "internal-server-error" + streamErrorConditionToText StreamInvalidFrom = "invalid-from" + streamErrorConditionToText StreamInvalidNamespace = "invalid-namespace" + streamErrorConditionToText StreamInvalidXml = "invalid-xml" + streamErrorConditionToText StreamNotAuthorized = "not-authorized" + streamErrorConditionToText StreamNotWellFormed = "not-well-formed" + streamErrorConditionToText StreamPolicyViolation = "policy-violation" + streamErrorConditionToText StreamRemoteConnectionFailed = "remote-connection-failed" + streamErrorConditionToText StreamReset = "reset" + streamErrorConditionToText StreamResourceConstraint = "resource-constraint" + streamErrorConditionToText StreamRestrictedXml = "restricted-xml" + streamErrorConditionToText StreamSeeOtherHost = "see-other-host" + streamErrorConditionToText StreamSystemShutdown = "system-shutdown" + streamErrorConditionToText StreamUndefinedCondition = "undefined-condition" + streamErrorConditionToText StreamUnsupportedEncoding = "unsupported-encoding" + streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature" + streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type" + streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version" + streamErrorConditionFromText "bad-format" = Just StreamBadFormat + streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix + streamErrorConditionFromText "conflict" = Just StreamConflict + streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout + streamErrorConditionFromText "host-gone" = Just StreamHostGone + streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown + streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing + streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError + streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom + streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace + streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml + streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized + streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed + streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation + streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed + streamErrorConditionFromText "reset" = Just StreamReset + streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint + streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml + streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost + streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown + streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition + streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding + streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature + streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType + streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion + streamErrorConditionFromText _ = Nothing diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 28372e9..8181c34 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -20,6 +20,8 @@ module Network.Xmpp.Types , IQResult(..) , IdGenerator(..) , LangTag (..) + , langTagFromText + , langTagToText , Message(..) , message , MessageError(..) @@ -47,7 +49,6 @@ module Network.Xmpp.Types , StanzaHandler , ConnectionDetails(..) , StreamConfiguration(..) - , langTag , Jid(..) #if __GLASGOW_HASKELL >= 706 , jidQ @@ -100,13 +101,7 @@ import qualified Text.StringPrep as SP -- Wraps a string of random characters that, when using an appropriate -- @IdGenerator@, is guaranteed to be unique for the Xmpp session. -data StanzaID = StanzaID !Text deriving (Eq, Ord) - -instance Show StanzaID where - show (StanzaID s) = Text.unpack s - -instance Read StanzaID where - readsPrec _ x = [(StanzaID $ Text.pack x, "")] +data StanzaID = StanzaID !Text deriving (Eq, Ord, Read, Show) instance IsString StanzaID where fromString = StanzaID . Text.pack @@ -133,16 +128,7 @@ data IQRequest = IQRequest { iqRequestID :: !StanzaID } deriving Show -- | The type of IQ request that is made. -data IQRequestType = Get | Set deriving (Eq, Ord) - -instance Show IQRequestType where - show Get = "get" - show Set = "set" - -instance Read IQRequestType where - readsPrec _ "get" = [(Get, "")] - readsPrec _ "set" = [(Set, "")] - readsPrec _ _ = [] +data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show) -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza -- of type "result" ('IQResult') or a Timeout. @@ -237,20 +223,7 @@ data MessageType = -- | The message is sent in the context of a one-to-one chat -- -- This is the /default/ value. | Normal - deriving (Eq) - -instance Show MessageType where - show Chat = "chat" - show GroupChat = "groupchat" - show Headline = "headline" - show Normal = "normal" - -instance Read MessageType where - readsPrec _ "chat" = [(Chat, "")] - readsPrec _ "groupchat" = [(GroupChat, "")] - readsPrec _ "headline" = [(Headline, "")] - readsPrec _ "normal" = [(Normal, "")] - readsPrec _ _ = [(Normal, "")] + deriving (Eq, Read, Show) -- | The presence stanza. Used for communicating status updates. data Presence = Presence { presenceID :: !(Maybe StanzaID) @@ -294,27 +267,7 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence -- should only be used by servers Available | -- ^ Sender wants to express availability -- (no type attribute is defined) - Unavailable deriving (Eq) - -instance Show PresenceType where - show Subscribe = "subscribe" - show Subscribed = "subscribed" - show Unsubscribe = "unsubscribe" - show Unsubscribed = "unsubscribed" - show Probe = "probe" - show Available = "" - show Unavailable = "unavailable" - -instance Read PresenceType where - readsPrec _ "" = [(Available, "")] - readsPrec _ "available" = [(Available, "")] - readsPrec _ "unavailable" = [(Unavailable, "")] - readsPrec _ "subscribe" = [(Subscribe, "")] - readsPrec _ "subscribed" = [(Subscribed, "")] - readsPrec _ "unsubscribe" = [(Unsubscribe, "")] - readsPrec _ "unsubscribed" = [(Unsubscribed, "")] - readsPrec _ "probe" = [(Probe, "")] - readsPrec _ _ = [] + Unavailable deriving (Eq, Read, Show) -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like . These errors are @@ -333,22 +286,7 @@ data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry Modify | -- ^ Change the data and retry Auth | -- ^ Provide credentials and retry Wait -- ^ Error is temporary - wait and retry - deriving (Eq) - -instance Show StanzaErrorType where - show Cancel = "cancel" - show Continue = "continue" - show Modify = "modify" - show Auth = "auth" - show Wait = "wait" - -instance Read StanzaErrorType where - readsPrec _ "auth" = [( Auth , "")] - readsPrec _ "cancel" = [( Cancel , "")] - readsPrec _ "continue" = [( Continue, "")] - readsPrec _ "modify" = [( Modify , "")] - readsPrec _ "wait" = [( Wait , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- | Stanza errors are accommodated with one of the error conditions listed -- below. @@ -385,56 +323,7 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML. | UndefinedCondition -- ^ Application-specific -- condition. | UnexpectedRequest -- ^ Badly timed request. - deriving Eq - -instance Show StanzaErrorCondition where - show BadRequest = "bad-request" - show Conflict = "conflict" - show FeatureNotImplemented = "feature-not-implemented" - show Forbidden = "forbidden" - show Gone = "gone" - show InternalServerError = "internal-server-error" - show ItemNotFound = "item-not-found" - show JidMalformed = "jid-malformed" - show NotAcceptable = "not-acceptable" - show NotAllowed = "not-allowed" - show NotAuthorized = "not-authorized" - show PaymentRequired = "payment-required" - show RecipientUnavailable = "recipient-unavailable" - show Redirect = "redirect" - show RegistrationRequired = "registration-required" - show RemoteServerNotFound = "remote-server-not-found" - show RemoteServerTimeout = "remote-server-timeout" - show ResourceConstraint = "resource-constraint" - show ServiceUnavailable = "service-unavailable" - show SubscriptionRequired = "subscription-required" - show UndefinedCondition = "undefined-condition" - show UnexpectedRequest = "unexpected-request" - -instance Read StanzaErrorCondition where - readsPrec _ "bad-request" = [(BadRequest , "")] - readsPrec _ "conflict" = [(Conflict , "")] - readsPrec _ "feature-not-implemented" = [(FeatureNotImplemented, "")] - readsPrec _ "forbidden" = [(Forbidden , "")] - readsPrec _ "gone" = [(Gone , "")] - readsPrec _ "internal-server-error" = [(InternalServerError , "")] - readsPrec _ "item-not-found" = [(ItemNotFound , "")] - readsPrec _ "jid-malformed" = [(JidMalformed , "")] - readsPrec _ "not-acceptable" = [(NotAcceptable , "")] - readsPrec _ "not-allowed" = [(NotAllowed , "")] - readsPrec _ "not-authorized" = [(NotAuthorized , "")] - readsPrec _ "payment-required" = [(PaymentRequired , "")] - readsPrec _ "recipient-unavailable" = [(RecipientUnavailable , "")] - readsPrec _ "redirect" = [(Redirect , "")] - readsPrec _ "registration-required" = [(RegistrationRequired , "")] - readsPrec _ "remote-server-not-found" = [(RemoteServerNotFound , "")] - readsPrec _ "remote-server-timeout" = [(RemoteServerTimeout , "")] - readsPrec _ "resource-constraint" = [(ResourceConstraint , "")] - readsPrec _ "service-unavailable" = [(ServiceUnavailable , "")] - readsPrec _ "subscription-required" = [(SubscriptionRequired , "")] - readsPrec _ "unexpected-request" = [(UnexpectedRequest , "")] - readsPrec _ "undefined-condition" = [(UndefinedCondition , "")] - readsPrec _ _ = [(UndefinedCondition , "")] + deriving (Eq, Read, Show) -- ============================================================================= -- OTHER STUFF @@ -473,34 +362,7 @@ data SaslError = SaslAborted -- ^ Client aborted. -- temporary error condition; the -- initiating entity is recommended -- to try again later. - deriving Eq - -instance Show SaslError where - show SaslAborted = "aborted" - show SaslAccountDisabled = "account-disabled" - show SaslCredentialsExpired = "credentials-expired" - show SaslEncryptionRequired = "encryption-required" - show SaslIncorrectEncoding = "incorrect-encoding" - show SaslInvalidAuthzid = "invalid-authzid" - show SaslInvalidMechanism = "invalid-mechanism" - show SaslMalformedRequest = "malformed-request" - show SaslMechanismTooWeak = "mechanism-too-weak" - show SaslNotAuthorized = "not-authorized" - show SaslTemporaryAuthFailure = "temporary-auth-failure" - -instance Read SaslError where - readsPrec _ "aborted" = [(SaslAborted , "")] - readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] - readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] - readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] - readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] - readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] - readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] - readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] - readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] - readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] - readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] - readsPrec _ _ = [] + deriving (Eq, Read, Show) -- The documentation of StreamErrorConditions is copied from -- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions @@ -617,63 +479,7 @@ data StreamErrorCondition -- initiating entity in the stream header -- specifies a version of XMPP that is not -- supported by the server. - deriving Eq - -instance Show StreamErrorCondition where - show StreamBadFormat = "bad-format" - show StreamBadNamespacePrefix = "bad-namespace-prefix" - show StreamConflict = "conflict" - show StreamConnectionTimeout = "connection-timeout" - show StreamHostGone = "host-gone" - show StreamHostUnknown = "host-unknown" - show StreamImproperAddressing = "improper-addressing" - show StreamInternalServerError = "internal-server-error" - show StreamInvalidFrom = "invalid-from" - show StreamInvalidNamespace = "invalid-namespace" - show StreamInvalidXml = "invalid-xml" - show StreamNotAuthorized = "not-authorized" - show StreamNotWellFormed = "not-well-formed" - show StreamPolicyViolation = "policy-violation" - show StreamRemoteConnectionFailed = "remote-connection-failed" - show StreamReset = "reset" - show StreamResourceConstraint = "resource-constraint" - show StreamRestrictedXml = "restricted-xml" - show StreamSeeOtherHost = "see-other-host" - show StreamSystemShutdown = "system-shutdown" - show StreamUndefinedCondition = "undefined-condition" - show StreamUnsupportedEncoding = "unsupported-encoding" - show StreamUnsupportedFeature = "unsupported-feature" - show StreamUnsupportedStanzaType = "unsupported-stanza-type" - show StreamUnsupportedVersion = "unsupported-version" - -instance Read StreamErrorCondition where - readsPrec _ "bad-format" = [(StreamBadFormat , "")] - readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] - readsPrec _ "conflict" = [(StreamConflict , "")] - readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] - readsPrec _ "host-gone" = [(StreamHostGone , "")] - readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] - readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] - readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] - readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] - readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] - readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] - readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] - readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] - readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] - readsPrec _ "remote-connection-failed" = - [(StreamRemoteConnectionFailed, "")] - readsPrec _ "reset" = [(StreamReset , "")] - readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] - readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] - readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] - readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] - readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] - readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] - readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] - readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")] - readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] - readsPrec _ _ = [(StreamUndefinedCondition , "")] + deriving (Eq, Read, Show) -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo @@ -758,7 +564,7 @@ newtype IdGenerator = IdGenerator (IO Text) -- 2.13, which in turn is lesser than 12.3. data Version = Version { majorVersion :: !Integer - , minorVersion :: !Integer } deriving (Eq) + , minorVersion :: !Integer } deriving (Eq, Read, Show) -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. @@ -767,11 +573,11 @@ instance Ord Version where | amajor /= bmajor = compare amajor bmajor | otherwise = compare aminor bminor -instance Read Version where - readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) +-- instance Read Version where +-- readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) +-- instance Show Version where +-- show (Version major minor) = (show major) ++ "." ++ (show minor) -- Converts a "." numeric version number to a @Version@ object. versionFromText :: Text.Text -> Maybe Version @@ -792,25 +598,22 @@ versionParser = do -- has a primary tag and a number of subtags. Two language tags are considered -- equal if and only if they contain the same tags (case-insensitive). data LangTag = LangTag { primaryTag :: !Text - , subtags :: ![Text] } + , subtags :: ![Text] } deriving (Read, Show) +-- Equals for language tags is not case-sensitive. instance Eq LangTag where LangTag p s == LangTag q t = Text.toLower p == Text.toLower q && map Text.toLower s == map Text.toLower t -instance Read LangTag where - readsPrec _ txt = (,"") <$> maybeToList (langTag $ Text.pack txt) - -instance Show LangTag where - show (LangTag p []) = Text.unpack p - show (LangTag p s) = Text.unpack . Text.concat $ - [p, "-", Text.intercalate "-" s] - -- | Parses, validates, and possibly constructs a "LangTag" object. -langTag :: Text.Text -> Maybe LangTag -langTag s = case AP.parseOnly langTagParser s of - Right tag -> Just tag - Left _ -> Nothing +langTagFromText :: Text.Text -> Maybe LangTag +langTagFromText s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + +langTagToText :: LangTag -> Text.Text +langTagToText (LangTag p []) = p +langTagToText (LangTag p s) = Text.concat $ [p, "-", Text.intercalate "-" s] -- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. langTagParser :: AP.Parser LangTag