From 113ca4034fca122d0a0a9b48dec77cb9913ff1a3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 19:28:01 +0200 Subject: [PATCH 1/6] work in JID.hs --- src/Network/XMPP/JID.hs | 232 ++++++++++++++++------------------------ 1 file changed, 93 insertions(+), 139 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 2076f94..5b6f1fd 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,183 +15,137 @@ -- -- This module does not internationalize hostnames. - module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where -import Network.XMPP.Types - -import Data.Maybe (fromJust, isJust) -import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) -import Text.Parsec.ByteString (GenParser) +import Control.Applicative ((<$>),(<|>)) +import Control.Monad(guard) -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) +import qualified Data.Attoparsec.Text as AP +import Data.Text (Text) +import qualified Data.Text as Text -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) +-- import Network.URI (isIPv4address, isIPv6address) +import Network.XMPP.Types +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP -- | -- Converts a string to a JID. - fromString :: String -> Maybe JID - -fromString s = fromStrings localpart domainpart resourcepart +fromString s = fromStrings l d r where - Right (localpart, domainpart, resourcepart) = - parse jidParts "" (DBC.pack s) - + Right (l, d, r) = + AP.parseOnly jidParts (Text.pack s) -- | -- Converts localpart, domainpart, and resourcepart strings to a JID. - -- Runs the appropriate stringprep profiles and validates the parts. - -fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID - -fromStrings l s r - | domainpart == Nothing = Nothing - | otherwise = if validateNonDomainpart localpart && - isJust domainpart' && - validateNonDomainpart resourcepart - then Just (JID localpart (fromJust domainpart') resourcepart) - else Nothing +fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID +fromStrings l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ JID localPart domainPart resourcePart where - - -- Applies the nodeprep profile on the localpart string, if any. - localpart :: Maybe String - localpart = case l of - Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of - Just l'' -> Just $ DT.unpack l'' - Nothing -> Nothing - Nothing -> Nothing - - -- Applies the nameprep profile on the domainpart string. - -- TODO: Allow unassigned? - domainpart :: Maybe String - domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of - Just s' -> Just $ DT.unpack s' - Nothing -> Nothing - - -- Applies the resourceprep profile on the resourcepart string, if - -- any. - resourcepart :: Maybe String - resourcepart = case r of - Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of - Just r'' -> Just $ DT.unpack r'' - Nothing -> Nothing - Nothing -> Nothing - -- Returns the domainpart if it was a valid IP or if the toASCII -- function was successful, or Nothing otherwise. - domainpart' :: Maybe String - domainpart' | isIPv4address s || isIPv6address s = Just s - | validHostname s = Just s - | otherwise = Nothing - - -- Validates that non-domainpart strings have an appropriate - -- length. - validateNonDomainpart :: Maybe String -> Bool - validateNonDomainpart Nothing = True - validateNonDomainpart (Just l) = validPartLength l - where - validPartLength :: String -> Bool - validPartLength p = length p > 0 && length p < 1024 + validDomainPart _s = True -- TODO + -- isIPv4address s || isIPv6address s || validHostname s + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - + -- validHostname :: Text -> Bool + -- validHostname _ = True -- TODO -- | Returns True if the JID is `bare', and False otherwise. - isBare :: JID -> Bool - isBare j | resourcepart j == Nothing = True | otherwise = False - -- | Returns True if the JID is `full', and False otherwise. - isFull :: JID -> Bool - isFull jid = not $ isBare jid - -- Parses an JID string and returns its three parts. It performs no -- validation or transformations. We are using Parsec to parse the -- JIDs. There is no input for which 'jidParts' fails. - -jidParts :: GenParser Char st (Maybe String, String, Maybe String) - +jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts = do - - -- Read until we reach an '@', a '/', or EOF. - a <- many $ noneOf ['@', '/'] - - -- Case 1: We found an '@', and thus the localpart. At least the - -- domainpart is remaining. Read the '@' and until a '/' or EOF. - do - char '@' - b <- many $ noneOf ['/'] - - -- Case 1A: We found a '/' and thus have all the JID parts. Read - -- the '/' and until EOF. - do - char '/' -- Resourcepart remaining - c <- many $ anyToken -- Parse resourcepart - eof - return (Just a, b, Just c) - - -- Case 1B: We have reached EOF; the JID is in the form - -- localpart@domainpart. - <|> do - eof - return (Just a, b, Nothing) - - -- Case 2: We found a '/'; the JID is in the form - -- domainpart/resourcepart. - <|> do - char '/' - b <- many $ anyToken - eof - return (Nothing, a, Just b) - - -- Case 3: We have reached EOF; we have an JID consisting of only - -- a domainpart. - <|> do - eof - return (Nothing, a, Nothing) - - -nodeprepProfile :: StringPrepProfile - -nodeprepProfile = Profile { maps = [b1, b2] - , shouldNormalize = True - , prohibited = [a1] ++ [c11, c12, c21, c22, - c3, c4, c5, c6, c7, - c8, c9] - , shouldCheckBidi = True } - + a <- firstPartP + b <- Just <$> domainPartP <|> (return Nothing) + c <- Just <$> resourcePartP <|> (return Nothing) + case (a,b,c) of + -- Whether or not we have a resource part, if there is no "@" + -- x is the domain + (x, Nothing, z) -> return (Nothing, x, z) + -- When we do have an "@", x is the localpart + (x, Just y, z) -> return (Just x, y, z) + where + firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + resourcePartP = do + _ <- AP.char '/' + AP.takeText + + +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile + { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.shouldCheckBidi = True + } -- These needs to be checked for after normalization. We could also -- look up the Unicode mappings and include a list of characters in -- the prohibited field above. Let's defer that until we know that we -- are going to use stringprep. - +nodeprepExtraProhibitedCharacters :: [Char] nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', '\x3C', '\x3E', '\x40'] - - -resourceprepProfile :: StringPrepProfile - -resourceprepProfile = Profile { maps = [b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, - c3, c4, c5, c6, - c7, c8, c9] - , shouldCheckBidi = True } +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile + { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + , SP.c12 + , SP.c21 + , SP.c22 + ] + , SP.shouldCheckBidi = True + } From 2f13935c0ba25ef13d963e7f9db72fde55b4402d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 18 Apr 2012 20:29:46 +0200 Subject: [PATCH 2/6] fixed JID parsing, moved JID to JID.hs --- src/Network/XMPP/JID.hs | 107 +++++++++++++++++++++++++------------- src/Network/XMPP/Types.hs | 34 +----------- 2 files changed, 74 insertions(+), 67 deletions(-) diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 5b6f1fd..b1f0783 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,28 +15,64 @@ -- -- This module does not internationalize hostnames. -module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where +module Network.XMPP.JID + ( JID(..) + , fromText + , fromStrings + , isBare + , isFull) where import Control.Applicative ((<$>),(<|>)) import Control.Monad(guard) import qualified Data.Attoparsec.Text as AP +import Data.Maybe(fromJust) +import qualified Data.Set as Set +import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text -- import Network.URI (isIPv4address, isIPv6address) -import Network.XMPP.Types import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP +-- | +-- @From@ is a readability type synonym for @Address@. + +-- | Jabber ID (JID) datatype +data JID = JID { localpart :: !(Maybe Text) + -- ^ Account name + , domainpart :: !Text + -- ^ Server adress + , resourcepart :: !(Maybe Text) + -- ^ Resource name + } + +instance Show JID where + show (JID nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +instance Read JID where + readsPrec _ x = case fromText (Text.pack x) of + Nothing -> [] + Just j -> [(j,"")] + + +instance IsString JID where + fromString = fromJust . fromText . Text.pack + -- | -- Converts a string to a JID. -fromString :: String -> Maybe JID -fromString s = fromStrings l d r - where - Right (l, d, r) = - AP.parseOnly jidParts (Text.pack s) +fromText :: Text -> Maybe JID +fromText t = do + (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t + fromStrings l d r + where + eitherToMaybe = either (const Nothing) Just + -- | -- Converts localpart, domainpart, and resourcepart strings to a JID. @@ -48,6 +84,8 @@ fromStrings l d r = do Just l'-> do l'' <- SP.runStringPrep nodeprepProfile l' guard $ validPartLength l'' + let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters + guard $ Text.all (`Set.notMember` prohibMap) l'' return $ Just l'' domainPart <- SP.runStringPrep (SP.namePrepProfile False) d guard $ validDomainPart domainPart @@ -93,33 +131,32 @@ jidParts = do (x, Nothing, z) -> return (Nothing, x, z) -- When we do have an "@", x is the localpart (x, Just y, z) -> return (Just x, y, z) - where - firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) - domainPartP = do + +firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/']) +domainPartP = do _ <- AP.char '@' AP.takeWhile1 (/= '/') - resourcePartP = do +resourcePartP = do _ <- AP.char '/' AP.takeText - nodeprepProfile :: SP.StringPrepProfile nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] , SP.shouldNormalize = True , SP.prohibited = [SP.a1 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - , SP.c11 - , SP.c12 - , SP.c21 - , SP.c22 - ] + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] , SP.shouldCheckBidi = True } @@ -136,16 +173,16 @@ resourceprepProfile = SP.Profile { SP.maps = [SP.b1] , SP.shouldNormalize = True , SP.prohibited = [ SP.a1 - , SP.c3 - , SP.c4 - , SP.c5 - , SP.c6 - , SP.c7 - , SP.c8 - , SP.c9 - , SP.c12 - , SP.c21 - , SP.c22 - ] + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] , SP.shouldCheckBidi = True } diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index a3e827c..834c265 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -33,6 +33,8 @@ import Data.XML.Types import qualified Network as N +import Network.XMPP.JID + import System.IO @@ -74,38 +76,6 @@ instance Read StanzaId where instance IsString StanzaId where fromString = SI . Text.pack --- | --- @From@ is a readability type synonym for @Address@. - --- | Jabber ID (JID) datatype -data JID = JID { localpart :: !(Maybe Text) - -- ^ Account name - , domainpart :: !Text - -- ^ Server adress - , resourcepart :: !(Maybe Text) - -- ^ Resource name - } - -instance Show JID where - show (JID nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ - (Text.unpack dmn) ++ - maybe "" (('/' :) . Text.unpack) res - -parseJID :: [Char] -> [JID] -parseJID jid = do - (jid', rst) <- case L.splitOn "@" jid of - [rest] -> [(JID Nothing, rest)] - [nd,rest] -> [(JID (Just (Text.pack nd)), rest)] - _ -> [] - case L.splitOn "/" rst of - [dmn] -> [jid' (Text.pack dmn) Nothing] - [dmn, rsrc] -> [jid' (Text.pack dmn) (Just (Text.pack rsrc))] - _ -> [] - -instance Read JID where - readsPrec _ x = (,"") <$> parseJID x - -- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- these two sub-types. From a7c8ca2202b58312b50ca75b47d34763f62fc981 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 11:29:18 +0200 Subject: [PATCH 3/6] Explicit export list for Network.XMPP.Types --- src/Network/XMPP/Types.hs | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 834c265..f514950 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -11,7 +11,39 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Types where +module Network.XMPP.Types + ( IQError(..) + , IQRequest(..) + , IQRequestType(..) + , IQResponse(..) + , IQResult(..) + , IdGenerator(..) + , LangTag(..) + , Message(..) + , MessageError(..) + , MessageType(..) + , Presence(..) + , PresenceError(..) + , PresenceType(..) + , SASLError(..) + , SASLFailure(..) + , ServerAddress(..) + , ServerFeatures(..) + , ShowType(..) + , Stanza(..) + , StanzaError(..) + , StanzaErrorCondition(..) + , StanzaErrorType(..) + , StanzaId(..) + , StreamError(..) + , Version(..) + , XMPPConMonad(..) + , XMPPConState(..) + , XMPPT(..) + , parseLangTag + , module Network.XMPP.JID + ) + where -- import Network.XMPP.Utilities (idGenerator) From f97d5c31c61dfb87dc19db6acd44592e7179168f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 12:52:53 +0200 Subject: [PATCH 4/6] 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. From 6c6f99c60005985932f94bba7b5e16d7b897f076 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 13:43:34 +0200 Subject: [PATCH 5/6] fixed word8 problem in SASL --- src/Network/XMPP/SASL.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index bff4caa..15de4c2 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -93,12 +93,10 @@ 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 - + B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g nc = "00000001" digestURI = ("xmpp/" `BS.append` realm) digest = md5Digest @@ -124,6 +122,7 @@ createResponse g hostname username passwd' pairs = let in Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] + toWord8 x = fromIntegral (abs (x :: Int) `mod` 256) :: Binary.Word8 toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do @@ -143,6 +142,7 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString hashRaw = toStrict . Binary.encode . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + toStrict :: BL.ByteString -> BS8.ByteString toStrict = BS.concat . BL.toChunks From fc14fb11970f59d15cdef0eb67df4d3237ae61b6 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 13:48:48 +0200 Subject: [PATCH 6/6] SASL alignment, simplified conversion --- src/Network/XMPP/SASL.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 15de4c2..bd9d713 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L +import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types @@ -88,18 +89,18 @@ createResponse :: Random.RandomGen g -> [(BS8.ByteString, BS8.ByteString)] -> Text createResponse g hostname username passwd' pairs = let - Just qop = L.lookup "qop" pairs + Just qop = L.lookup "qop" pairs Just nonce = L.lookup "nonce" pairs - 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) + uname = Text.encodeUtf8 username + passwd = Text.encodeUtf8 passwd' + realm = Text.encodeUtf8 hostname + -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. - cnonce = BS.tail . BS.init . + cnonce = BS.tail . BS.init . B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g - nc = "00000001" - digestURI = ("xmpp/" `BS.append` realm) - digest = md5Digest + nc = "00000001" + digestURI = ("xmpp/" `BS.append` realm) + digest = md5Digest uname realm passwd @@ -122,7 +123,7 @@ createResponse g hostname username passwd' pairs = let in Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] - toWord8 x = fromIntegral (abs (x :: Int) `mod` 256) :: Binary.Word8 + toWord8 x = fromIntegral (x :: Int) :: Word8 toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do