From b41882f4cc674a7f1d8b6f046d332113d237899a Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Dec 2013 13:10:49 +0100 Subject: [PATCH] integrate incomplete pickler move xpStanzaErrorCondition into the body of xpErrorCondition because it is meaningless by itself and rename xpErrorCondition to xpStanzaErrorCondition --- source/Network/Xmpp/Marshal.hs | 116 +++++++++++++++++---------------- tests/Tests/Picklers.hs | 2 +- 2 files changed, 61 insertions(+), 57 deletions(-) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 4963bbe..ae4fe3d 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -109,8 +109,8 @@ xpIQResult = ("xpIQResult" , "") xpWrap -- Errors ---------------------------------------------------------- -xpErrorCondition :: PU [Node] StanzaErrorCondition -xpErrorCondition = ("xpErrorCondition" , "") xpWrapEither +xpStanzaErrorCondition :: PU [Node] StanzaErrorCondition +xpStanzaErrorCondition = ("xpErrorCondition" , "") xpWrapEither (\(cond, (),cont) -> case (cond, cont) of (Gone _, x) -> Right $ Gone x (Redirect _, x) -> Right $ Redirect x @@ -125,10 +125,66 @@ xpErrorCondition = ("xpErrorCondition" , "") xpWrapEither c -> (c, (), Nothing)) (xpElemByNamespace "urn:ietf:params:xml:ns:xmpp-stanzas" - xpStanzaErrorCondition + xpStanzaErrorConditionShape xpUnit (xpOption $ xpContent xpNonemptyText) ) + where + -- Create the "shape" of the error condition. In case of Gone and Redirect + -- 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 + 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 PolicyViolation = "policy-violation" + 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 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 + + xpStanzaError :: PU [Node] StanzaError xpStanzaError = ("xpStanzaError" , "") xpWrap @@ -137,7 +193,7 @@ xpStanzaError = ("xpStanzaError" , "") xpWrap (xpElem "{jabber:client}error" (xpAttr "type" xpStanzaErrorType) (xp3Tuple - xpErrorCondition + xpStanzaErrorCondition (xpOption $ xpElem "{jabber:client}text" (xpAttrImplied xmlLang xpLang) (xpContent xpNonemptyText) @@ -378,58 +434,6 @@ xpStanzaErrorType = ("xpStanzaErrorType", "") 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 PolicyViolation = "policy-violation" - 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 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 xpStreamErrorCondition :: PU Text StreamErrorCondition xpStreamErrorCondition = ("xpStreamErrorCondition", "") diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs index b2ad633..a2d2fbc 100644 --- a/tests/Tests/Picklers.hs +++ b/tests/Tests/Picklers.hs @@ -37,7 +37,7 @@ prop_xpIQRequest_invertibe = tpsi xpIQRequest prop_xpIQRequest_invertibe :: IQRequest -> Bool prop_xpIQResult_invertibe = tpsi xpIQResult prop_xpIQResult_invertibe :: IQResult -> Bool -prop_xpErrorCondition_invertibe = tpsi xpErrorCondition +prop_xpErrorCondition_invertibe = tpsi xpStanzaErrorCondition prop_xpErrorCondition_invertibe :: StanzaErrorCondition -> Bool prop_xpStanzaError_invertibe = tpsi xpStanzaError prop_xpStanzaError_invertibe :: StanzaError -> Bool