@ -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 , from Maybe )
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