asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

fix defined condition picklers being too strict

master
Philipp Balzarek 12 years ago
parent
91b8d1b5ae
commit
4d9fa5f28e
2 changed files with 67 additions and 74 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 108
      source/Network/Xmpp/Marshal.hs
  2. 29
      source/Network/Xmpp/Sasl/Common.hs

108
source/Network/Xmpp/Marshal.hs
Unescape View File

@ -156,9 +156,7 @@ xpStanzaErrorCondition = ("xpErrorCondition" , "") <?+> xpWrapEither
-- the optional field is left empty and must be filled in by the caller -- the optional field is left empty and must be filled in by the caller
xpStanzaErrorConditionShape :: PU Text StanzaErrorCondition xpStanzaErrorConditionShape :: PU Text StanzaErrorCondition
xpStanzaErrorConditionShape = ("xpStanzaErrorCondition", "") <?> xpStanzaErrorConditionShape = ("xpStanzaErrorCondition", "") <?>
xpPartial ( \input -> case stanzaErrorConditionFromText input of xpIso stanzaErrorConditionFromText
Nothing -> Left "Could not parse stanza error condition."
Just j -> Right j)
stanzaErrorConditionToText stanzaErrorConditionToText
stanzaErrorConditionToText BadRequest = "bad-request" stanzaErrorConditionToText BadRequest = "bad-request"
stanzaErrorConditionToText Conflict = "conflict" stanzaErrorConditionToText Conflict = "conflict"
@ -182,29 +180,29 @@ xpStanzaErrorCondition = ("xpErrorCondition" , "") <?+> xpWrapEither
stanzaErrorConditionToText SubscriptionRequired = "subscription-required" stanzaErrorConditionToText SubscriptionRequired = "subscription-required"
stanzaErrorConditionToText UndefinedCondition = "undefined-condition" stanzaErrorConditionToText UndefinedCondition = "undefined-condition"
stanzaErrorConditionToText UnexpectedRequest = "unexpected-request" stanzaErrorConditionToText UnexpectedRequest = "unexpected-request"
stanzaErrorConditionFromText "bad-request" = Just BadRequest stanzaErrorConditionFromText "bad-request" = BadRequest
stanzaErrorConditionFromText "conflict" = Just Conflict stanzaErrorConditionFromText "conflict" = Conflict
stanzaErrorConditionFromText "feature-not-implemented" = Just FeatureNotImplemented stanzaErrorConditionFromText "feature-not-implemented" = FeatureNotImplemented
stanzaErrorConditionFromText "forbidden" = Just Forbidden stanzaErrorConditionFromText "forbidden" = Forbidden
stanzaErrorConditionFromText "gone" = Just $ Gone Nothing stanzaErrorConditionFromText "gone" = Gone Nothing
stanzaErrorConditionFromText "internal-server-error" = Just InternalServerError stanzaErrorConditionFromText "internal-server-error" = InternalServerError
stanzaErrorConditionFromText "item-not-found" = Just ItemNotFound stanzaErrorConditionFromText "item-not-found" = ItemNotFound
stanzaErrorConditionFromText "jid-malformed" = Just JidMalformed stanzaErrorConditionFromText "jid-malformed" = JidMalformed
stanzaErrorConditionFromText "not-acceptable" = Just NotAcceptable stanzaErrorConditionFromText "not-acceptable" = NotAcceptable
stanzaErrorConditionFromText "not-allowed" = Just NotAllowed stanzaErrorConditionFromText "not-allowed" = NotAllowed
stanzaErrorConditionFromText "not-authorized" = Just NotAuthorized stanzaErrorConditionFromText "not-authorized" = NotAuthorized
stanzaErrorConditionFromText "policy-violation" = Just PolicyViolation stanzaErrorConditionFromText "policy-violation" = PolicyViolation
stanzaErrorConditionFromText "recipient-unavailable" = Just RecipientUnavailable stanzaErrorConditionFromText "recipient-unavailable" = RecipientUnavailable
stanzaErrorConditionFromText "redirect" = Just $ Redirect Nothing stanzaErrorConditionFromText "redirect" = Redirect Nothing
stanzaErrorConditionFromText "registration-required" = Just RegistrationRequired stanzaErrorConditionFromText "registration-required" = RegistrationRequired
stanzaErrorConditionFromText "remote-server-not-found" = Just RemoteServerNotFound stanzaErrorConditionFromText "remote-server-not-found" = RemoteServerNotFound
stanzaErrorConditionFromText "remote-server-timeout" = Just RemoteServerTimeout stanzaErrorConditionFromText "remote-server-timeout" = RemoteServerTimeout
stanzaErrorConditionFromText "resource-constraint" = Just ResourceConstraint stanzaErrorConditionFromText "resource-constraint" = ResourceConstraint
stanzaErrorConditionFromText "service-unavailable" = Just ServiceUnavailable stanzaErrorConditionFromText "service-unavailable" = ServiceUnavailable
stanzaErrorConditionFromText "subscription-required" = Just SubscriptionRequired stanzaErrorConditionFromText "subscription-required" = SubscriptionRequired
stanzaErrorConditionFromText "undefined-condition" = Just UndefinedCondition stanzaErrorConditionFromText "undefined-condition" = UndefinedCondition
stanzaErrorConditionFromText "unexpected-request" = Just UnexpectedRequest stanzaErrorConditionFromText "unexpected-request" = UnexpectedRequest
stanzaErrorConditionFromText _ = Nothing stanzaErrorConditionFromText _ = UndefinedCondition
@ -218,7 +216,7 @@ xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap
(xpAttribute' "code" xpId)) (xpAttribute' "code" xpId))
(xp3Tuple (xp3Tuple
xpStanzaErrorCondition xpStanzaErrorCondition
(xpOption $ xpElem "{jabber:client}text" (xpOption $ xpElem "{urn:ietf:params:xml:ns:xmpp-stanzas}text"
(xpAttrImplied xmlLang xpLang) (xpAttrImplied xmlLang xpLang)
(xpContent xpNonemptyText) (xpContent xpNonemptyText)
) )
@ -463,9 +461,7 @@ xpStanzaErrorType = ("xpStanzaErrorType", "") <?>
xpStreamErrorCondition :: PU Text StreamErrorCondition xpStreamErrorCondition :: PU Text StreamErrorCondition
xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?> xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>
xpPartial ( \input -> case streamErrorConditionFromText input of xpIso streamErrorConditionFromText
Nothing -> Left "Could not parse stream error condition."
Just j -> Right j)
streamErrorConditionToText streamErrorConditionToText
where where
streamErrorConditionToText StreamBadFormat = "bad-format" streamErrorConditionToText StreamBadFormat = "bad-format"
@ -493,29 +489,29 @@ xpStreamErrorCondition = ("xpStreamErrorCondition", "") <?>
streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature" streamErrorConditionToText StreamUnsupportedFeature = "unsupported-feature"
streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type" streamErrorConditionToText StreamUnsupportedStanzaType = "unsupported-stanza-type"
streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version" streamErrorConditionToText StreamUnsupportedVersion = "unsupported-version"
streamErrorConditionFromText "bad-format" = Just StreamBadFormat streamErrorConditionFromText "bad-format" = StreamBadFormat
streamErrorConditionFromText "bad-namespace-prefix" = Just StreamBadNamespacePrefix streamErrorConditionFromText "bad-namespace-prefix" = StreamBadNamespacePrefix
streamErrorConditionFromText "conflict" = Just StreamConflict streamErrorConditionFromText "conflict" = StreamConflict
streamErrorConditionFromText "connection-timeout" = Just StreamConnectionTimeout streamErrorConditionFromText "connection-timeout" = StreamConnectionTimeout
streamErrorConditionFromText "host-gone" = Just StreamHostGone streamErrorConditionFromText "host-gone" = StreamHostGone
streamErrorConditionFromText "host-unknown" = Just StreamHostUnknown streamErrorConditionFromText "host-unknown" = StreamHostUnknown
streamErrorConditionFromText "improper-addressing" = Just StreamImproperAddressing streamErrorConditionFromText "improper-addressing" = StreamImproperAddressing
streamErrorConditionFromText "internal-server-error" = Just StreamInternalServerError streamErrorConditionFromText "internal-server-error" = StreamInternalServerError
streamErrorConditionFromText "invalid-from" = Just StreamInvalidFrom streamErrorConditionFromText "invalid-from" = StreamInvalidFrom
streamErrorConditionFromText "invalid-namespace" = Just StreamInvalidNamespace streamErrorConditionFromText "invalid-namespace" = StreamInvalidNamespace
streamErrorConditionFromText "invalid-xml" = Just StreamInvalidXml streamErrorConditionFromText "invalid-xml" = StreamInvalidXml
streamErrorConditionFromText "not-authorized" = Just StreamNotAuthorized streamErrorConditionFromText "not-authorized" = StreamNotAuthorized
streamErrorConditionFromText "not-well-formed" = Just StreamNotWellFormed streamErrorConditionFromText "not-well-formed" = StreamNotWellFormed
streamErrorConditionFromText "policy-violation" = Just StreamPolicyViolation streamErrorConditionFromText "policy-violation" = StreamPolicyViolation
streamErrorConditionFromText "remote-connection-failed" = Just StreamRemoteConnectionFailed streamErrorConditionFromText "remote-connection-failed" = StreamRemoteConnectionFailed
streamErrorConditionFromText "reset" = Just StreamReset streamErrorConditionFromText "reset" = StreamReset
streamErrorConditionFromText "resource-constraint" = Just StreamResourceConstraint streamErrorConditionFromText "resource-constraint" = StreamResourceConstraint
streamErrorConditionFromText "restricted-xml" = Just StreamRestrictedXml streamErrorConditionFromText "restricted-xml" = StreamRestrictedXml
streamErrorConditionFromText "see-other-host" = Just StreamSeeOtherHost streamErrorConditionFromText "see-other-host" = StreamSeeOtherHost
streamErrorConditionFromText "system-shutdown" = Just StreamSystemShutdown streamErrorConditionFromText "system-shutdown" = StreamSystemShutdown
streamErrorConditionFromText "undefined-condition" = Just StreamUndefinedCondition streamErrorConditionFromText "undefined-condition" = StreamUndefinedCondition
streamErrorConditionFromText "unsupported-encoding" = Just StreamUnsupportedEncoding streamErrorConditionFromText "unsupported-encoding" = StreamUnsupportedEncoding
streamErrorConditionFromText "unsupported-feature" = Just StreamUnsupportedFeature streamErrorConditionFromText "unsupported-feature" = StreamUnsupportedFeature
streamErrorConditionFromText "unsupported-stanza-type" = Just StreamUnsupportedStanzaType streamErrorConditionFromText "unsupported-stanza-type" = StreamUnsupportedStanzaType
streamErrorConditionFromText "unsupported-version" = Just StreamUnsupportedVersion streamErrorConditionFromText "unsupported-version" = StreamUnsupportedVersion
streamErrorConditionFromText _ = Nothing streamErrorConditionFromText _ = StreamUndefinedCondition -- §4.9.2

29
source/Network/Xmpp/Sasl/Common.hs
Unescape View File

@ -86,10 +86,7 @@ xpFailure = xpWrap
xpSaslError :: PU Text.Text SaslError xpSaslError :: PU Text.Text SaslError
xpSaslError = ("xpSaslError", "") <?> xpSaslError = ("xpSaslError", "") <?>
xpPartial ( \input -> case saslErrorFromText input of xpIso saslErrorFromText saslErrorToText
Nothing -> Left "Could not parse SASL error."
Just j -> Right j)
saslErrorToText
where where
saslErrorToText SaslAborted = "aborted" saslErrorToText SaslAborted = "aborted"
saslErrorToText SaslAccountDisabled = "account-disabled" saslErrorToText SaslAccountDisabled = "account-disabled"
@ -102,18 +99,18 @@ xpSaslError = ("xpSaslError", "") <?>
saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak" saslErrorToText SaslMechanismTooWeak = "mechanism-too-weak"
saslErrorToText SaslNotAuthorized = "not-authorized" saslErrorToText SaslNotAuthorized = "not-authorized"
saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure" saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"
saslErrorFromText "aborted" = Just SaslAborted saslErrorFromText "aborted" = SaslAborted
saslErrorFromText "account-disabled" = Just SaslAccountDisabled saslErrorFromText "account-disabled" = SaslAccountDisabled
saslErrorFromText "credentials-expired" = Just SaslCredentialsExpired saslErrorFromText "credentials-expired" = SaslCredentialsExpired
saslErrorFromText "encryption-required" = Just SaslEncryptionRequired saslErrorFromText "encryption-required" = SaslEncryptionRequired
saslErrorFromText "incorrect-encoding" = Just SaslIncorrectEncoding saslErrorFromText "incorrect-encoding" = SaslIncorrectEncoding
saslErrorFromText "invalid-authzid" = Just SaslInvalidAuthzid saslErrorFromText "invalid-authzid" = SaslInvalidAuthzid
saslErrorFromText "invalid-mechanism" = Just SaslInvalidMechanism saslErrorFromText "invalid-mechanism" = SaslInvalidMechanism
saslErrorFromText "malformed-request" = Just SaslMalformedRequest saslErrorFromText "malformed-request" = SaslMalformedRequest
saslErrorFromText "mechanism-too-weak" = Just SaslMechanismTooWeak saslErrorFromText "mechanism-too-weak" = SaslMechanismTooWeak
saslErrorFromText "not-authorized" = Just SaslNotAuthorized saslErrorFromText "not-authorized" = SaslNotAuthorized
saslErrorFromText "temporary-auth-failure" = Just SaslTemporaryAuthFailure saslErrorFromText "temporary-auth-failure" = SaslTemporaryAuthFailure
saslErrorFromText _ = Nothing saslErrorFromText _ = SaslNotAuthorized
-- Challenge element pickler. -- Challenge element pickler.
xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge :: PU [Node] (Maybe Text.Text)

Write Preview
Loading…
Cancel
Save