Browse Source

miscellaneous Version and LangTag improvements

removed parseLangTag, using langTag instead
versionFromString renamed versionFromText
versionFromText, versionParser, langTag, langTagParser moved to Types
case-insensitive Eq instance for LangTag
Read instance for Version
minor documentation and formatting enhancements
formatting and other clean-up in the Utilities modules
master
Jon Kristensen 14 years ago
parent
commit
038129c5b7
  1. 95
      source/Network/Xmpp/Types.hs
  2. 74
      source/Network/Xmpp/Utilities.hs

95
source/Network/Xmpp/Types.hs

@ -37,22 +37,21 @@ module Network.Xmpp.Types
, XmppConnectionState(..) , XmppConnectionState(..)
, XmppT(..) , XmppT(..)
, XmppStreamError(..) , XmppStreamError(..)
, parseLangTag
, module Network.Xmpp.Jid , module Network.Xmpp.Jid
) )
where where
import Control.Applicative((<$>)) import Control.Applicative ((<$>), many)
import Control.Exception import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Error import Control.Monad.Error
import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.String(IsString(..)) import Data.String(IsString(..))
import Data.Maybe (fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Typeable(Typeable) import Data.Typeable(Typeable)
@ -590,14 +589,12 @@ instance Error StreamError where noMsg = StreamConnectionError
newtype IdGenerator = IdGenerator (IO Text) newtype IdGenerator = IdGenerator (IO Text)
-- Version numbers are displayed as "<major>.<minor>". -- | XMPP version number. Displayed as "<major>.<minor>". 2.4 is lesser than
-- 2.13, which in turn is lesser than 12.3.
data Version = Version { majorVersion :: Integer data Version = Version { majorVersion :: Integer
, minorVersion :: Integer } deriving (Eq) , 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 -- If the major version numbers are not equal, compare them. Otherwise, compare
-- the minor version numbers. -- the minor version numbers.
instance Ord Version where instance Ord Version where
@ -605,34 +602,72 @@ instance Ord Version where
| amajor /= bmajor = compare amajor bmajor | amajor /= bmajor = compare amajor bmajor
| otherwise = compare aminor bminor | otherwise = compare aminor bminor
-- The language tag in the form of "en-US". It has a primary tag, followed by a instance Read Version where
-- number of subtags. readsPrec _ txt = [(fromJust $ versionFromText $ Text.pack txt, "")]
instance Show Version where
show (Version major minor) = (show major) ++ "." ++ (show minor)
-- Converts a "<major>.<minor>" 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 data LangTag = LangTag { primaryTag :: Text
, subtags :: [Text] } , subtags :: [Text] }
deriving (Eq) -- TODO: remove
instance Show LangTag where instance Eq LangTag where
show (LangTag p []) = Text.unpack p LangTag p s == LangTag q t = Text.toLower p == Text.toLower q &&
show (LangTag p s) = Text.unpack . Text.concat map Text.toLower s == map Text.toLower t
$ [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 Read LangTag where 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 instance Show LangTag where
-- (LangTag ap as) == (LangTag bp bs) show (LangTag p []) = Text.unpack p
-- | length as == length bs && map toLower ap == map toLower bp = show (LangTag p s) = Text.unpack . Text.concat $
-- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs [p, "-", Text.intercalate "-" s]
-- | otherwise = False
-- | 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 data ServerFeatures = SF
{ stls :: Maybe Bool { stls :: Maybe Bool

74
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 #-} {-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -14,28 +9,21 @@ import Network.Xmpp.Types
import Control.Monad.STM import Control.Monad.STM
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Prelude import Prelude
import Control.Applicative (many)
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import qualified Data.Text as Text import qualified Data.Text as Text
-- | -- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list
-- Creates a new @IdGenerator@. Internally, it will maintain an infinite list of -- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the
-- IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the IDs -- IDs with. Calling the function will extract an ID and update the generator's
-- 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. -- internal state so that the same ID will not be generated again.
idGenerator :: Text.Text -> IO IdGenerator idGenerator :: Text.Text -> IO IdGenerator
idGenerator prefix = atomically $ do idGenerator prefix = atomically $ do
tvar <- newTVar $ ids prefix tvar <- newTVar $ ids prefix
return $ IdGenerator $ next tvar return $ IdGenerator $ next tvar
where where
-- Transactionally extract the next ID from the infinite list of IDs. -- Transactionally extract the next ID from the infinite list of IDs.
next :: TVar [Text.Text] -> IO Text.Text next :: TVar [Text.Text] -> IO Text.Text
next tvar = atomically $ do next tvar = atomically $ do
list <- readTVar tvar list <- readTVar tvar
@ -46,75 +34,21 @@ idGenerator prefix = atomically $ do
return x return x
-- Generates an infinite and predictable list of IDs, all beginning with the -- 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] ids :: Text.Text -> [Text.Text]
-- Adds the prefix to all combinations of IDs (ids').
ids p = map (\ id -> Text.append p id) ids' ids p = map (\ id -> Text.append p id) ids'
where where
-- Generate all combinations of IDs, with increasing length. -- Generate all combinations of IDs, with increasing length.
ids' :: [Text.Text] ids' :: [Text.Text]
ids' = map Text.pack $ concatMap ids'' [1..] ids' = map Text.pack $ concatMap ids'' [1..]
-- Generates all combinations of IDs with the given length. -- Generates all combinations of IDs with the given length.
ids'' :: Integer -> [String] ids'' :: Integer -> [String]
ids'' 0 = [""] ids'' 0 = [""]
ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)]
-- Characters allowed in IDs. -- Characters allowed in IDs.
repertoire :: String repertoire :: String
repertoire = ['a'..'z'] repertoire = ['a'..'z']
-- Converts a "<major>.<minor>" 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. -- Constructs a "Version" based on the major and minor version numbers.
versionFromNumbers :: Integer -> Integer -> Version versionFromNumbers :: Integer -> Integer -> Version
versionFromNumbers major minor = Version major minor 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']
Loading…
Cancel
Save