diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,8 +1,8 @@ +Cabal-Version: 2.2 Name: pontarius-xmpp -Version: 0.5.6.3 -Cabal-Version: >= 1.10 +Version: 0.5.6.4 Build-Type: Simple -License: BSD3 +License: BSD-3-Clause License-File: LICENSE.md Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, IETF Trust, Philipp Balzarek, Sergey Alirzaev @@ -17,7 +17,7 @@ While in alpha, Pontarius XMPP works quite well and fulfills most requirements of the RFCs. Category: Network -Tested-With: GHC == 8.6.5 +Tested-With: GHC == 9.0.1 Extra-Source-Files: README.md , ChangeLog.md @@ -32,9 +32,8 @@ Default: True } -Library - hs-source-dirs: source - Exposed: True +-- kludge for https://github.com/haskell/cabal/issues/2032 +common stuff Build-Depends: attoparsec >=0.10.0.3 , base >4 && <5 , base64-bytestring >=0.1.0.0 @@ -50,7 +49,8 @@ , exceptions >=0.6 , hslogger >=1.1.0 , iproute >=1.2.4 - , lens-family < 1.3 + , lens + , lens-family , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 , network >=2.3.1.0 @@ -70,7 +70,6 @@ , xml-conduit >=1.1.0.7 , xml-picklers >=0.3.3 , xml-types >=0.3.1 - If impl(ghc ==7.0.1) { Build-Depends: bytestring >=0.9.1.9 && <=0.9.2.1 } Else { @@ -79,6 +78,11 @@ If flag(with-th) && impl(ghc >=7.6.1) { Build-Depends: template-haskell >=2.5 } + +Library + import: stuff + hs-source-dirs: source + Exposed: True Exposed-modules: Network.Xmpp , Network.Xmpp.IM , Network.Xmpp.Internal @@ -118,6 +122,7 @@ default-language: Haskell2010 Test-Suite tests + import: stuff Type: exitcode-stdio-1.0 main-is: Main.hs Build-Depends: Cabal @@ -128,7 +133,7 @@ , conduit , containers , data-default - , derive + , generic-arbitrary , hslogger , hspec , hspec-expectations @@ -162,6 +167,9 @@ default-language: Haskell2010 Test-Suite runtests + import: stuff + -- requires credentials to auth at a remote server + Buildable: False Type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Run.hs @@ -191,6 +199,7 @@ default-language: Haskell2010 benchmark benchmarks + import: stuff type: exitcode-stdio-1.0 build-depends: base , criterion @@ -207,4 +216,4 @@ Source-Repository this Type: git Location: https://github.com/l29ah/pontarius-xmpp.git - Tag: 0.5.6.3 + Tag: 0.5.6.4 diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs --- a/source/Network/Xmpp/Concurrent/Message.hs +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -90,7 +90,7 @@ filterMessages f g s = either (Left . fst) (Right . fst) <$> filterMessagesA (f . fst) (g . fst) s --- | Send a message stanza. Returns @False@ when the 'Message' could not be +-- | Send a message stanza. Returns @Left@ when the 'Message' could not be -- sent. sendMessage :: Message -> Session -> IO (Either XmppFailure ()) sendMessage m session = sendStanza (MessageS m) session diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -3,8 +3,9 @@ import Control.Applicative ((<$>)) import Control.Concurrent.STM +import Control.Lens.Prism (_Just) import Lens.Family2 hiding (to) -import Lens.Family2.Stock +import Lens.Family2.Stock hiding (_Just) import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.Types import Network.Xmpp.Lens diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -4,13 +4,14 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM +import Control.Lens.Prism (_Just) import Control.Monad import qualified Data.Foldable as Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe -import Lens.Family2 -import Lens.Family2.Stock +import Lens.Family2 hiding (Prism) +import Lens.Family2.Stock hiding (Prism, _Just, from) import Network.Xmpp.Concurrent.Types import Network.Xmpp.IM.Presence import Network.Xmpp.Lens hiding (Lens, Traversal) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -5,6 +5,7 @@ #endif {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -103,6 +104,7 @@ import Data.Typeable(Typeable) import Data.XML.Types as XML import qualified Data.Text.Encoding as Text +import GHC.Generics #if WITH_TEMPLATE_HASKELL import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -153,7 +155,7 @@ | MessageErrorS !MessageError | PresenceS !Presence | PresenceErrorS !PresenceError - deriving (Eq, Show) + deriving (Eq, Show, Generic) type ExtendedAttribute = (XML.Name, Text) @@ -166,10 +168,10 @@ , iqRequestType :: !IQRequestType , iqRequestPayload :: !Element , iqRequestAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | The type of IQ request that is made. -data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show) +data IQRequestType = Get | Set deriving (Eq, Ord, Read, Show, Generic) -- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza -- of type "result" ('IQResult') @@ -184,7 +186,7 @@ , iqResultLangTag :: !(Maybe LangTag) , iqResultPayload :: !(Maybe Element) , iqResultAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | The answer to an IQ request that generated an error. data IQError = IQError { iqErrorID :: !Text @@ -194,7 +196,7 @@ , iqErrorStanzaError :: !StanzaError , iqErrorPayload :: !(Maybe Element) -- should this be []? , iqErrorAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | The message stanza. Used for /push/ type communication. data Message = Message { messageID :: !(Maybe Text) @@ -204,7 +206,7 @@ , messageType :: !MessageType , messagePayload :: ![Element] , messageAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | An empty message -- @@ -244,7 +246,7 @@ , messageErrorStanzaError :: !StanzaError , messageErrorPayload :: ![Element] , messageErrorAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) messageError :: MessageError messageError = MessageError { messageErrorID = Nothing @@ -303,7 +305,7 @@ -- -- This is the /default/ value. | Normal - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) -- | The presence stanza. Used for communicating status updates. data Presence = Presence { presenceID :: !(Maybe Text) @@ -313,7 +315,7 @@ , presenceType :: !PresenceType , presencePayload :: ![Element] , presenceAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | An empty presence. presence :: Presence @@ -341,7 +343,7 @@ , presenceErrorStanzaError :: !StanzaError , presenceErrorPayload :: ![Element] , presenceErrorAttributes :: ![ExtendedAttribute] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | @PresenceType@ holds Xmpp presence types. The "error" message type is left -- out as errors are using @PresenceError@. @@ -354,7 +356,7 @@ -- should only be used by servers Available | -- ^ Sender wants to express availability -- (no type attribute is defined) - Unavailable deriving (Eq, Read, Show) + Unavailable deriving (Eq, Read, Show, Generic) -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like @\@ . These @@ -365,7 +367,7 @@ , stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorText :: Maybe (Maybe LangTag, NonemptyText) , stanzaErrorApplicationSpecificCondition :: Maybe Element - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | @StanzaError@s always have one of these types. data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry @@ -373,7 +375,7 @@ Modify | -- ^ Change the data and retry Auth | -- ^ Provide credentials and retry Wait -- ^ Error is temporary - wait and retry - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) -- | Stanza errors are accommodated with one of the error conditions listed -- below. @@ -415,7 +417,7 @@ | UndefinedCondition -- ^ Application-specific -- condition. | UnexpectedRequest -- ^ Badly timed request. - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) -- ============================================================================= -- OTHER STUFF @@ -425,7 +427,7 @@ , saslFailureText :: Maybe ( Maybe LangTag , Text ) - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) data SaslError = SaslAborted -- ^ Client aborted. | SaslAccountDisabled -- ^ The account has been temporarily @@ -454,7 +456,7 @@ -- temporary error condition; the -- initiating entity is recommended -- to try again later. - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) -- The documentation of StreamErrorConditions is copied from -- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions @@ -571,18 +573,18 @@ -- initiating entity in the stream header -- specifies a version of XMPP that is not -- supported by the server. - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) -- | Encapsulates information about an XMPP stream error. data StreamErrorInfo = StreamErrorInfo { errorCondition :: !StreamErrorCondition , errorText :: !(Maybe (Maybe LangTag, NonemptyText)) , errorXml :: !(Maybe Element) - } deriving (Show, Eq) + } deriving (Show, Eq, Generic) data XmppTlsError = XmppTlsError TLSError | XmppTlsException TLSException - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Typeable, Generic) -- | Signals an XMPP stream error or another unpredicted stream-related -- situation. This error is fatal, and closes the XMPP stream. @@ -621,7 +623,7 @@ | XmppIOException IOException -- ^ An 'IOException' -- occurred | XmppInvalidXml String -- ^ Received data is not valid XML - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Typeable, Generic) instance Exception XmppFailure @@ -639,7 +641,7 @@ -- | Other failure; more information is available -- in the log | AuthOtherFailure - deriving (Eq, Show) + deriving (Eq, Show, Generic) -- ============================================================================= -- XML TYPES @@ -649,7 +651,7 @@ -- 2.13, which in turn is lesser than 12.3. data Version = Version { majorVersion :: !Integer - , minorVersion :: !Integer } deriving (Eq, Read, Show) + , minorVersion :: !Integer } deriving (Eq, Read, Show, Generic) -- If the major version numbers are not equal, compare them. Otherwise, compare -- the minor version numbers. @@ -769,7 +771,7 @@ | Plain -- ^ Stream established, but not secured via TLS | Secured -- ^ Stream established and secured via TLS | Finished -- ^ Stream was closed - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Typeable, Generic) -- | Defines operations for sending, receiving, flushing, and closing on a -- stream. @@ -1086,7 +1088,7 @@ guard $ Text.all (`Set.notMember` prohibMap) l'' l''' <- nonEmpty l'' return $ Just l''' - domainPart' <- SP.runStringPrep (SP.namePrepProfile False) (stripSuffix d) + domainPart' <- forbidSeparators =<< SP.runStringPrep (SP.namePrepProfile False) (stripSuffix d) guard $ validDomainPart domainPart' guard $ validPartLength domainPart' domainPart <- nonEmpty domainPart' @@ -1108,6 +1110,8 @@ && BS.length (Text.encodeUtf8 p) < 1024 -- RFC6122 §2.2 stripSuffix t = if Text.last t == '.' then Text.init t else t + -- "／" might be a valid JID, but stringprep messes it up, so we use + forbidSeparators t = if Nothing == Text.find (flip elem ['/', '@']) t then Just t else Nothing -- | Returns 'True' if the JID is /bare/, that is, it doesn't have a resource -- part, and 'False' otherwise. @@ -1300,3 +1304,4 @@ | PreferPlain -- ^ Negotitate TLS only if the server requires -- it | RefuseTls -- ^ Never secure the stream with TLS. + deriving (Eq, Show, Generic) diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs --- a/tests/Tests/Arbitrary/Xmpp.hs +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -9,6 +9,7 @@ import Network.Xmpp.Internal hiding (elements) import Test.QuickCheck import Test.QuickCheck.Instances() +import Test.QuickCheck.Arbitrary.Generic import qualified Text.CharRanges as Ranges import qualified Text.StringPrep as SP import qualified Text.StringPrep.Profiles as SP @@ -16,10 +17,7 @@ import Tests.Arbitrary.Common import Tests.Arbitrary.Xml () -import Data.Derive.Arbitrary -import Data.DeriveTH - instance Arbitrary NonemptyText where arbitrary = Nonempty . Text.pack <$> listOf1 (arbitrary `suchThat` (not . isSpace)) @@ -42,7 +40,7 @@ isProhibited x = Ranges.member x prohibited || if node then False - else x `elem` ['@','/'] + else x `elem` ['@','/', '＠', '／'] shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkMaybe shrink lp] ++ [ Jid lp dp' rp | dp' <- shrink dp] @@ -64,31 +62,94 @@ [LangTag lt lts' | lts' <- filter (not . Text.null) <$> shrink lts] +instance Arbitrary XmppFailure where + arbitrary = elements [StreamEndFailure, TcpConnectionFailure, XmppIllegalTcpDetails, TlsNoServerSupport, XmppNoStream, TlsStreamSecured, XmppOtherFailure] + -- Auto-derive trivial instances -concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType - , ''StanzaErrorCondition - , ''StanzaError - , ''StreamErrorInfo - , ''IQRequestType - , ''IQRequest - , ''IQResult - , ''IQError - , ''MessageType - , ''Message - , ''MessageError - , ''PresenceType - , ''Presence - , ''PresenceError - , ''Stanza +instance Arbitrary StanzaErrorType where + arbitrary = genericArbitrary + shrink = genericShrink - , ''SaslError - , ''SaslFailure - , ''StreamErrorCondition +instance Arbitrary StanzaErrorCondition where + arbitrary = genericArbitrary + shrink = genericShrink - -- , ''HandshakeFailed - -- , ''XmppTlsError --- , ''AuthFailure - , ''Version - , ''ConnectionState - , ''TlsBehaviour - ] +instance Arbitrary StanzaError where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary StreamErrorInfo where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary IQRequestType where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary IQRequest where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary IQResult where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary IQError where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary MessageType where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Message where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary MessageError where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary PresenceType where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Presence where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary PresenceError where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Stanza where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary SaslError where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary SaslFailure where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary StreamErrorCondition where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AuthFailure where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Version where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ConnectionState where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary TlsBehaviour where + arbitrary = genericArbitrary + shrink = genericShrink