From 4d9fa5f28ed0b390d45c39b98c3c2ab7f29efd64 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 9 Mar 2014 12:54:58 +0100 Subject: [PATCH] fix defined condition picklers being too strict --- source/Network/Xmpp/Marshal.hs | 112 ++++++++++++++--------------- source/Network/Xmpp/Sasl/Common.hs | 29 ++++---- 2 files changed, 67 insertions(+), 74 deletions(-) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 0a9eadb..daee98d 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -156,10 +156,8 @@ xpStanzaErrorCondition = ("xpErrorCondition" , "") xpWrapEither -- the optional field is left empty and must be filled in by the caller xpStanzaErrorConditionShape :: PU Text StanzaErrorCondition xpStanzaErrorConditionShape = ("xpStanzaErrorCondition", "") - xpPartial ( \input -> case stanzaErrorConditionFromText input of - Nothing -> Left "Could not parse stanza error condition." - Just j -> Right j) - stanzaErrorConditionToText + xpIso stanzaErrorConditionFromText + stanzaErrorConditionToText stanzaErrorConditionToText BadRequest = "bad-request" stanzaErrorConditionToText Conflict = "conflict" stanzaErrorConditionToText FeatureNotImplemented = "feature-not-implemented" @@ -182,29 +180,29 @@ xpStanzaErrorCondition = ("xpErrorCondition" , "") xpWrapEither 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 Nothing - 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 "policy-violation" = Just PolicyViolation - stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable - stanzaErrorConditionFromText "redirect" = Just $ Redirect Nothing - 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 + stanzaErrorConditionFromText "bad-request" = BadRequest + stanzaErrorConditionFromText "conflict" = Conflict + stanzaErrorConditionFromText "feature-not-implemented" = FeatureNotImplemented + stanzaErrorConditionFromText "forbidden" = Forbidden + stanzaErrorConditionFromText "gone" = Gone Nothing + stanzaErrorConditionFromText "internal-server-error" = InternalServerError + stanzaErrorConditionFromText "item-not-found" = ItemNotFound + stanzaErrorConditionFromText "jid-malformed" = JidMalformed + stanzaErrorConditionFromText "not-acceptable" = NotAcceptable + stanzaErrorConditionFromText "not-allowed" = NotAllowed + stanzaErrorConditionFromText "not-authorized" = NotAuthorized + stanzaErrorConditionFromText "policy-violation" = PolicyViolation + stanzaErrorConditionFromText "recipient-unavailable" = RecipientUnavailable + stanzaErrorConditionFromText "redirect" = Redirect Nothing + stanzaErrorConditionFromText "registration-required" = RegistrationRequired + stanzaErrorConditionFromText "remote-server-not-found" = RemoteServerNotFound + stanzaErrorConditionFromText "remote-server-timeout" = RemoteServerTimeout + stanzaErrorConditionFromText "resource-constraint" = ResourceConstraint + stanzaErrorConditionFromText "service-unavailable" = ServiceUnavailable + stanzaErrorConditionFromText "subscription-required" = SubscriptionRequired + stanzaErrorConditionFromText "undefined-condition" = UndefinedCondition + stanzaErrorConditionFromText "unexpected-request" = UnexpectedRequest + stanzaErrorConditionFromText _ = UndefinedCondition @@ -218,7 +216,7 @@ xpStanzaError = ("xpStanzaError" , "") xpWrap (xpAttribute' "code" xpId)) (xp3Tuple xpStanzaErrorCondition - (xpOption $ xpElem "{jabber:client}text" + (xpOption $ xpElem "{urn:ietf:params:xml:ns:xmpp-stanzas}text" (xpAttrImplied xmlLang xpLang) (xpContent xpNonemptyText) ) @@ -463,10 +461,8 @@ xpStanzaErrorType = ("xpStanzaErrorType", "") 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 + xpIso streamErrorConditionFromText + streamErrorConditionToText where streamErrorConditionToText StreamBadFormat = "bad-format" streamErrorConditionToText StreamBadNamespacePrefix = "bad-namespace-prefix" @@ -493,29 +489,29 @@ xpStreamErrorCondition = ("xpStreamErrorCondition", "") 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 + streamErrorConditionFromText "bad-format" = StreamBadFormat + streamErrorConditionFromText "bad-namespace-prefix" = StreamBadNamespacePrefix + streamErrorConditionFromText "conflict" = StreamConflict + streamErrorConditionFromText "connection-timeout" = StreamConnectionTimeout + streamErrorConditionFromText "host-gone" = StreamHostGone + streamErrorConditionFromText "host-unknown" = StreamHostUnknown + streamErrorConditionFromText "improper-addressing" = StreamImproperAddressing + streamErrorConditionFromText "internal-server-error" = StreamInternalServerError + streamErrorConditionFromText "invalid-from" = StreamInvalidFrom + streamErrorConditionFromText "invalid-namespace" = StreamInvalidNamespace + streamErrorConditionFromText "invalid-xml" = StreamInvalidXml + streamErrorConditionFromText "not-authorized" = StreamNotAuthorized + streamErrorConditionFromText "not-well-formed" = StreamNotWellFormed + streamErrorConditionFromText "policy-violation" = StreamPolicyViolation + streamErrorConditionFromText "remote-connection-failed" = StreamRemoteConnectionFailed + streamErrorConditionFromText "reset" = StreamReset + streamErrorConditionFromText "resource-constraint" = StreamResourceConstraint + streamErrorConditionFromText "restricted-xml" = StreamRestrictedXml + streamErrorConditionFromText "see-other-host" = StreamSeeOtherHost + streamErrorConditionFromText "system-shutdown" = StreamSystemShutdown + streamErrorConditionFromText "undefined-condition" = StreamUndefinedCondition + streamErrorConditionFromText "unsupported-encoding" = StreamUnsupportedEncoding + streamErrorConditionFromText "unsupported-feature" = StreamUnsupportedFeature + streamErrorConditionFromText "unsupported-stanza-type" = StreamUnsupportedStanzaType + streamErrorConditionFromText "unsupported-version" = StreamUnsupportedVersion + streamErrorConditionFromText _ = StreamUndefinedCondition -- ยง4.9.2 diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 0e0ab81..5ab11af 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -86,10 +86,7 @@ xpFailure = xpWrap 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 + xpIso saslErrorFromText saslErrorToText where saslErrorToText SaslAborted = "aborted" saslErrorToText SaslAccountDisabled = "account-disabled" @@ -102,18 +99,18 @@ xpSaslError = ("xpSaslError", "") 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 - saslErrorFromText _ = Nothing + saslErrorFromText "aborted" = SaslAborted + saslErrorFromText "account-disabled" = SaslAccountDisabled + saslErrorFromText "credentials-expired" = SaslCredentialsExpired + saslErrorFromText "encryption-required" = SaslEncryptionRequired + saslErrorFromText "incorrect-encoding" = SaslIncorrectEncoding + saslErrorFromText "invalid-authzid" = SaslInvalidAuthzid + saslErrorFromText "invalid-mechanism" = SaslInvalidMechanism + saslErrorFromText "malformed-request" = SaslMalformedRequest + saslErrorFromText "mechanism-too-weak" = SaslMechanismTooWeak + saslErrorFromText "not-authorized" = SaslNotAuthorized + saslErrorFromText "temporary-auth-failure" = SaslTemporaryAuthFailure + saslErrorFromText _ = SaslNotAuthorized -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text)