diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/app/mqtt-watch/Main.hs b/app/mqtt-watch/Main.hs --- a/app/mqtt-watch/Main.hs +++ b/app/mqtt-watch/Main.hs @@ -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)), diff --git a/net-mqtt.cabal b/net-mqtt.cabal --- a/net-mqtt.cabal +++ b/net-mqtt.cabal @@ -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 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 diff --git a/src/Network/MQTT/Arbitrary.hs b/src/Network/MQTT/Arbitrary.hs --- a/src/Network/MQTT/Arbitrary.hs +++ b/src/Network/MQTT/Arbitrary.hs @@ -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 diff --git a/src/Network/MQTT/Client.hs b/src/Network/MQTT/Client.hs --- a/src/Network/MQTT/Client.hs +++ b/src/Network/MQTT/Client.hs @@ -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 diff --git a/src/Network/MQTT/Types.hs b/src/Network/MQTT/Types.hs --- a/src/Network/MQTT/Types.hs +++ b/src/Network/MQTT/Types.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 ()