asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

add NonemptyText type and adapt code where necessary

master
Philipp Balzarek 12 years ago
parent
99880c2549
commit
389389804c
7 changed files with 162 additions and 125 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      source/Network/Xmpp/Lens.hs
  2. 9
      source/Network/Xmpp/Marshal.hs
  3. 4
      source/Network/Xmpp/Stream.hs
  4. 101
      source/Network/Xmpp/Types.hs
  5. 4
      tests/Tests/Arbitrary/Common.hs
  6. 24
      tests/Tests/Arbitrary/Xmpp.hs
  7. 135
      tests/Tests/Picklers.hs

2
source/Network/Xmpp/Lens.hs
Unescape View File

@ -354,7 +354,7 @@ stanzaErrorConditionL :: Lens StanzaError StanzaErrorCondition
stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = x} = stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = x} =
(\x' -> se{stanzaErrorCondition = x'}) <$> inj x (\x' -> se{stanzaErrorCondition = x'}) <$> inj x
stanzaErrorTextL :: Lens StanzaError (Maybe (Maybe LangTag, Text)) stanzaErrorTextL :: Lens StanzaError (Maybe (Maybe LangTag, NonemptyText))
stanzaErrorTextL inj se@StanzaError{stanzaErrorText = x} = stanzaErrorTextL inj se@StanzaError{stanzaErrorText = x} =
(\x' -> se{stanzaErrorText = x'}) <$> inj x (\x' -> se{stanzaErrorText = x'}) <$> inj x

9
source/Network/Xmpp/Marshal.hs
Unescape View File

@ -17,6 +17,9 @@ import Data.Text
import Network.Xmpp.Types import Network.Xmpp.Types
xpNonemptyText :: PU Text NonemptyText
xpNonemptyText = ("xpNonemptyText" , "") <?+> xpWrap Nonempty fromNonempty xpText
xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
xpStreamStanza = xpEither xpStreamError xpStanza xpStreamStanza = xpEither xpStreamError xpStanza
@ -124,7 +127,7 @@ xpErrorCondition = ("xpErrorCondition" , "") <?+> xpWrapEither
"urn:ietf:params:xml:ns:xmpp-stanzas" "urn:ietf:params:xml:ns:xmpp-stanzas"
xpStanzaErrorCondition xpStanzaErrorCondition
xpUnit xpUnit
(xpOption $ xpContent xpId) (xpOption $ xpContent xpNonemptyText)
) )
xpStanzaError :: PU [Node] StanzaError xpStanzaError :: PU [Node] StanzaError
@ -137,7 +140,7 @@ xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap
xpErrorCondition xpErrorCondition
(xpOption $ xpElem "{jabber:client}text" (xpOption $ xpElem "{jabber:client}text"
(xpAttrImplied xmlLang xpLang) (xpAttrImplied xmlLang xpLang)
(xpContent xpText) (xpContent xpNonemptyText)
) )
(xpOption xpElemVerbatim) (xpOption xpElemVerbatim)
) )
@ -215,7 +218,7 @@ xpStreamError = ("xpStreamError" , "") <?+> xpWrap
(xpOption $ xpElem (xpOption $ xpElem
"{urn:ietf:params:xml:ns:xmpp-streams}text" "{urn:ietf:params:xml:ns:xmpp-streams}text"
xpLangTag xpLangTag
(xpContent xpId) (xpContent xpNonemptyText)
) )
(xpOption xpElemVerbatim) -- Application specific error conditions (xpOption xpElemVerbatim) -- Application specific error conditions
) )

4
source/Network/Xmpp/Stream.hs
Unescape View File

