net-mqtt 0.7.0.1 → 0.7.1.0

raw patch · 7 files changed

+114/−24 lines, 7 filesdep ~QuickCheckdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, bytestring

API changes (from Hackage documentation)

Files

• Changelog.md +8/−0
• app/mqtt-watch/Main.hs +20/−10
• net-mqtt.cabal +9/−9
• src/Network/MQTT/Arbitrary.hs +56/−2
• src/Network/MQTT/Client.hs +1/−1
• src/Network/MQTT/Types.hs +8/−1
• test/Spec.hs +12/−1

@@ -1,5 +1,13 @@ # Changelog for net-mqtt +## 0.7.1.0++More Arbitrary topic helpers.++Commandline tool enhancements.++Bump version bounds.+ ## 0.7.0.1  Fixed an error where there'd be an ugly crash in a situation where

@@ -8,7 +8,7 @@ import           Control.Concurrent.Async   (async, link) import           Control.Concurrent.STM     (TChan, atomically, newTChanIO, readTChan, writeTChan) import           Control.Exception          (Handler (..), IOException, catches)-import           Control.Monad              (foldM_, forever, when)+import           Control.Monad              (foldM_, forever, when, (<=<)) import qualified Data.ByteString.Lazy       as BL import qualified Data.ByteString.Lazy.Char8 as BCS import qualified Data.IORef                 as R@@ -16,12 +16,13 @@ import qualified Data.Text.IO               as TIO import           Data.Word                  (Word32) import           Network.MQTT.Client-import           Network.MQTT.Types         (ConnACKFlags (..), SessionReuse (..))+import           Network.MQTT.Types         (ConnACKFlags (..), SessionReuse (..), qosFromInt) import           Network.URI-import           Options.Applicative        (Parser, argument, auto, execParser, fullDesc, help, helper, info, long,-                                             maybeReader, metavar, option, progDesc, short, showDefault, some, str,-                                             switch, value, (<**>))+import           Options.Applicative        (Parser, argument, auto, eitherReader, execParser, fullDesc, help, helper,+                                             info, long, maybeReader, metavar, option, progDesc, short, showDefault,+                                             some, str, switch, value, (<**>)) import           System.IO                  (stdout)+import           Text.Read                  (readMaybe)  data Msg = Msg Topic BL.ByteString [Property] @@ -41,22 +42,31 @@   <*> switch (short 'p' <> help "hide properties")   <*> option auto (long "session-timeout" <> showDefault <> value 300 <> help "mqtt session timeout (0 == clean)")   <*> switch (short 'v' <> long "verbose" <> help "enable debug logging")-  <*> option (toEnum <$> auto) (long "qos" <> short 'q' <> showDefault <> value QoS0 <> help "QoS level (0-2)")+  <*> option (eitherReader pQoS) (long "qos" <> short 'q' <> showDefault <> value QoS0 <> help "QoS level (0-2)")   <*> switch (long "always-subscribe" <> help "subscribe even when resuming a connection")   <*> some (argument str (metavar "topics...")) -printer :: TChan Msg -> Bool -> IO ()-printer ch showProps = forever $ do+  where+    pQoS = maybe (Left "Only QoS 0, 1, and 2 are supported") Right . (qosFromInt <=< readMaybe)++printer :: TChan Msg -> Bool -> Bool -> IO ()+printer ch showProps verbose = forever $ do   (Msg t m props) <- atomically $ readTChan ch   TIO.putStr $ mconcat [t, " → "]   BL.hPut stdout m   putStrLn ""-  when showProps $ mapM_ (putStrLn . ("  " <>) . drop 4 . show) props+  mapM_ (putStrLn . ("  " <>) . drop 4 . show) (filter (viewableProp showProps verbose) props) +    where+      viewableProp False _ _              = False+      viewableProp _ True _               = True+      viewableProp _ _ (PropTopicAlias _) = False+      viewableProp _ _ _                  = True+ run :: Options -> IO () run Options{..} = do   ch <- newTChanIO-  async (printer ch (not optHideProps)) >>= link+  async (printer ch (not optHideProps) optVerbose) >>= link   uref <- R.newIORef optUri    forever $ catches (go ch uref) [Handler (\(ex :: MQTTException) -> handler (show ex)),

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 20018fa092913650fb64e9a4118baa239d6ba287d900b6089922dd5396e552c6+-- hash: d9a226d2e765d07b5d1f8269024496dfd275ee4920b8118e0b9e93f61684df17  name:           net-mqtt-version:        0.7.0.1+version:        0.7.1.0 synopsis:       An MQTT Protocol Implementation. description:    Please see the README on GitHub at <https://github.com/dustin/mqtt-hs#readme> category:       Network@@ -39,13 +39,13 @@       src   ghc-options: -Wall   build-depends:-      QuickCheck >=2.12.6.1 && <2.14+      QuickCheck >=2.12.6.1 && <2.15     , async >=2.2.1 && <2.3     , attoparsec >=0.13.2 && <0.14     , attoparsec-binary >=0.2 && <1.0     , base >=4.7 && <5     , binary >=0.8.5 && <0.9-    , bytestring >=0.10.8 && <0.11+    , bytestring >=0.10.8 && <0.12     , conduit >=1.3.1 && <1.4     , conduit-extra >=1.3.0 && <1.4     , connection >=0.2.0 && <0.4@@ -66,13 +66,13 @@       app/example   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:-      QuickCheck >=2.12.6.1 && <2.14+      QuickCheck >=2.12.6.1 && <2.15     , async >=2.2.1 && <2.3     , attoparsec >=0.13.2 && <0.14     , attoparsec-binary >=0.2 && <1.0     , base >=4.7 && <5     , binary >=0.8.5 && <0.9-    , bytestring >=0.10.8 && <0.11+    , bytestring >=0.10.8 && <0.12     , conduit >=1.3.1 && <1.4     , conduit-extra >=1.3.0 && <1.4     , connection >=0.2.0 && <0.4@@ -94,7 +94,7 @@       app/mqtt-watch   ghc-options: -Wall -threaded -rtsopts -eventlog -with-rtsopts=-N   build-depends:-      QuickCheck >=2.12.6.1 && <2.14+      QuickCheck >=2.12.6.1 && <2.15     , async >=2.2.1 && <2.3     , attoparsec >=0.13.2 && <0.14     , attoparsec-binary >=0.2 && <1.0@@ -125,13 +125,13 @@   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:       HUnit-    , QuickCheck >=2.12.6.1 && <2.14+    , QuickCheck >=2.12.6.1 && <2.15     , async >=2.2.1 && <2.3     , attoparsec >=0.13.2 && <0.14     , attoparsec-binary >=0.2 && <1.0     , base >=4.7 && <5     , binary >=0.8.5 && <0.9-    , bytestring >=0.10.8 && <0.11+    , bytestring >=0.10.8 && <0.12     , conduit >=1.3.1 && <1.4     , conduit-extra >=1.3.0 && <1.4     , connection >=0.2.0 && <0.4

@@ -9,22 +9,29 @@ Arbitrary instances for QuickCheck. -} -{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Network.MQTT.Arbitrary (   SizeT(..),+  ATopic, unTopic, MatchingTopic(..),+  arbitraryTopicSegment, arbitraryTopic, arbitraryMatchingTopic,   v311mask   ) where  import           Control.Applicative   (liftA2) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy  as L+import           Data.Function         ((&))+import           Data.Text             (Text)+import qualified Data.Text             as Text+import           Network.MQTT.Topic    (Filter, Topic) import           Network.MQTT.Types    as MT import           Test.QuickCheck       as QC  - -- | Arbitrary type fitting variable integers. newtype SizeT = SizeT Int deriving(Eq, Show) @@ -208,3 +215,50 @@ v311mask (PubRELPkt (PubREL x _ _)) = PubRELPkt (PubREL x 0 mempty) v311mask (PubCOMPPkt (PubCOMP x _ _)) = PubCOMPPkt (PubCOMP x 0 mempty) v311mask x = x++-- | An arbitrary topic.+newtype ATopic = ATopic [Text] deriving (Show, Eq)++instance Arbitrary ATopic where+  arbitrary = arbitraryTopic ['a'..'z'] (1,6) (1,6)++  shrink (ATopic x) = fmap ATopic . shrinkList shrinkWord $ x+    where shrinkWord = fmap Text.pack . shrink . Text.unpack++-- | Retrieve the Topic from ATopic+unTopic :: ATopic -> Topic+unTopic (ATopic t) = Text.intercalate "/" t++-- | An arbitrary Topic and an arbitrary Filter that should match it.+newtype MatchingTopic = MatchingTopic (Topic, [Filter]) deriving (Eq, Show)++instance Arbitrary MatchingTopic where+  arbitrary = MatchingTopic <$> arbitraryMatchingTopic ['a'..'z'] (1,6) (1,6) (1,6)+  shrink (MatchingTopic (t,ms)) = fmap (MatchingTopic . (t,)) . shrinkList (const []) $ ms++-- | Generate an arbitrary topic segment (e.g. the 'X' in 'a\/X\/b') of a+-- given length from the given alphabet.+arbitraryTopicSegment :: [Char] -> Int -> Gen Text+arbitraryTopicSegment alphabet n = Text.pack <$> vectorOf n (elements alphabet)++-- | Generate an arbitrary ATopic from the given alphabet with lengths+-- of segments and the segment count specified by the given ranges.+arbitraryTopic :: [Char] -> (Int,Int) -> (Int,Int) -> Gen ATopic+arbitraryTopic alphabet seglen nsegs = do+  ATopic <$> someSegs+    where someSegs = choose nsegs >>= flip vectorOf aSeg+          aSeg = choose seglen >>= arbitraryTopicSegment alphabet++-- | Generate an arbitrary topic similarly to arbitraryTopic as well+-- as some arbitrary filters that should match that topic.+arbitraryMatchingTopic :: [Char] -> (Int,Int) -> (Int,Int) -> (Int,Int) -> Gen (Topic, [Filter])+arbitraryMatchingTopic alphabet seglen nsegs nfilts = do+    t@(ATopic tsegs) <- arbitraryTopic alphabet seglen nsegs+    fn <- choose nfilts+    reps <- vectorOf fn $ vectorOf (length tsegs) (elements [id, const "+", const "#"])+    let m = map (unTopic . ATopic . clean . zipWith (&) tsegs) reps+    pure $ (unTopic t, m)+      where+        clean []      = []+        clean ("#":_) = ["#"]+        clean (x:xs)  = x : clean xs

@@ -323,7 +323,7 @@       where         doSrc pch = runConduit $ src                     .| conduitParser (parsePacket _protocol)-                    .| C.mapM_ (\(_,x) -> liftIO (dispatch c pch x))+                    .| C.mapM_ (\(_,x) -> liftIO (dispatch c pch $! x))          onceConnected = atomically $ check . (== Connected) =<< readTVar _st 

@@ -13,7 +13,7 @@ {-# LANGUAGE RecordWildCards   #-}  module Network.MQTT.Types (-  LastWill(..), MQTTPkt(..), QoS(..),+  LastWill(..), MQTTPkt(..), QoS(..), qosFromInt,   ConnectRequest(..), connectRequest, SessionReuse(..), ConnACKFlags(..), ConnACKRC(..),   PublishRequest(..), PubACK(..), PubREC(..), PubREL(..), PubCOMP(..),   ProtocolLevel(..), Property(..), AuthRequest(..),@@ -46,6 +46,13 @@  wQos :: Word8 -> QoS wQos = toEnum . fromIntegral++-- | Parse a valid QoS value from an Int.+qosFromInt :: Int -> Maybe QoS+qosFromInt 0 = Just QoS0+qosFromInt 1 = Just QoS1+qosFromInt 2 = Just QoS2+qosFromInt _ = Nothing  (≫) :: Bits a => a -> Int -> a (≫) = shiftR

@@ -86,9 +86,18 @@                                 ("#/b", [])] in     map (\(p,want) -> testCase (show p) $ assertEqual "" want (filter (match p) allTopics)) tsts +prop_TopicMatching :: MatchingTopic -> QC.Property+prop_TopicMatching (MatchingTopic (t,ms)) = counterexample (show ms <> " doesn't match " <> show t) $+  all (\m -> match m t) ms+ byteRT :: (ByteSize a, Show a, Eq a) => a -> Bool byteRT x = x == (fromByte . toByte) x +testQoSFromInt :: Assertion+testQoSFromInt = do+  mapM_ (\q -> assertEqual (show q) (Just q) (qosFromInt (fromEnum q))) [QoS0 ..]+  assertEqual "invalid QoS" Nothing (qosFromInt 1939)+ tests :: [TestTree] tests = [   localOption (QC.QuickCheckTests 10000) $ testProperty "header length rt (parser)" prop_rtLengthParser,@@ -99,11 +108,13 @@   localOption (QC.QuickCheckTests 1000) $ testProperty "rt property" prop_PropertyRT,   testProperty "rt properties" prop_PropertiesRT,   testProperty "sub options" prop_SubOptionsRT,+  testCase "qosFromInt" testQoSFromInt,    testProperty "conn reasons" (byteRT :: ConnACKRC -> Bool),   testProperty "disco reasons" (byteRT :: DiscoReason -> Bool), -  testGroup "topic matching" testTopicMatching+  testGroup "topic matching" testTopicMatching,+  testProperty "arbitrary topic matching" prop_TopicMatching   ]  main :: IO ()