pontarius-xmpp 0.5.6.3 → 0.5.6.4
raw patch · 6 files changed
+145/−68 lines, 6 filesdep +generic-arbitrarydep −derivedep ~basedep ~bytestringdep ~conduitPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: generic-arbitrary
Dependencies removed: derive
Dependency ranges changed: base, bytestring, conduit, containers, data-default, hslogger, lens-family, mtl, network, stm, text, tls, transformers, xml-picklers, xml-types
API changes (from Hackage documentation)
- Network.Xmpp.Lens: set :: () => Setter a a' b b' -> b' -> a -> a'
+ Network.Xmpp.Lens: set :: Setter s t a b -> b -> s -> t
- Network.Xmpp.Lens: view :: () => FoldLike b a a' b b' -> a -> b
+ Network.Xmpp.Lens: view :: FoldLike a s t a b -> s -> a
Files
- pontarius-xmpp.cabal +20/−11
- source/Network/Xmpp/Concurrent/Message.hs +1/−1
- source/Network/Xmpp/Concurrent/Presence.hs +2/−1
- source/Network/Xmpp/IM/PresenceTracker.hs +3/−2
- source/Network/Xmpp/Types.hs +29/−24
- tests/Tests/Arbitrary/Xmpp.hs +90/−29
pontarius-xmpp.cabal view
@@ -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
source/Network/Xmpp/Concurrent/Message.hs view
@@ -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
source/Network/Xmpp/Concurrent/Presence.hs view
@@ -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
source/Network/Xmpp/IM/PresenceTracker.hs view
@@ -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)
source/Network/Xmpp/Types.hs view
@@ -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 @\<stanza-kind to=\'sender\' type=\'error\'\>@ . 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)
tests/Tests/Arbitrary/Xmpp.hs view
@@ -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