Merge pull request #3 from Philonous/master

sasl fix + jid enhancements + exports fix

src/Network/XMPP/JID.hs

@@ -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           Network.URI (isIPv4address, isIPv6address)
-import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse)
-import Text.Parsec.ByteString (GenParser)
 
-import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22,
+import qualified Text.NamePrep as SP
-                        c3, c4, c5, c6, c7, c8, c9, runStringPrep)
+import qualified Text.StringPrep as SP
-import Text.NamePrep (namePrepProfile)
 
-import Network.URI (isIPv4address, isIPv6address)
+-- |
+-- @From@ is a readability type synonym for @Address@.
 
-import qualified Data.ByteString.Char8 as DBC (pack)
+-- | Jabber ID (JID) datatype
-import qualified Data.Text as DT (pack, unpack)
+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
+-- |
+-- 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
-        Right (localpart, domainpart, resourcepart) =
+    eitherToMaybe = either (const Nothing) Just
-            parse jidParts "" (DBC.pack s)
 
 
 -- |
 -- Converts localpart, domainpart, and resourcepart strings to a JID.
-
 -- Runs the appropriate stringprep profiles and validates the parts.
-
+fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID
-fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID
+fromStrings l d r = do
-
+        localPart <- case l of
-fromStrings l s r
+          Nothing -> return Nothing
-  | domainpart == Nothing = Nothing
+          Just l'-> do
-  | otherwise = if validateNonDomainpart localpart &&
+            l'' <- SP.runStringPrep nodeprepProfile l'
-                   isJust domainpart' &&
+            guard $ validPartLength l''
-                   validateNonDomainpart resourcepart
+            let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters
-                then Just (JID localpart (fromJust domainpart') resourcepart)
+            guard $ Text.all (`Set.notMember` prohibMap) l''
-                else Nothing
+            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
+    validDomainPart _s = True -- TODO
-    domainpart' | isIPv4address s || isIPv6address s = Just s
+      -- isIPv4address s || isIPv6address s || validHostname 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
 
+    validPartLength :: Text -> Bool
+    validPartLength p = Text.length p > 0 && Text.length p < 1024
     -- Validates a host name
-    validHostname :: String -> Bool
+    -- validHostname :: Text -> Bool
-    validHostname _ = True -- TODO
+    -- 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 :: AP.Parser (Maybe Text, Text, Maybe Text)
-jidParts :: GenParser Char st (Maybe String, String, Maybe String)
-
 jidParts = do
-
+  a <- firstPartP
-  -- Read until we reach an '@', a '/', or EOF.
+  b <- Just <$> domainPartP <|> (return Nothing)
-  a <- many $ noneOf ['@', '/']
+  c <- Just <$> resourcePartP <|> (return Nothing)
-
+  case (a,b,c) of
-  -- Case 1: We found an '@', and thus the localpart. At least the
+    -- Whether or not we have a resource part, if there is no "@"
-  -- domainpart is remaining. Read the '@' and until a '/' or EOF.
+    -- x is the domain
-  do
+    (x, Nothing, z) -> return (Nothing, x, z)
-    char '@'
+    -- When we do have an "@", x is the localpart
-    b <- many $ noneOf ['/']
+    (x, Just y, z) -> return (Just x, y, z)
-
+
-    -- Case 1A: We found a '/' and thus have all the JID parts. Read
+firstPartP = AP.takeWhile1 (AP.notInClass ['@', '/'])
-    -- the '/' and until EOF.
+domainPartP = do
-    do
+           _ <- AP.char '@'
-      char '/' -- Resourcepart remaining
+           AP.takeWhile1 (/= '/')
-      c <- many $ anyToken -- Parse resourcepart
+resourcePartP = do
-      eof
+           _ <- AP.char '/'
-      return (Just a, b, Just c)
+           AP.takeText
-
+
-    -- Case 1B: We have reached EOF; the JID is in the form
+nodeprepProfile :: SP.StringPrepProfile
-    -- localpart@domainpart.
+nodeprepProfile = SP.Profile
-      <|> do
+                             { SP.maps = [SP.b1, SP.b2]
-        eof
+                             , SP.shouldNormalize = True
-        return (Just a, b, Nothing)
+                             , SP.prohibited = [SP.a1
-
+                                               , SP.c11
-    -- Case 2: We found a '/'; the JID is in the form
+                                               , SP.c12
-    -- domainpart/resourcepart.
+                                               , SP.c21
-    <|> do
+                                               , SP.c22
-      char '/'
+                                               , SP.c3
-      b <- many $ anyToken
+                                               , SP.c4
-      eof
+                                               , SP.c5
-      return (Nothing, a, Just b)
+                                               , SP.c6
-
+                                               , SP.c7
-    -- Case 3: We have reached EOF; we have an JID consisting of only
+                                               , SP.c8
-    -- a domainpart.
+                                               , SP.c9
-    <|> do
+                                               ]
-      eof
+                             , SP.shouldCheckBidi = True
-      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 }
-
 
 -- 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 :: SP.StringPrepProfile
-
+resourceprepProfile = SP.Profile
-resourceprepProfile :: StringPrepProfile
+                                 { SP.maps = [SP.b1]
-
+                                 , SP.shouldNormalize = True
-resourceprepProfile = Profile { maps = [b1]
+                                 , SP.prohibited = [ SP.a1
-                              , shouldNormalize = True
+                                                   , SP.c12
-                              , prohibited = [a1] ++ [c12, c21, c22,
+                                                   , SP.c21
-                                                      c3, c4, c5, c6,
+                                                   , SP.c22
-                                                      c7, c8, c9]
+                                                   , SP.c3
-                              , shouldCheckBidi = True }
+                                                   , SP.c4
+                                                   , SP.c5
+                                                   , SP.c6
+                                                   , SP.c7
+                                                   , SP.c8
+                                                   , SP.c9
+                                                   ]
+                                 , SP.shouldCheckBidi = True
+                                 }

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

@@ -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
 import           Network.XMPP.Monad
 import           Network.XMPP.Stream
 import           Network.XMPP.Types
+import           Network.XMPP.Pickle
 
 import qualified System.Random as Random
 
@@ -92,12 +94,10 @@ createResponse g hostname username passwd' pairs = let
   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)
-  -- 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
@@ -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
 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=
 
 
 -- 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

@@ -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
 
 import qualified Network as N
 
+import           Network.XMPP.JID
+
 import           System.IO
 
 
@@ -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
 -- =============================================================================
 
 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
-                 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
-                 -- SASLMalformedRequest | -- Invalid syntax - should not happen
+               | SASLMalformedRequest     -- ^ Invalid syntax
-                 SASLMechanismTooWeak | -- ^ The receiving entity policy
+               | SASLMechanismTooWeak     -- ^ The receiving entity policy
                                           --   requires a stronger mechanism
-                 SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials
+               | SASLNotAuthorized        -- ^ Invalid credentials
                                           --   provided, or some
                                           --   generic authentication
                                           --   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.