From 389389804cb35f53be476e3d9dca109533984e23 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 17 Dec 2013 23:58:21 +0100 Subject: [PATCH] add NonemptyText type and adapt code where necessary --- source/Network/Xmpp/Lens.hs | 2 +- source/Network/Xmpp/Marshal.hs | 9 ++- source/Network/Xmpp/Stream.hs | 4 +- source/Network/Xmpp/Types.hs | 105 +++++++++++++++--------- tests/Tests/Arbitrary/Common.hs | 4 + tests/Tests/Arbitrary/Xmpp.hs | 24 +++--- tests/Tests/Picklers.hs | 139 +++++++++++++++----------------- 7 files changed, 162 insertions(+), 125 deletions(-) diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 209ab8b..7aa1198 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -354,7 +354,7 @@ stanzaErrorConditionL :: Lens StanzaError StanzaErrorCondition stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = 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} = (\x' -> se{stanzaErrorText = x'}) <$> inj x diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 14110e9..4963bbe 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -17,6 +17,9 @@ import Data.Text import Network.Xmpp.Types +xpNonemptyText :: PU Text NonemptyText +xpNonemptyText = ("xpNonemptyText" , "") xpWrap Nonempty fromNonempty xpText + xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza @@ -124,7 +127,7 @@ xpErrorCondition = ("xpErrorCondition" , "") xpWrapEither "urn:ietf:params:xml:ns:xmpp-stanzas" xpStanzaErrorCondition xpUnit - (xpOption $ xpContent xpId) + (xpOption $ xpContent xpNonemptyText) ) xpStanzaError :: PU [Node] StanzaError @@ -137,7 +140,7 @@ xpStanzaError = ("xpStanzaError" , "") xpWrap xpErrorCondition (xpOption $ xpElem "{jabber:client}text" (xpAttrImplied xmlLang xpLang) - (xpContent xpText) + (xpContent xpNonemptyText) ) (xpOption xpElemVerbatim) ) @@ -215,7 +218,7 @@ xpStreamError = ("xpStreamError" , "") xpWrap (xpOption $ xpElem "{urn:ietf:params:xml:ns:xmpp-streams}text" xpLangTag - (xpContent xpId) + (xpContent xpNonemptyText) ) (xpOption xpElemVerbatim) -- Application specific error conditions ) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 12f3cb2..68cfd5e 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -126,7 +126,7 @@ startStream = runErrorT $ do ErrorT . pushOpenElement . streamNSHack $ pickleElem xpStream ( "1.0" , expectedTo - , Just (Jid Nothing address Nothing) + , Just (Jid Nothing (Nonempty address) Nothing) , Nothing , 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 -- 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 "Stream from is invalid" | to /= expectedTo -> diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 25848cd..09a2bb7 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -13,7 +13,10 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Types - ( IQError(..) + ( NonemptyText(..) + , nonEmpty + , text + , IQError(..) , IQRequest(..) , IQRequestType(..) , IQResponse(..) @@ -68,8 +71,7 @@ module Network.Xmpp.Types , parseJid , TlsBehaviour(..) , AuthFailure(..) - ) - where + ) where import Control.Applicative ((<$>), (<|>), many) import Control.Concurrent.STM @@ -77,9 +79,11 @@ import Control.Exception import Control.Monad.Error import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS +import Data.Char (isSpace) import Data.Conduit import Data.Default import qualified Data.Set as Set +import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) @@ -87,6 +91,7 @@ import Data.XML.Types #if WITH_TEMPLATE_HASKELL import Language.Haskell.TH import Language.Haskell.TH.Quote +import qualified Language.Haskell.TH.Syntax as TH #endif import Network import Network.DNS @@ -95,6 +100,25 @@ import Network.TLS.Extra import qualified Text.StringPrep 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 -- called stanzas. data Stanza = IQRequestS !IQRequest @@ -151,8 +175,6 @@ data Message = Message { messageID :: !(Maybe Text) , messagePayload :: ![Element] } deriving (Eq, Show) - - -- | An empty message message :: Message message = Message { messageID = Nothing @@ -272,7 +294,7 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition - , stanzaErrorText :: Maybe (Maybe LangTag, Text) + , stanzaErrorText :: Maybe (Maybe LangTag, NonemptyText) , stanzaErrorApplicationSpecificCondition :: Maybe Element } deriving (Eq, Show) @@ -291,9 +313,9 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML. -- name already exists. | FeatureNotImplemented | Forbidden -- ^ Insufficient permissions. - | Gone (Maybe Text) -- ^ Entity can no longer be - -- contacted at this - -- address. + | Gone (Maybe NonemptyText) -- ^ Entity can no longer + -- be contacted at this + -- address. | InternalServerError | ItemNotFound | JidMalformed @@ -309,9 +331,10 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML. -- words that are prohibited -- by the service) | RecipientUnavailable -- ^ Temporarily unavailable. - | Redirect (Maybe Text) -- ^ Redirecting to other - -- entity, usually - -- temporarily. + | Redirect (Maybe NonemptyText) -- ^ Redirecting to + -- other entity, + -- usually + -- temporarily. | RegistrationRequired | RemoteServerNotFound | RemoteServerTimeout @@ -484,7 +507,7 @@ data StreamErrorCondition -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo { errorCondition :: !StreamErrorCondition - , errorText :: !(Maybe (Maybe LangTag, Text)) + , errorText :: !(Maybe (Maybe LangTag, NonemptyText)) , errorXml :: !(Maybe Element) } deriving (Show, Eq) @@ -645,7 +668,7 @@ data StreamFeatures = StreamFeatures -- non-standard "optional" element -- (observed with prosody). , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead? - } deriving Show + } deriving (Eq, Show) -- | Signals the state of the stream connection. data ConnectionState @@ -736,21 +759,23 @@ newtype Stream = Stream { unStream :: TMVar StreamState } -- the entity associated with an XMPP localpart at a domain -- (i.e., @localpart\@domainpart/resourcepart@). -data Jid = Jid { localpart_ :: !(Maybe Text) - , domainpart_ :: !Text - , resourcepart_ :: !(Maybe Text) +data Jid = Jid { localpart_ :: !(Maybe NonemptyText) + , domainpart_ :: !NonemptyText + , resourcepart_ :: !(Maybe NonemptyText) } deriving (Eq, Ord) -- | Converts a JID to a Text. jidToText :: Jid -> Text -jidToText (Jid nd dmn res) = - Text.pack $ (maybe "" ((++ "@") . Text.unpack) nd) ++ (Text.unpack dmn) ++ - maybe "" (('/' :) . Text.unpack) res +jidToText (Jid nd dmn res) = Text.concat . concat $ + [ maybe [] (:["@"]) (text <$> nd) + , [text dmn] + , maybe [] (\r -> ["/",r]) (text <$> res) + ] -- | Converts a JID to up to three Text values: (the optional) localpart, the -- domainpart, and (the optional) resourcepart. 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 \"\"". instance Show Jid where @@ -775,6 +800,17 @@ instance Read Jid where -- or the `parseJid' error message (see below) #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. -- -- Syntax: @@ -788,18 +824,12 @@ jidQ = QuasiQuoter { quoteExp = \s -> do when (Text.last t == ' ') . reportWarning $ "Trailing whitespace in JID " ++ show s case jidFromText t of Nothing -> fail $ "Could not parse JID " ++ s - Just j -> [| Jid $(mbTextE $ localpart_ j) - $(textE $ domainpart_ j) - $(mbTextE $ resourcepart_ j) - |] + Just j -> TH.lift j , quotePat = fail "Jid patterns aren't implemented" , quoteType = fail "jid QQ can't be used in type 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 -- Produces a LangTag value in the format "parseLangTag \"\"". @@ -874,15 +904,18 @@ jidFromTexts l d r = do 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 + l''' <- nonEmpty l'' + return $ Just l''' + domainPart' <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart' + domainPart <- nonEmpty domainPart' resourcePart <- case r of Nothing -> return Nothing Just r' -> do r'' <- SP.runStringPrep resourceprepProfile r' guard $ validPartLength r'' - return $ Just r'' + r''' <- nonEmpty r'' + return $ Just r''' return $ Jid localPart domainPart resourcePart where validDomainPart :: Text -> Bool @@ -907,15 +940,15 @@ toBare j = j{resourcepart_ = Nothing} -- | Returns the localpart of the @Jid@ (if any). localpart :: Jid -> Maybe Text -localpart = localpart_ +localpart = fmap text . localpart_ -- | Returns the domainpart of the @Jid@. domainpart :: Jid -> Text -domainpart = domainpart_ +domainpart = text . domainpart_ -- | Returns the resourcepart of the @Jid@ (if any). resourcepart :: Jid -> Maybe Text -resourcepart = resourcepart_ +resourcepart = fmap text . resourcepart_ jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts = do diff --git a/tests/Tests/Arbitrary/Common.hs b/tests/Tests/Arbitrary/Common.hs index c593dd2..389244f 100644 --- a/tests/Tests/Arbitrary/Common.hs +++ b/tests/Tests/Arbitrary/Common.hs @@ -21,3 +21,7 @@ maybeGen :: Gen a -> Gen (Maybe a) maybeGen g = oneof [ return Nothing , Just <$> g ] + +shrinkMaybe :: (t -> [t]) -> Maybe t -> [Maybe t] +shrinkMaybe _s Nothing = [] +shrinkMaybe s (Just x) = Nothing : map Just (s x) diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs index d2fb812..6c842c6 100644 --- a/tests/Tests/Arbitrary/Xmpp.hs +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -2,6 +2,7 @@ module Tests.Arbitrary.Xmpp where import Control.Applicative ((<$>), (<*>)) +import Data.Char import Data.Maybe import qualified Data.Text as Text import Network.Xmpp.Types @@ -18,6 +19,12 @@ import Data.Derive.Arbitrary 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 arbitrary = do Just jid <- tryJid `suchThat` isJust @@ -34,9 +41,9 @@ instance Arbitrary Jid where 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] + shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkMaybe shrink lp] + ++ [ Jid lp dp' rp | dp' <- shrink dp] + ++ [ Jid lp dp rp' | rp' <- shrinkMaybe shrink rp] string :: SP.StringPrepProfile -> Gen [Char] @@ -53,17 +60,12 @@ instance Arbitrary LangTag where 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 - <*> maybeGen ((,) <$> arbitrary <*> genText1) - <*> arbitrary -- Auto-derive trivial instances concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType , ''StanzaErrorCondition + , ''StanzaError + , ''StreamErrorInfo , ''IQRequestType , ''IQRequest , ''IQResult @@ -79,7 +81,7 @@ concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType , ''SaslError , ''SaslFailure , ''StreamErrorCondition - , ''StreamErrorInfo + -- , ''HandshakeFailed -- , ''XmppTlsError -- , ''AuthFailure diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs index b965b81..b2ad633 100644 --- a/tests/Tests/Picklers.hs +++ b/tests/Tests/Picklers.hs @@ -9,87 +9,82 @@ import Network.Xmpp.Types import Test.Tasty import Test.Tasty.TH import Test.Tasty.QuickCheck +import Data.Text (Text) import Data.XML.Types -testPicklerInvertible :: Eq a => PU t a -> a -> Bool -testPicklerInvertible p = \x -> case unpickle p (pickle p x) of +-- | Test Pickler self-inverse: Check that unpickling after pickling gives the +-- original value +tpsi :: Eq a => PU t a -> a -> Bool +tpsi p = \x -> case unpickle p (pickle p x) of Left _ -> False Right x' -> x == x' +testPickler :: PU t a -> a -> IO () testPickler p x = case unpickle p (pickle p x) of Left e -> putStrLn $ ppUnpickleError e - Right r -> putStrLn "OK." - -prop_errorConditionPicklerInvertible :: StanzaErrorCondition -> Bool -prop_errorConditionPicklerInvertible = testPicklerInvertible xpErrorCondition - -prop_stanzaErrorPicklerInvertible :: StanzaError -> Bool -prop_stanzaErrorPicklerInvertible = testPicklerInvertible xpStanzaError - -prop_messagePicklerInvertible :: Message -> Bool -prop_messagePicklerInvertible = testPicklerInvertible xpMessage - -prop_messageErrorPicklerInvertible :: MessageError -> Bool -prop_messageErrorPicklerInvertible = testPicklerInvertible xpMessageError - -prop_presencePicklerInvertible :: Presence -> Bool -prop_presencePicklerInvertible = testPicklerInvertible xpPresence - -prop_presenceErrorPicklerInvertible :: PresenceError -> Bool -prop_presenceErrorPicklerInvertible = testPicklerInvertible xpPresenceError - -prop_iqRequestPicklerInvertible :: IQRequest -> Bool -prop_iqRequestPicklerInvertible = testPicklerInvertible xpIQRequest - -prop_iqResultPicklerInvertible :: IQResult -> Bool -prop_iqResultPicklerInvertible = testPicklerInvertible xpIQResult - -prop_iqErrorPicklerInvertible :: IQError -> Bool -prop_iqErrorPicklerInvertible = testPicklerInvertible xpIQError - -prop_langTagPicklerInvertible :: Maybe LangTag -> Bool -prop_langTagPicklerInvertible = testPicklerInvertible xpLangTag - -prop_langPicklerInvertible :: LangTag -> Bool -prop_langPicklerInvertible = testPicklerInvertible xpLang + Right _ -> putStrLn "OK." + +prop_xpStreamStanza_invertibe :: Either StreamErrorInfo Stanza -> Bool +prop_xpStreamStanza_invertibe = tpsi xpStreamStanza +prop_xpStanza_invertibe :: Stanza -> Bool +prop_xpStanza_invertibe = tpsi xpStanza +prop_xpMessage_invertibe :: Message -> Bool +prop_xpMessage_invertibe = tpsi xpMessage +prop_xpPresence_invertibe = tpsi xpPresence +prop_xpPresence_invertibe :: Presence -> Bool +prop_xpIQRequest_invertibe = tpsi xpIQRequest +prop_xpIQRequest_invertibe :: IQRequest -> Bool +prop_xpIQResult_invertibe = tpsi xpIQResult +prop_xpIQResult_invertibe :: IQResult -> Bool +prop_xpErrorCondition_invertibe = tpsi xpErrorCondition +prop_xpErrorCondition_invertibe :: StanzaErrorCondition -> Bool +prop_xpStanzaError_invertibe = tpsi xpStanzaError +prop_xpStanzaError_invertibe :: StanzaError -> Bool +prop_xpMessageError_invertibe = tpsi xpMessageError +prop_xpMessageError_invertibe :: MessageError -> Bool +prop_xpPresenceError_invertibe = tpsi xpPresenceError +prop_xpPresenceError_invertibe :: PresenceError -> Bool +prop_xpIQError_invertibe = tpsi xpIQError +prop_xpIQError_invertibe :: IQError -> Bool +prop_xpStreamError_invertibe = tpsi xpStreamError +prop_xpStreamError_invertibe :: StreamErrorInfo -> Bool +prop_xpLangTag_invertibe = tpsi xpLangTag +prop_xpLangTag_invertibe :: Maybe LangTag -> Bool +prop_xpLang_invertibe = tpsi xpLang +prop_xpLang_invertibe :: LangTag -> Bool +prop_xpStream_invertibe = tpsi xpStream +prop_xpStream_invertibe :: ( Text + , Maybe Jid + , 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 = $testGroupGenerator -bad1 = StanzaError { stanzaErrorType = Cancel - , stanzaErrorCondition = Forbidden - , stanzaErrorText = Just $ (Just $ LangTag "v" [], "") - , stanzaErrorApplicationSpecificCondition = - Just (Element {elementName = - Name { nameLocalName = "\231" - , nameNamespace = Nothing - , 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 = [] - , 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 = []}]} +bad = StreamErrorInfo { errorCondition = StreamInvalidFrom + , errorText = Just (Nothing,"") + , errorXml = Just ( + Element { elementName = + Name { nameLocalName = "\65044" + , nameNamespace = Just "\14139" + , namePrefix = Just "\651"} + , elementAttributes = [] + , elementNodes = []})}