@ -126,7 +126,7 @@ startStream = runErrorT $ do
ErrorT . pushOpenElement . streamNSHack $ ErrorT . pushOpenElement . streamNSHack $
pickleElem xpStream ( "1.0" pickleElem xpStream ( "1.0"
, expectedTo , expectedTo
, Just (Jid Nothing address Nothing) , Just (Jid Nothing (Nonempty address) Nothing)
, Nothing , Nothing
, preferredLang $ streamConfiguration st , preferredLang $ streamConfiguration st
) )
@ -145,7 +145,7 @@ startStream = runErrorT $ do
-- If `from' is set, we verify that it's the correct one. TODO: Should we -- If `from' is set, we verify that it's the correct one. TODO: Should we
-- check against the realm instead? -- check against the realm instead?
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> | isJust from && (from /= Just (Jid Nothing (Nonempty . fromJust $ streamAddress st) Nothing)) ->
closeStreamWithError StreamInvalidFrom Nothing closeStreamWithError StreamInvalidFrom Nothing
"Stream from is invalid" "Stream from is invalid"
| to /= expectedTo -> | to /= expectedTo ->

101
source/Network/Xmpp/Types.hs
Unescape View File

@ -13,7 +13,10 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Types module Network.Xmpp.Types
( IQError(..) ( NonemptyText(..)
, nonEmpty
, text
, IQError(..)
, IQRequest(..) , IQRequest(..)
, IQRequestType(..) , IQRequestType(..)
, IQResponse(..) , IQResponse(..)
@ -68,8 +71,7 @@ module Network.Xmpp.Types
, parseJid , parseJid
, TlsBehaviour(..) , TlsBehaviour(..)
, AuthFailure(..) , AuthFailure(..)
) ) where
where
import Control.Applicative ((<$>), (<|>), many) import Control.Applicative ((<$>), (<|>), many)
import Control.Concurrent.STM import Control.Concurrent.STM
@ -77,9 +79,11 @@ import Control.Exception
import Control.Monad.Error import Control.Monad.Error
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Char (isSpace)
import Data.Conduit import Data.Conduit
import Data.Default import Data.Default
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.String (IsString, fromString)
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)
@ -87,6 +91,7 @@ import Data.XML.Types
#if WITH_TEMPLATE_HASKELL #if WITH_TEMPLATE_HASKELL
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import qualified Language.Haskell.TH.Syntax as TH
#endif #endif
import Network import Network
import Network.DNS import Network.DNS
@ -95,6 +100,25 @@ import Network.TLS.Extra
import qualified Text.StringPrep as SP import qualified Text.StringPrep as SP
import qualified Text.StringPrep.Profiles as SP import qualified Text.StringPrep.Profiles as SP
-- | Type of Texts that contain at least on non-space character
newtype NonemptyText = Nonempty {fromNonempty :: Text}
deriving (Show, Read, Eq, Ord)
instance IsString NonemptyText where
fromString str = case nonEmpty (Text.pack str) of
Nothing -> error $ "NonemptyText fromString called on empty or " ++
"all-whitespace string"
Just r -> r
-- | Check that Text contains at least one non-space character wrap it
nonEmpty :: Text -> Maybe NonemptyText
nonEmpty txt = if Text.all isSpace txt then Nothing else Just (Nonempty txt)
-- | Same as 'fromNonempty'
text :: NonemptyText -> Text
text (Nonempty txt) = txt
{-# INLINE text #-}
-- | The Xmpp communication primities (Message, Presence and Info/Query) are -- | The Xmpp communication primities (Message, Presence and Info/Query) are
-- called stanzas. -- called stanzas.
data Stanza = IQRequestS !IQRequest data Stanza = IQRequestS !IQRequest
@ -151,8 +175,6 @@ data Message = Message { messageID :: !(Maybe Text)
, messagePayload :: ![Element] , messagePayload :: ![Element]
} deriving (Eq, Show) } deriving (Eq, Show)
-- | An empty message -- | An empty message
message :: Message message :: Message
message = Message { messageID = Nothing message = Message { messageID = Nothing
@ -272,7 +294,7 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
data StanzaError = StanzaError data StanzaError = StanzaError
{ stanzaErrorType :: StanzaErrorType { stanzaErrorType :: StanzaErrorType
, stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorCondition :: StanzaErrorCondition
, stanzaErrorText :: Maybe (Maybe LangTag, Text) , stanzaErrorText :: Maybe (Maybe LangTag, NonemptyText)
, stanzaErrorApplicationSpecificCondition :: Maybe Element , stanzaErrorApplicationSpecificCondition :: Maybe Element
} deriving (Eq, Show) } deriving (Eq, Show)
@ -291,8 +313,8 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML.
-- name already exists. -- name already exists.
| FeatureNotImplemented | FeatureNotImplemented
| Forbidden -- ^ Insufficient permissions. | Forbidden -- ^ Insufficient permissions.
| Gone (Maybe Text) -- ^ Entity can no longer be | Gone (Maybe NonemptyText) -- ^ Entity can no longer
-- contacted at this -- be contacted at this
-- address. -- address.
| InternalServerError | InternalServerError
| ItemNotFound | ItemNotFound
@ -309,8 +331,9 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML.
-- words that are prohibited -- words that are prohibited
-- by the service) -- by the service)
| RecipientUnavailable -- ^ Temporarily unavailable. | RecipientUnavailable -- ^ Temporarily unavailable.
| Redirect (Maybe Text) -- ^ Redirecting to other | Redirect (Maybe NonemptyText) -- ^ Redirecting to
-- entity, usually -- other entity,
-- usually
-- temporarily. -- temporarily.
| RegistrationRequired | RegistrationRequired
| RemoteServerNotFound | RemoteServerNotFound
@ -484,7 +507,7 @@ data StreamErrorCondition
-- | Encapsulates information about an XMPP stream error. -- | Encapsulates information about an XMPP stream error.
data StreamErrorInfo = StreamErrorInfo data StreamErrorInfo = StreamErrorInfo
{ errorCondition :: !StreamErrorCondition { errorCondition :: !StreamErrorCondition
, errorText :: !(Maybe (Maybe LangTag, Text)) , errorText :: !(Maybe (Maybe LangTag, NonemptyText))
, errorXml :: !(Maybe Element) , errorXml :: !(Maybe Element)
} deriving (Show, Eq) } deriving (Show, Eq)
@ -645,7 +668,7 @@ data StreamFeatures = StreamFeatures
-- non-standard "optional" element -- non-standard "optional" element
-- (observed with prosody). -- (observed with prosody).
, streamOtherFeatures :: ![Element] -- TODO: All feature elements instead? , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead?
} deriving Show } deriving (Eq, Show)
-- | Signals the state of the stream connection. -- | Signals the state of the stream connection.
data ConnectionState data ConnectionState
@ -736,21 +759,23 @@ newtype Stream = Stream { unStream :: TMVar StreamState }
-- the entity associated with an XMPP localpart at a domain -- the entity associated with an XMPP localpart at a domain
-- (i.e., @localpart\@domainpart/resourcepart@). -- (i.e., @localpart\@domainpart/resourcepart@).
data Jid = Jid { localpart_ :: !(Maybe Text) data Jid = Jid { localpart_ :: !(Maybe NonemptyText)
, domainpart_ :: !Text , domainpart_ :: !NonemptyText
, resourcepart_ :: !(Maybe Text) , resourcepart_ :: !(Maybe NonemptyText)
} deriving (Eq, Ord) } deriving (Eq, Ord)
-- | Converts a JID to a Text. -- | Converts a JID to a Text.
jidToText :: Jid -> Text jidToText :: Jid -> Text
jidToText (Jid nd dmn res) = jidToText (Jid nd dmn res) = Text.concat . concat $
Text.pack $ (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++ [ maybe [] (:["@"]) (text <$> nd)
maybe "" (('/' :) . Text.unpack) res , [text dmn]
, maybe [] (\r -> ["/",r]) (text <$> res)
]
-- | Converts a JID to up to three Text values: (the optional) localpart, the -- | Converts a JID to up to three Text values: (the optional) localpart, the
-- domainpart, and (the optional) resourcepart. -- domainpart, and (the optional) resourcepart.
jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text) jidToTexts :: Jid -> (Maybe Text, Text, Maybe Text)
jidToTexts (Jid nd dmn res) = (nd, dmn, res) jidToTexts (Jid nd dmn res) = (text <$> nd, text dmn, text <$> res)
-- Produces a Jid value in the format "parseJid \"<jid>\"". -- Produces a Jid value in the format "parseJid \"<jid>\"".
instance Show Jid where instance Show Jid where
@ -775,6 +800,17 @@ instance Read Jid where
-- or the `parseJid' error message (see below) -- or the `parseJid' error message (see below)
#if WITH_TEMPLATE_HASKELL #if WITH_TEMPLATE_HASKELL
instance TH.Lift Jid where
lift (Jid lp dp rp) = [| Jid $(mbTextE $ text <$> lp)
$(textE $ text dp)
$(mbTextE $ text <$> rp)
|]
where
textE t = [| Nonempty $ Text.pack $(stringE $ Text.unpack t) |]
mbTextE Nothing = [| Nothing |]
mbTextE (Just s) = [| Just $(textE s) |]
-- | Constructs a @Jid@ value at compile time. -- | Constructs a @Jid@ value at compile time.
-- --
-- Syntax: -- Syntax:
@ -788,18 +824,12 @@ jidQ = QuasiQuoter { quoteExp = \s -> do
when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s
case jidFromText t of case jidFromText t of
Nothing -> fail $ "Could not parse JID " ++ s Nothing -> fail $ "Could not parse JID " ++ s
Just j -> [| Jid $(mbTextE $ localpart_ j) Just j -> TH.lift j
$(textE $ domainpart_ j)
$(mbTextE $ resourcepart_ j)
|]
, quotePat = fail "Jid patterns aren't implemented" , quotePat = fail "Jid patterns aren't implemented"
, quoteType = fail "jid QQ can't be used in type context" , quoteType = fail "jid QQ can't be used in type context"
, quoteDec = fail "jid QQ can't be used in declaration context" , quoteDec = fail "jid QQ can't be used in declaration context"
} }
where
textE t = [| Text.pack $(stringE $ Text.unpack t) |]
mbTextE Nothing = [| Nothing |]
mbTextE (Just s) = [| Just $(textE s) |]
#endif #endif
-- Produces a LangTag value in the format "parseLangTag \"<jid>\"". -- Produces a LangTag value in the format "parseLangTag \"<jid>\"".
@ -874,15 +904,18 @@ jidFromTexts l d r = do
guard $ validPartLength l'' guard $ validPartLength l''
let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters
guard $ Text.all (`Set.notMember` prohibMap) l'' guard $ Text.all (`Set.notMember` prohibMap) l''
return $ Just l'' l''' <- nonEmpty l''
domainPart <- SP.runStringPrep (SP.namePrepProfile False) d return $ Just l'''
guard $ validDomainPart domainPart domainPart' <- SP.runStringPrep (SP.namePrepProfile False) d
guard $ validDomainPart domainPart'
domainPart <- nonEmpty domainPart'
resourcePart <- case r of resourcePart <- case r of
Nothing -> return Nothing Nothing -> return Nothing
Just r' -> do Just r' -> do
r'' <- SP.runStringPrep resourceprepProfile r' r'' <- SP.runStringPrep resourceprepProfile r'
guard $ validPartLength r'' guard $ validPartLength r''
return $ Just r'' r''' <- nonEmpty r''
return $ Just r'''
return $ Jid localPart domainPart resourcePart return $ Jid localPart domainPart resourcePart
where where
validDomainPart :: Text -> Bool validDomainPart :: Text -> Bool
@ -907,15 +940,15 @@ toBare j = j{resourcepart_ = Nothing}
-- | Returns the localpart of the @Jid@ (if any). -- | Returns the localpart of the @Jid@ (if any).
localpart :: Jid -> Maybe Text localpart :: Jid -> Maybe Text
localpart = localpart_ localpart = fmap text . localpart_
-- | Returns the domainpart of the @Jid@. -- | Returns the domainpart of the @Jid@.
domainpart :: Jid -> Text domainpart :: Jid -> Text
domainpart = domainpart_ domainpart = text . domainpart_
-- | Returns the resourcepart of the @Jid@ (if any). -- | Returns the resourcepart of the @Jid@ (if any).
resourcepart :: Jid -> Maybe Text resourcepart :: Jid -> Maybe Text
resourcepart = resourcepart_ resourcepart = fmap text . resourcepart_
jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
jidParts = do jidParts = do

