You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
94 lines
3.9 KiB
94 lines
3.9 KiB
12 years ago
|
{-# LANGUAGE TemplateHaskell #-}
|
||
|
|
module Tests.Arbitrary.Xmpp where
|
||
|
|
|
||
|
|
import Control.Applicative ((<$>), (<*>))
|
||
|
|
import Data.Maybe
|
||
|
|
import qualified Data.Text as Text
|
||
|
|
import Network.Xmpp.Types
|
||
|
|
import Test.QuickCheck
|
||
|
|
import Test.QuickCheck.Instances()
|
||
|
|
import qualified Text.CharRanges as Ranges
|
||
|
|
import qualified Text.StringPrep as SP
|
||
|
|
import qualified Text.StringPrep.Profiles as SP
|
||
|
|
|
||
|
|
import Tests.Arbitrary.Common
|
||
|
|
import Tests.Arbitrary.Xml ()
|
||
|
|
|
||
|
|
import Data.Derive.Arbitrary
|
||
|
|
import Data.DeriveTH
|
||
|
|
|
||
|
|
|
||
|
|
instance Arbitrary Jid where
|
||
|
|
arbitrary = do
|
||
|
|
Just jid <- tryJid `suchThat` isJust
|
||
|
|
return jid
|
||
|
|
where
|
||
|
|
tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile)
|
||
|
|
<*> genString (SP.namePrepProfile False)
|
||
|
|
<*> maybeGen (genString resourceprepProfile)
|
||
|
|
maybeGen g = oneof [ return Nothing
|
||
|
|
, Just <$> g
|
||
|
|
]
|
||
|
|
genString profile = Text.pack . take 1024 <$> listOf1 genChar
|
||
|
|
where
|
||
|
|
genChar = arbitrary `suchThat` (not . isProhibited)
|
||
|
|
prohibited = Ranges.toSet $ concat (SP.prohibited profile)
|
||
|
|
isProhibited x = Ranges.member x prohibited
|
||
|
|
|| x `elem` "@/"
|
||
|
|
|
||
|
|
shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkTextMaybe lp]
|
||
|
|
++ [ Jid lp dp' rp | dp' <- shrinkText1 dp]
|
||
|
|
++ [ Jid lp dp rp' | rp' <- shrinkTextMaybe rp]
|
||
|
|
|
||
|
|
|
||
|
|
string :: SP.StringPrepProfile -> Gen [Char]
|
||
|
|
string profile = take 1024 <$> listOf1 genChar
|
||
|
|
where
|
||
|
|
genChar = arbitrary `suchThat` (not . isProhibited)
|
||
|
|
prohibited = Ranges.toSet $ concat (SP.prohibited profile)
|
||
|
|
isProhibited x = Ranges.member x prohibited
|
||
|
|
|| x `elem` "@/"
|
||
|
|
|
||
|
|
instance Arbitrary LangTag where
|
||
|
|
arbitrary = LangTag <$> genTag <*> listOf genTag
|
||
|
|
where genTag = fmap Text.pack . listOf1 . elements $ ['a'..'z'] ++ ['A'..'Z']
|
||
|
|
shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] ++
|
||
|
|
[LangTag lt lts' | lts' <- filter (not . Text.null)
|
||
|
|
<$> shrink lts]
|
||
|
|
|
||
|
|
|
||
|
|
instance Arbitrary StanzaError where
|
||
|
|
arbitrary = StanzaError <$> arbitrary
|
||
|
|
<*> arbitrary
|
||
|
|
<*> oneof [ return Nothing
|
||
|
|
, Just <$> ((,) <$> arbitrary <*> genText1)
|
||
|
|
]
|
||
|
|
<*> arbitrary
|
||
|
|
|
||
|
|
-- Auto-derive trivial instances
|
||
|
|
concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType
|
||
|
|
, ''StanzaErrorCondition
|
||
|
|
, ''IQRequestType
|
||
|
|
, ''IQRequest
|
||
|
|
, ''IQResult
|
||
|
|
, ''IQError
|
||
|
|
, ''MessageType
|
||
|
|
, ''Message
|
||
|
|
, ''MessageError
|
||
|
|
, ''PresenceType
|
||
|
|
, ''Presence
|
||
|
|
, ''PresenceError
|
||
|
|
, ''Stanza
|
||
|
|
|
||
|
|
, ''SaslError
|
||
|
|
, ''SaslFailure
|
||
|
|
, ''StreamErrorCondition
|
||
|
|
, ''StreamErrorInfo
|
||
|
|
-- , ''HandshakeFailed
|
||
|
|
-- , ''XmppTlsError
|
||
|
|
-- , ''AuthFailure
|
||
|
|
, ''Version
|
||
|
|
, ''ConnectionState
|
||
|
|
, ''TlsBehaviour
|
||
|
|
]
|