From f97d5c31c61dfb87dc19db6acd44592e7179168f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 12:52:53 +0200 Subject: [PATCH] added pickler for SASLError --- src/Network/XMPP/Marshal.hs | 7 +--- src/Network/XMPP/Pickle.hs | 8 ++++ src/Network/XMPP/SASL.hs | 25 ++++++++++--- src/Network/XMPP/Types.hs | 75 +++++++++++++++++++++++++------------ 4 files changed, 81 insertions(+), 34 deletions(-) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 6f32fde..3d694e2 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -5,6 +5,7 @@ module Network.XMPP.Marshal where import Data.XML.Pickle import Data.XML.Types +import Network.XMPP.Pickle import Network.XMPP.Types stanzaSel :: Stanza -> Int @@ -27,12 +28,6 @@ stanzaP = xpAlt stanzaSel , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError ] -xmlLang :: Name -xmlLang = Name "lang" Nothing (Just "xml") - -xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim - xpMessage :: PU [Node] (Message) xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) -> Message qid from to lang tp sub thr body ext) diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 97d3989..45eeab2 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -10,6 +10,8 @@ module Network.XMPP.Pickle where import Data.XML.Types import Data.XML.Pickle +import Network.XMPP.Types + import Text.XML.Stream.Elements mbToBool :: Maybe t -> Bool @@ -21,6 +23,12 @@ xpElemEmpty name = xpWrap (\((),()) -> ()) (\() -> ((),())) $ xpElem name xpUnit xpUnit +xmlLang :: Name +xmlLang = Name "lang" Nothing (Just "xml") + +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim + -- xpElemExists :: Name -> PU [Node] Bool -- xpElemExists name = xpWrap (\x -> mbToBool x) -- (\x -> if x then Just () else Nothing) $ diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index f7e28c3..bff4caa 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -26,6 +26,7 @@ import qualified Data.Text.Encoding as Text import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types +import Network.XMPP.Pickle import qualified System.Random as Random @@ -92,12 +93,12 @@ createResponse g hostname username passwd' pairs = let uname = Text.encodeUtf8 username passwd = Text.encodeUtf8 passwd' realm = Text.encodeUtf8 hostname - + -- Using Char instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. cnonce = BS.tail . BS.init . B64.encode . BS8.pack . take 8 $ Random.randoms g - + nc = "00000001" digestURI = ("xmpp/" `BS.append` realm) digest = md5Digest @@ -163,10 +164,24 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= -- Pickling +failurePickle :: PU [Node] (SASLFailure) +failurePickle = xpWrap (\(txt,(failure,_,_)) + -> SASLFailure failure txt) + (\(SASLFailure failure txt) + -> (txt,(failure,(),()))) + (xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xp2Tuple + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-sasl}text" + xpLangTag + (xpContent xpId)) + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-sasl" + xpPrim + (xpUnit) + (xpUnit)))) -failurePickle :: PU [Node] (Element) -failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" - (xpIsolate xpElemVerbatim) challengePickle :: PU [Node] Text.Text challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index f514950..f4ea65f 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -18,7 +18,7 @@ module Network.XMPP.Types , IQResponse(..) , IQResult(..) , IdGenerator(..) - , LangTag(..) + , LangTag (..) , Message(..) , MessageError(..) , MessageType(..) @@ -474,39 +474,68 @@ instance Read StanzaErrorCondition where -- ============================================================================= data SASLFailure = SASLFailure { saslFailureCondition :: SASLError - , saslFailureText :: Maybe Text } -- TODO: XMLLang + , saslFailureText :: Maybe ( Maybe LangTag + , Text + ) + } deriving Show -data SASLError = -- SASLAborted | -- Client aborted - should not happen - SASLAccountDisabled | -- ^ The account has been temporarily - -- disabled - SASLCredentialsExpired | -- ^ The authentication failed because +data SASLError = SASLAborted -- ^ Client aborted + | SASLAccountDisabled -- ^ The account has been temporarily + -- disabled + | SASLCredentialsExpired -- ^ The authentication failed because -- the credentials have expired - SASLEncryptionRequired | -- ^ The mechanism requested cannot be + | SASLEncryptionRequired -- ^ The mechanism requested cannot be -- used the confidentiality and -- integrity of the underlying -- stream is protected (typically -- with TLS) - -- SASLIncorrectEncoding | -- The base64 encoding is incorrect - -- - should not happen - -- SASLInvalidAuthzid | -- The authzid has an incorrect format, - -- or the initiating entity does not - -- have the appropriate permissions to - -- authorize that ID - SASLInvalidMechanism | -- ^ The mechanism is not supported by - -- the receiving entity - -- SASLMalformedRequest | -- Invalid syntax - should not happen - SASLMechanismTooWeak | -- ^ The receiving entity policy - -- requires a stronger mechanism - SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials - -- provided, or some - -- generic authentication - -- failure has occurred - SASLTemporaryAuthFailure -- ^ There receiving entity reported a + | SASLIncorrectEncoding -- ^ The base64 encoding is incorrect + | SASLInvalidAuthzid -- ^ The authzid has an incorrect + -- format or the initiating entity does + -- not have the appropriate permissions + -- to authorize that ID + | SASLInvalidMechanism -- ^ The mechanism is not supported by + -- the receiving entity + | SASLMalformedRequest -- ^ Invalid syntax + | SASLMechanismTooWeak -- ^ The receiving entity policy + -- requires a stronger mechanism + | SASLNotAuthorized -- ^ Invalid credentials + -- provided, or some + -- generic authentication + -- failure has occurred + | SASLTemporaryAuthFailure -- ^ There receiving entity reported a -- temporary error condition; the -- initiating entity is recommended -- to try again later +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 , "")] + + -- | Readability type for host name Texts.