4
tests/Tests/Arbitrary/Common.hs
Unescape View File

@ -21,3 +21,7 @@ maybeGen :: Gen a -> Gen (Maybe a)
maybeGen g = oneof [ return Nothing maybeGen g = oneof [ return Nothing
, Just <$> g , Just <$> g
] ]
shrinkMaybe :: (t -> [t]) -> Maybe t -> [Maybe t]
shrinkMaybe _s Nothing = []
shrinkMaybe s (Just x) = Nothing : map Just (s x)

24
tests/Tests/Arbitrary/Xmpp.hs
Unescape View File

@ -2,6 +2,7 @@
module Tests.Arbitrary.Xmpp where module Tests.Arbitrary.Xmpp where
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.Char
import Data.Maybe import Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
import Network.Xmpp.Types import Network.Xmpp.Types
@ -18,6 +19,12 @@ import Data.Derive.Arbitrary
import Data.DeriveTH import Data.DeriveTH
instance Arbitrary NonemptyText where
arbitrary = Nonempty . Text.pack <$> listOf1
(arbitrary `suchThat` (not . isSpace))
shrink (Nonempty txt) = map Nonempty
. filter (not . Text.all isSpace) $ shrink txt
instance Arbitrary Jid where instance Arbitrary Jid where
arbitrary = do arbitrary = do
Just jid <- tryJid `suchThat` isJust Just jid <- tryJid `suchThat` isJust
@ -34,9 +41,9 @@ instance Arbitrary Jid where
isProhibited x = Ranges.member x prohibited isProhibited x = Ranges.member x prohibited
|| x `elem` "@/" || x `elem` "@/"
shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkTextMaybe lp] shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkMaybe shrink lp]
++ [ Jid lp dp' rp | dp' <- shrinkText1 dp] ++ [ Jid lp dp' rp | dp' <- shrink dp]
++ [ Jid lp dp rp' | rp' <- shrinkTextMaybe rp] ++ [ Jid lp dp rp' | rp' <- shrinkMaybe shrink rp]
string :: SP.StringPrepProfile -> Gen [Char] string :: SP.StringPrepProfile -> Gen [Char]
@ -53,17 +60,12 @@ instance Arbitrary LangTag where
shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] ++ shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] ++
[LangTag lt lts' | lts' <- filter (not . Text.null) [LangTag lt lts' | lts' <- filter (not . Text.null)
<$> shrink lts] <$> shrink lts]
`
instance Arbitrary StanzaError where
arbitrary = StanzaError <$> arbitrary
<*> arbitrary
<*> maybeGen ((,) <$> arbitrary <*> genText1)
<*> arbitrary
-- Auto-derive trivial instances -- Auto-derive trivial instances
concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType
, ''StanzaErrorCondition , ''StanzaErrorCondition
, ''StanzaError
, ''StreamErrorInfo
, ''IQRequestType , ''IQRequestType
, ''IQRequest , ''IQRequest
, ''IQResult , ''IQResult
@ -79,7 +81,7 @@ concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType
, ''SaslError , ''SaslError
, ''SaslFailure , ''SaslFailure
, ''StreamErrorCondition , ''StreamErrorCondition
, ''StreamErrorInfo
-- , ''HandshakeFailed -- , ''HandshakeFailed
-- , ''XmppTlsError -- , ''XmppTlsError
-- , ''AuthFailure -- , ''AuthFailure

135
tests/Tests/Picklers.hs
Unescape View File

@ -9,87 +9,82 @@ import Network.Xmpp.Types
import Test.Tasty import Test.Tasty
import Test.Tasty.TH import Test.Tasty.TH
import Test.Tasty.QuickCheck import Test.Tasty.QuickCheck
import Data.Text (Text)
import Data.XML.Types import Data.XML.Types
testPicklerInvertible :: Eq a => PU t a -> a -> Bool -- | Test Pickler self-inverse: Check that unpickling after pickling gives the
testPicklerInvertible p = \x -> case unpickle p (pickle p x) of -- original value
tpsi :: Eq a => PU t a -> a -> Bool
tpsi p = \x -> case unpickle p (pickle p x) of
Left _ -> False Left _ -> False
Right x' -> x == x' Right x' -> x == x'
testPickler :: PU t a -> a -> IO ()
testPickler p x = case unpickle p (pickle p x) of testPickler p x = case unpickle p (pickle p x) of
Left e -> putStrLn $ ppUnpickleError e Left e -> putStrLn $ ppUnpickleError e
Right r -> putStrLn "OK." Right _ -> putStrLn "OK."
prop_errorConditionPicklerInvertible :: StanzaErrorCondition -> Bool prop_xpStreamStanza_invertibe :: Either StreamErrorInfo Stanza -> Bool
prop_errorConditionPicklerInvertible = testPicklerInvertible xpErrorCondition prop_xpStreamStanza_invertibe = tpsi xpStreamStanza
prop_xpStanza_invertibe :: Stanza -> Bool
prop_stanzaErrorPicklerInvertible :: StanzaError -> Bool prop_xpStanza_invertibe = tpsi xpStanza
prop_stanzaErrorPicklerInvertible = testPicklerInvertible xpStanzaError prop_xpMessage_invertibe :: Message -> Bool
prop_xpMessage_invertibe = tpsi xpMessage
prop_messagePicklerInvertible :: Message -> Bool prop_xpPresence_invertibe = tpsi xpPresence
prop_messagePicklerInvertible = testPicklerInvertible xpMessage prop_xpPresence_invertibe :: Presence -> Bool
prop_xpIQRequest_invertibe = tpsi xpIQRequest
prop_messageErrorPicklerInvertible :: MessageError -> Bool prop_xpIQRequest_invertibe :: IQRequest -> Bool
prop_messageErrorPicklerInvertible = testPicklerInvertible xpMessageError prop_xpIQResult_invertibe = tpsi xpIQResult
prop_xpIQResult_invertibe :: IQResult -> Bool
prop_presencePicklerInvertible :: Presence -> Bool prop_xpErrorCondition_invertibe = tpsi xpErrorCondition
prop_presencePicklerInvertible = testPicklerInvertible xpPresence prop_xpErrorCondition_invertibe :: StanzaErrorCondition -> Bool
prop_xpStanzaError_invertibe = tpsi xpStanzaError
prop_presenceErrorPicklerInvertible :: PresenceError -> Bool prop_xpStanzaError_invertibe :: StanzaError -> Bool
prop_presenceErrorPicklerInvertible = testPicklerInvertible xpPresenceError prop_xpMessageError_invertibe = tpsi xpMessageError
prop_xpMessageError_invertibe :: MessageError -> Bool
prop_iqRequestPicklerInvertible :: IQRequest -> Bool prop_xpPresenceError_invertibe = tpsi xpPresenceError
prop_iqRequestPicklerInvertible = testPicklerInvertible xpIQRequest prop_xpPresenceError_invertibe :: PresenceError -> Bool
prop_xpIQError_invertibe = tpsi xpIQError
prop_iqResultPicklerInvertible :: IQResult -> Bool prop_xpIQError_invertibe :: IQError -> Bool
prop_iqResultPicklerInvertible = testPicklerInvertible xpIQResult prop_xpStreamError_invertibe = tpsi xpStreamError
prop_xpStreamError_invertibe :: StreamErrorInfo -> Bool
prop_iqErrorPicklerInvertible :: IQError -> Bool prop_xpLangTag_invertibe = tpsi xpLangTag
prop_iqErrorPicklerInvertible = testPicklerInvertible xpIQError prop_xpLangTag_invertibe :: Maybe LangTag -> Bool
prop_xpLang_invertibe = tpsi xpLang
prop_langTagPicklerInvertible :: Maybe LangTag -> Bool prop_xpLang_invertibe :: LangTag -> Bool
prop_langTagPicklerInvertible = testPicklerInvertible xpLangTag prop_xpStream_invertibe = tpsi xpStream
prop_xpStream_invertibe :: ( Text
prop_langPicklerInvertible :: LangTag -> Bool , Maybe Jid
prop_langPicklerInvertible = testPicklerInvertible xpLang , Maybe Jid
, Maybe Text
, Maybe LangTag )
-> Bool
prop_xpJid_invertibe = tpsi xpJid
prop_xpJid_invertibe :: Jid -> Bool
prop_xpIQRequestType_invertibe = tpsi xpIQRequestType
prop_xpIQRequestType_invertibe :: IQRequestType -> Bool
prop_xpMessageType_invertibe = tpsi xpMessageType
prop_xpMessageType_invertibe :: MessageType -> Bool
prop_xpPresenceType_invertibe = tpsi xpPresenceType
prop_xpPresenceType_invertibe :: PresenceType -> Bool
prop_xpStanzaErrorType_invertibe = tpsi xpStanzaErrorType
prop_xpStanzaErrorType_invertibe :: StanzaErrorType -> Bool
prop_xpStanzaErrorCondition_invertibe = tpsi xpStanzaErrorCondition
prop_xpStanzaErrorCondition_invertibe :: StanzaErrorCondition -> Bool
prop_xpStreamErrorCondition_invertibe = tpsi xpStreamErrorCondition
prop_xpStreamErrorCondition_invertibe :: StreamErrorCondition -> Bool
-- prop_xpStreamFeatures_invertibe = testPicklerInvertible xpStreamFeatures
picklerTests :: TestTree picklerTests :: TestTree
picklerTests = $testGroupGenerator picklerTests = $testGroupGenerator
bad1 = StanzaError { stanzaErrorType = Cancel bad = StreamErrorInfo { errorCondition = StreamInvalidFrom
, stanzaErrorCondition = Forbidden , errorText = Just (Nothing,"")
, stanzaErrorText = Just $ (Just $ LangTag "v" [], "") , errorXml = Just (
, stanzaErrorApplicationSpecificCondition = Element { elementName =
Just (Element {elementName = Name { nameLocalName = "\65044"
Name { nameLocalName = "\231" , nameNamespace = Just "\14139"
, nameNamespace = Nothing , namePrefix = Just "\651"}
, namePrefix = Nothing}
, elementAttributes = []
, elementNodes = []
})
}
bad2StanzaError = StanzaError { stanzaErrorType = Continue
, stanzaErrorCondition = NotAllowed
, stanzaErrorText = Just (Just $ parseLangTag "W-o","\f")
, stanzaErrorApplicationSpecificCondition =
Just (Element {elementName =
Name { nameLocalName = "\8204"
, nameNamespace = Nothing
, namePrefix = Just "\8417A"}
, elementAttributes = [] , elementAttributes = []
, elementNodes = []})} , elementNodes = []})}
bad2 = MessageError { messageErrorID = Just ""
, messageErrorFrom = Just $ parseJid "a@y/\177"
, messageErrorTo = Just $ parseJid "\250@7"
, messageErrorLangTag = Nothing
, messageErrorStanzaError = bad2StanzaError
, messageErrorPayload =
[Element {elementName =
Name { nameLocalName = "\12226C"
, nameNamespace = Nothing
, namePrefix = Nothing}
, elementAttributes = []
, elementNodes = []}]}

Write Preview
Loading…
Cancel
Save