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

Merge pull request #3 from Philonous/master 

sasl fix + jid enhancements + exports fix
master
Jon Kristensen 14 years ago
parent
b3c73c1774 fc14fb1197
commit
1932d8a1f4
5 changed files with 255 additions and 214 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 267
      src/Network/XMPP/JID.hs
  2. 7
      src/Network/XMPP/Marshal.hs
  3. 8
      src/Network/XMPP/Pickle.hs
  4. 46
      src/Network/XMPP/SASL.hs
  5. 141
      src/Network/XMPP/Types.hs

267
src/Network/XMPP/JID.hs
Unescape View File

@ -15,183 +15,174 @@ @@ -15,183 +15,174 @@
--
-- This module does not internationalize hostnames.
module Network.XMPP.JID
( JID(..)
, fromText
, fromStrings
, isBare
, isFull) where
module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where
import Control.Applicative ((<$>),(<|>))
import Control.Monad(guard)
import Network.XMPP.Types
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 Data.Maybe (fromJust, isJust)
import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse)
import Text.Parsec.ByteString (GenParser)
-- import Network.URI (isIPv4address, isIPv6address)
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 Text.NamePrep as SP
import qualified Text.StringPrep as SP
import Network.URI (isIPv4address, isIPv6address)
-- |
-- @From@ is a readability type synonym for @Address@.
import qualified Data.ByteString.Char8 as DBC (pack)
import qualified Data.Text as DT (pack, unpack)
-- | 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,"")]
-- |
-- Converts a string to a JID.
fromString :: String -> Maybe JID
instance IsString JID where
fromString = fromJust . fromText . Text.pack
fromString s = fromStrings localpart domainpart resourcepart
where
Right (localpart, domainpart, resourcepart) =
parse jidParts "" (DBC.pack s)
-- |
-- Converts a string to a JID.
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.
-- 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''
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
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)
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.c11
, SP.c12
, SP.c21
, SP.c22
, SP.c3
, SP.c4
, SP.c5
, SP.c6
, SP.c7
, SP.c8
, SP.c9
]
, 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.c12
, SP.c21
, SP.c22
, SP.c3
, SP.c4
, SP.c5
, SP.c6
, SP.c7
, SP.c8
, SP.c9
]
, SP.shouldCheckBidi = True
}

7
src/Network/XMPP/Marshal.hs
Unescape View File

@ -5,6 +5,7 @@ module Network.XMPP.Marshal where @@ -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 @@ -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)

8
src/Network/XMPP/Pickle.hs
Unescape View File

@ -10,6 +10,8 @@ module Network.XMPP.Pickle where @@ -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 (\((),()) -> ()) @@ -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) $

46
src/Network/XMPP/SASL.hs
Unescape View File

@ -16,6 +16,7 @@ import qualified Data.ByteString.Char8 as BS8 @@ -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
@ -26,6 +27,7 @@ import qualified Data.Text.Encoding as Text @@ -26,6 +27,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
@ -87,20 +89,18 @@ createResponse :: Random.RandomGen g @@ -87,20 +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 .
B64.encode . BS8.pack . take 8 $ Random.randoms g
nc = "00000001"
digestURI = ("xmpp/" `BS.append` realm)
digest = md5Digest
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
uname
realm
passwd
@ -123,6 +123,7 @@ createResponse g hostname username passwd' pairs = let @@ -123,6 +123,7 @@ createResponse g hostname username passwd' pairs = let
in Text.decodeUtf8 $ B64.encode response
where
quote x = BS.concat ["\"",x,"\""]
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
@ -142,6 +143,7 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString @@ -142,6 +143,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
@ -163,10 +165,24 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= @@ -163,10 +165,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"

141
src/Network/XMPP/Types.hs
Unescape View File

@ -11,7 +11,39 @@ @@ -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)
@ -33,6 +65,8 @@ import Data.XML.Types @@ -33,6 +65,8 @@ import Data.XML.Types
import qualified Network as N
import Network.XMPP.JID
import System.IO
@ -74,38 +108,6 @@ instance Read StanzaId where @@ -74,38 +108,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.
@ -472,39 +474,68 @@ instance Read StanzaErrorCondition where @@ -472,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.

Write Preview
Loading…
Cancel
Save