module Network.Xmpp.Jid
( Jid(..)
, fromText
, fromStrings
, isBare
, isFull
) where
import Control.Applicative ((<$>),(<|>))
import Control.Monad(guard)
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 qualified Text.NamePrep as SP
import qualified Text.StringPrep as SP
data Jid = Jid {
localpart :: !(Maybe Text)
, domainpart :: !Text
, resourcepart :: !(Maybe Text)
} deriving Eq
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,"")]
instance IsString Jid where
fromString = fromJust . fromText . Text.pack
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
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
validDomainPart :: Text -> Bool
validDomainPart _s = True
validPartLength :: Text -> Bool
validPartLength p = Text.length p > 0 && Text.length p < 1024
isBare :: Jid -> Bool
isBare j | resourcepart j == Nothing = True
| otherwise = False
isFull :: Jid -> Bool
isFull = not . isBare
jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
jidParts = do
a <- AP.takeWhile1 (AP.notInClass ['@', '/'])
do
b <- domainPartP
do
c <- resourcePartP
return (Just a, b, Just c)
<|> do
AP.endOfInput
return (Just a, b, Nothing)
<|> do
b <- resourcePartP
AP.endOfInput
return (Nothing, a, Just b)
<|> do
AP.endOfInput
return (Nothing, a, Nothing)
where
domainPartP :: AP.Parser Text
domainPartP = do
_ <- AP.char '@'
AP.takeWhile1 (/= '/')
resourcePartP :: AP.Parser Text
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
}
nodeprepExtraProhibitedCharacters :: [Char]
nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',
'\x3C', '\x3E', '\x40']
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
}