added pickler for SASLError

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)

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) $

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"

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
+data SASLError = SASLAborted              -- ^ Client aborted
-                 SASLAccountDisabled | -- ^ The account has been temporarily
+               | SASLAccountDisabled      -- ^ The account has been temporarily
-                                       --   disabled
+                                          --   disabled
-                 SASLCredentialsExpired | -- ^ The authentication failed because
+               | 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
+               | SASLIncorrectEncoding    -- ^ The base64 encoding is incorrect
-                                            -- - should not happen
+               | SASLInvalidAuthzid       -- ^ The authzid has an incorrect
-                 -- SASLInvalidAuthzid | -- The authzid has an incorrect format,
+                                          -- format or the initiating entity does
-                                         -- or the initiating entity does not
+                                          -- not have the appropriate permissions
-                                         -- have the appropriate permissions to
+                                          -- to authorize that ID
-                                         -- authorize that ID
+               | SASLInvalidMechanism     -- ^ The mechanism is not supported by
-                 SASLInvalidMechanism | -- ^ The mechanism is not supported by
+                                          --   the receiving entity
-                                        --   the receiving entity
+               | SASLMalformedRequest     -- ^ Invalid syntax
-                 -- SASLMalformedRequest | -- Invalid syntax - should not happen
+               | SASLMechanismTooWeak     -- ^ The receiving entity policy
-                 SASLMechanismTooWeak | -- ^ The receiving entity policy
+                                          --   requires a stronger mechanism
-                                        --   requires a stronger mechanism
+               | SASLNotAuthorized        -- ^ Invalid credentials
-                 SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials
+                                          --   provided, or some
-                                                    --   provided, or some
+                                          --   generic authentication
-                                                    --   generic authentication
+                                          --   failure has occurred
-                                                    --   failure has occurred
+               | SASLTemporaryAuthFailure -- ^ There receiving entity reported a
-                 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.