diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index a407983..21506a8 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -37,22 +37,21 @@ module Network.Xmpp.Types , XmppConnectionState(..) , XmppT(..) , XmppStreamError(..) - , parseLangTag , module Network.Xmpp.Jid ) where -import Control.Applicative((<$>)) +import Control.Applicative ((<$>), many) import Control.Exception import Control.Monad.IO.Class import Control.Monad.State.Strict import Control.Monad.Error - +import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Conduit import Data.String(IsString(..)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) @@ -590,14 +589,12 @@ instance Error StreamError where noMsg = StreamConnectionError newtype IdGenerator = IdGenerator (IO Text) --- Version numbers are displayed as ".". +-- | XMPP version number. Displayed as ".". 2.4 is lesser than +-- 2.13, which in turn is lesser than 12.3. data Version = Version { majorVersion :: Integer , minorVersion :: Integer } deriving (Eq) -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) - -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. instance Ord Version where @@ -605,34 +602,72 @@ instance Ord Version where | amajor /= bmajor = compare amajor bmajor | otherwise = compare aminor bminor --- The language tag in the form of "en-US". It has a primary tag, followed by a --- number of subtags. +instance Read Version where + readsPrec _ txt = [(fromJust $ versionFromText $ Text.pack txt, "")] + +instance Show Version where + show (Version major minor) = (show major) ++ "." ++ (show minor) + +-- Converts a "." numeric version number to a @Version@ object. +versionFromText :: Text.Text -> Maybe Version +versionFromText s = case AP.parseOnly versionParser s of + Right version -> Just version + Left _ -> Nothing + +-- Read numbers, a dot, more numbers, and end-of-file. +versionParser :: AP.Parser Version +versionParser = do + major <- AP.many1 AP.digit + AP.skip (== '.') + minor <- AP.many1 AP.digit + AP.endOfInput + return $ Version (read major) (read minor) + +-- | The language tag in accordance with RFC 5646 (in the form of "en-US"). It +-- has a primary tag and a number of subtags. Two language tags are considered +-- equal if and only if they contain the same tags (case-insensitive). data LangTag = LangTag { primaryTag :: Text , subtags :: [Text] } - deriving (Eq) -- TODO: remove - -instance Show LangTag where - show (LangTag p []) = Text.unpack p - show (LangTag p s) = Text.unpack . Text.concat - $ [p, "-", Text.intercalate "-" s] -- TODO: clean up --- Parses a Text string to a list of LangTag objects. TODO: Why? -parseLangTag :: Text -> [LangTag] -parseLangTag txt = case Text.splitOn "-" txt of - [] -> [] - prim: subs -> [LangTag prim subs] +instance Eq LangTag where + LangTag p s == LangTag q t = Text.toLower p == Text.toLower q && + map Text.toLower s == map Text.toLower t instance Read LangTag where - readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt) + readsPrec _ txt = [(fromJust $ langTag $ Text.pack txt, "")] --- Two language tags are considered equal of they contain the same tags --- (case-insensitive). - --- instance Eq LangTag where --- (LangTag ap as) == (LangTag bp bs) --- | length as == length bs && map toLower ap == map toLower bp = --- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs --- | otherwise = False +instance Show LangTag where + show (LangTag p []) = Text.unpack p + show (LangTag p s) = Text.unpack . Text.concat $ + [p, "-", Text.intercalate "-" s] + +-- | Parses, validates, and possibly constructs a "LangTag" object. +langTag :: Text.Text -> Maybe LangTag +langTag s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + +-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. +langTagParser :: AP.Parser LangTag +langTagParser = do + -- Read until we reach a '-' character, or EOF. This is the `primary tag'. + primTag <- tag + -- Read zero or more subtags. + subTags <- many subtag + AP.endOfInput + return $ LangTag primTag subTags + where + tag :: AP.Parser Text.Text + tag = do + t <- AP.takeWhile1 $ AP.inClass tagChars + return t + subtag :: AP.Parser Text.Text + subtag = do + AP.skip (== '-') + subtag <- tag + return subtag + tagChars :: [Char] + tagChars = ['a'..'z'] ++ ['A'..'Z'] data ServerFeatures = SF { stls :: Maybe Bool diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index f8e05a4..9326ace 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -1,8 +1,3 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the Pontarius --- distribution for more details. - --- TODO: More efficient to use Text instead of Strings for ID generation? - {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,28 +9,21 @@ import Network.Xmpp.Types import Control.Monad.STM import Control.Concurrent.STM.TVar import Prelude -import Control.Applicative (many) import qualified Data.Attoparsec.Text as AP import qualified Data.Text as Text --- | --- Creates a new @IdGenerator@. Internally, it will maintain an infinite list of --- IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the IDs --- with. Calling the function will extract an ID and update the generator's +-- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list +-- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the +-- IDs with. Calling the function will extract an ID and update the generator's -- internal state so that the same ID will not be generated again. - idGenerator :: Text.Text -> IO IdGenerator - idGenerator prefix = atomically $ do tvar <- newTVar $ ids prefix return $ IdGenerator $ next tvar - where - -- Transactionally extract the next ID from the infinite list of IDs. - next :: TVar [Text.Text] -> IO Text.Text next tvar = atomically $ do list <- readTVar tvar @@ -46,75 +34,21 @@ idGenerator prefix = atomically $ do return x -- Generates an infinite and predictable list of IDs, all beginning with the - -- provided prefix. - + -- provided prefix. Adds the prefix to all combinations of IDs (ids'). ids :: Text.Text -> [Text.Text] - - -- Adds the prefix to all combinations of IDs (ids'). ids p = map (\ id -> Text.append p id) ids' where - -- Generate all combinations of IDs, with increasing length. ids' :: [Text.Text] ids' = map Text.pack $ concatMap ids'' [1..] - -- Generates all combinations of IDs with the given length. ids'' :: Integer -> [String] ids'' 0 = [""] ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] - -- Characters allowed in IDs. repertoire :: String repertoire = ['a'..'z'] - --- Converts a "." numeric version number to a @Version@ object. -versionFromString :: Text.Text -> Maybe Version -versionFromString s = case AP.parseOnly versionParser s of - Right version -> Just version - Left _ -> Nothing - - -- Constructs a "Version" based on the major and minor version numbers. versionFromNumbers :: Integer -> Integer -> Version -versionFromNumbers major minor = Version major minor - - --- Read numbers, a dot, more numbers, and end-of-file. -versionParser :: AP.Parser Version -versionParser = do - major <- AP.many1 AP.digit - AP.skip (== '.') - minor <- AP.many1 AP.digit - AP.endOfInput - return $ Version (read major) (read minor) - - --- | Parses, validates, and possibly constructs a "LangTag" object. -langTag :: Text.Text -> Maybe LangTag -langTag s = case AP.parseOnly langTagParser s of - Right tag -> Just tag - Left _ -> Nothing - - --- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. -langTagParser :: AP.Parser LangTag -langTagParser = do - -- Read until we reach a '-' character, or EOF. This is the `primary tag'. - primTag <- tag - -- Read zero or more subtags. - subTags <- many subtag - AP.endOfInput - return $ LangTag primTag subTags - where - tag :: AP.Parser Text.Text - tag = do - t <- AP.takeWhile1 $ AP.inClass tagChars - return t - subtag :: AP.Parser Text.Text - subtag = do - AP.skip (== '-') - subtag <- tag - return subtag - tagChars :: [Char] - tagChars = ['a'..'z'] ++ ['A'..'Z'] \ No newline at end of file +versionFromNumbers major minor = Version major minor \ No newline at end of file