net-mqtt 0.7.1.1 → 0.8.0.0

raw patch · 7 files changed

+109/−39 lines, 7 filesdep +checkersPVP ok

version bump matches the API change (PVP)

Dependencies added: checkers

API changes (from Hackage documentation)

Files

• Changelog.md +12/−0
• app/mqtt-watch/Main.hs +5/−3
• net-mqtt.cabal +3/−2
• src/Network/MQTT/Arbitrary.hs +13/−18
• src/Network/MQTT/Client.hs +16/−10
• src/Network/MQTT/Topic.hs +45/−6
• test/Spec.hs +15/−0

@@ -1,5 +1,17 @@ # Changelog for net-mqtt +## 0.8.0.0++The `Topic` and `Filter` types are now `newtype` wrappers around Text+instead of being aliases for text.  This is a breaking change, but+makes a lot of bugs harder to express.  There's a `split` function+available that will split a `Topic` or `Filter` into components, and+both types are `Semigroup`s joining on `/`.++Because these are `newtype`s, we the `Arbitrary` instances don't need+special wrappers, so `ATopic` is gone in favor of just `Topic`'s+`Arbitrary` instance.+ ## 0.7.1.0  More Arbitrary topic helpers.

@@ -13,9 +13,11 @@ import qualified Data.ByteString.Lazy.Char8 as BCS import qualified Data.IORef                 as R import           Data.Maybe                 (fromJust)+import qualified Data.Text                  as T import qualified Data.Text.IO               as TIO import           Data.Word                  (Word32) import           Network.MQTT.Client+import           Network.MQTT.Topic         (Filter, Topic, mkFilter, unTopic) import           Network.MQTT.Types         (ConnACKFlags (..), SessionReuse (..), qosFromInt) import           Network.URI import           Options.Applicative        (Parser, argument, auto, eitherReader, execParser, fullDesc, help, helper,@@ -33,7 +35,7 @@   , optVerbose     :: Bool   , optQoS         :: QoS   , optSubResume   :: Bool-  , optTopics      :: [Topic]+  , optTopics      :: [Filter]   }  options :: Parser Options@@ -44,7 +46,7 @@   <*> switch (short 'v' <> long "verbose" <> help "enable debug logging")   <*> 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..."))+  <*> some (argument (maybeReader (mkFilter . T.pack)) (metavar "topics..."))    where     pQoS = maybe (Left "Only QoS 0, 1, and 2 are supported") Right . (qosFromInt <=< readMaybe)@@ -52,7 +54,7 @@ printer :: TChan Msg -> Bool -> Bool -> IO () printer ch showProps verbose = forever $ do   (Msg t m props) <- atomically $ readTChan ch-  TIO.putStr $ mconcat [t, " → "]+  TIO.putStr $ mconcat [unTopic t, " → "]   BL.hPut stdout m   putStrLn ""   mapM_ (putStrLn . ("  " <>) . drop 4 . show) (filter (viewableProp showProps verbose) props)

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 61a8c0f6c844ddab092db68ee8410eaaa215e5ca65232f4b17cec8d5cc842ecc+-- hash: b407b40c8336bc1b3e8490c3097a2bf78450622686c0e5c0e621e33675b4829d  name:           net-mqtt-version:        0.7.1.1+version:        0.8.0.0 synopsis:       An MQTT Protocol Implementation. description:    Please see the README on GitHub at <https://github.com/dustin/mqtt-hs#readme> category:       Network@@ -132,6 +132,7 @@     , base >=4.7 && <5     , binary >=0.8.5 && <0.9     , bytestring >=0.10.8 && <0.12+    , checkers     , conduit >=1.3.1 && <1.4     , conduit-extra >=1.3.0 && <1.4     , connection >=0.2.0 && <0.4

@@ -12,11 +12,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Network.MQTT.Arbitrary (   SizeT(..),-  ATopic, unTopic, MatchingTopic(..),+  MatchingTopic(..),   arbitraryTopicSegment, arbitraryTopic, arbitraryMatchingTopic,   v311mask   ) where@@ -25,9 +26,10 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy  as L import           Data.Function         ((&))+import           Data.Maybe            (mapMaybe) import           Data.Text             (Text) import qualified Data.Text             as Text-import           Network.MQTT.Topic    (Filter, Topic)+import           Network.MQTT.Topic    (Filter, Topic, mkFilter, mkTopic, unTopic) import           Network.MQTT.Types    as MT import           Test.QuickCheck       as QC @@ -216,19 +218,12 @@ 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+instance Arbitrary Topic where   arbitrary = arbitraryTopic ['a'..'z'] (1,6) (1,6) -  shrink (ATopic x) = fmap ATopic . shrinkList shrinkWord $ x+  shrink (unTopic -> x) = mapMaybe (mkTopic . Text.intercalate "/") . shrinkList shrinkWord $ Text.splitOn "/" 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) @@ -241,11 +236,10 @@ arbitraryTopicSegment :: [Char] -> Int -> Gen Text arbitraryTopicSegment alphabet n = Text.pack <$> vectorOf n (elements alphabet) --- | Generate an arbitrary ATopic from the given alphabet with lengths+-- | Generate an arbitrary Topic 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+arbitraryTopic :: [Char] -> (Int,Int) -> (Int,Int) -> Gen Topic+arbitraryTopic alphabet seglen nsegs = someSegs `suchThatMap` (mkTopic . Text.intercalate "/")     where someSegs = choose nsegs >>= flip vectorOf aSeg           aSeg = choose seglen >>= arbitraryTopicSegment alphabet @@ -253,11 +247,12 @@ -- 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+    t <- arbitraryTopic alphabet seglen nsegs+    let tsegs = Text.splitOn "/" (unTopic t)     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)+    let m = mapMaybe (mkFilter . Text.intercalate "/" . clean . zipWith (&) tsegs) reps+    pure (t, m)       where         clean []      = []         clean ("#":_) = ["#"]

@@ -55,7 +55,7 @@ import           Data.Conduit.Network.TLS   (runTLSClient, tlsClientConfig, tlsClientTLSSettings) import           Data.Map.Strict            (Map) import qualified Data.Map.Strict            as Map-import           Data.Maybe                 (fromMaybe)+import           Data.Maybe                 (fromJust, fromMaybe) import           Data.Text                  (Text) import qualified Data.Text.Encoding         as TE import           Data.Word                  (Word16)@@ -68,7 +68,7 @@ import           System.IO.Error            (catchIOError, isEOFError) import           System.Timeout             (timeout) -import           Network.MQTT.Topic         (Filter, Topic)+import           Network.MQTT.Topic         (Filter, Topic, mkFilter, mkTopic, unFilter, unTopic) import           Network.MQTT.Types         as T  data ConnState = Starting@@ -426,7 +426,7 @@           corrs <- readTVarIO _corr           E.evaluate . force =<< case maybe _cb (\cd -> Map.findWithDefault _cb cd corrs) cdata of                                    NoCallback         -> pure ()-                                   SimpleCallback f   -> call (f c (blToText _pubTopic) _pubBody _pubProps)+                                   SimpleCallback f   -> call (f c (blToTopic _pubTopic) _pubBody _pubProps)                                    LowLevelCallback f -> call (f c p)              where@@ -438,15 +438,15 @@          resolve p@PublishRequest{..} = do           topic <- resolveTopic (foldr aliasID Nothing _pubProps)-          pure p{_pubTopic=textToBL topic}+          pure p{_pubTopic=textToBL (unTopic topic)}            where             aliasID (PropTopicAlias x) _ = Just x             aliasID _ o                  = o -            resolveTopic Nothing = pure (blToText _pubTopic)+            resolveTopic Nothing = pure (blToTopic _pubTopic)             resolveTopic (Just x) = do-              when (_pubTopic /= "") $ modifyTVar' _inA (Map.insert x (blToText _pubTopic))+              when (_pubTopic /= "") $ modifyTVar' _inA (Map.insert x (blToTopic _pubTopic))               m <- readTVar _inA               case Map.lookup x m of                 Nothing -> mqttFail ("failed to lookup topic alias " <> show x)@@ -496,6 +496,12 @@ blToText :: BL.ByteString -> Text blToText = TE.decodeUtf8 . BL.toStrict +blToTopic :: BL.ByteString -> Topic+blToTopic = fromJust . mkTopic . blToText++blToFilter :: BL.ByteString -> Filter+blToFilter = fromJust . mkFilter . blToText+ reservePktID :: MQTTClient -> [DispatchType] -> STM (TChan MQTTPkt, Word16) reservePktID c@MQTTClient{..} dts = do   checkConnected c@@ -534,7 +540,7 @@   let (SubACKPkt (SubscribeResponse _ rs aprops)) = r   pure (rs, aprops) -    where ls' = map (first textToBL) ls+    where ls' = map (first (textToBL . unFilter)) ls  -- | Unsubscribe from a list of topic filters. --@@ -545,7 +551,7 @@ -- should know about. unsubscribe :: MQTTClient -> [Filter] -> [Property] -> IO ([UnsubStatus], [Property]) unsubscribe c@MQTTClient{..} ls props = do-  (UnsubACKPkt (UnsubscribeResponse _ rsn rprop)) <- sendAndWait c DUnsubACK (\pid -> UnsubscribePkt $ UnsubscribeRequest pid (map textToBL ls) props)+  (UnsubACKPkt (UnsubscribeResponse _ rsn rprop)) <- sendAndWait c DUnsubACK (\pid -> UnsubscribePkt $ UnsubscribeRequest pid (map (textToBL . unFilter) ls) props)   pure (rprop, rsn)  -- | Publish a message (QoS 0).@@ -578,7 +584,7 @@                                              _pubQoS = q,                                              _pubPktID = pid,                                              _pubRetain = r,-                                             _pubTopic = textToBL t,+                                             _pubTopic = textToBL (unTopic t),                                              _pubBody = m,                                              _pubProps = props} @@ -624,7 +630,7 @@ mkLWT t m r = T.LastWill{   T._willRetain=r,   T._willQoS=QoS0,-  T._willTopic = textToBL t,+  T._willTopic = textToBL (unTopic t),   T._willMsg=m,   T._willProps=mempty   }

@@ -9,25 +9,64 @@ Topic and topic related utiilities. -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}  module Network.MQTT.Topic (-  Filter, Topic, match+  Filter, unFilter, Topic, unTopic, match,+  mkFilter, mkTopic, split ) where -import           Data.Text (Text, isPrefixOf, splitOn)+import           Data.String (IsString (..))+import           Data.Text   (Text, isPrefixOf, splitOn) +class Splittable a where+  -- | split separates a `Filter` or `Topic` into its `/`-separated components.+  split :: a -> [a]+ -- | An MQTT topic.-type Topic = Text+newtype Topic = Topic { unTopic :: Text } deriving (Show, Ord, Eq, IsString) +instance Splittable Topic where+  split (Topic t) = Topic <$> splitOn "/" t++instance Semigroup Topic where+  (Topic a) <> (Topic b) = Topic (a <> "/" <> b)++-- | mkTopic creates a topic from a text representation of a valid filter.+mkTopic :: Text -> Maybe Topic+mkTopic "" = Nothing+mkTopic t = Topic <$> validate (splitOn "/" t)+  where+    validate ("#":_) = Nothing+    validate ("+":_) = Nothing+    validate []      = Just t+    validate (_:xs)  = validate xs+ -- | An MQTT topic filter.-type Filter = Text+newtype Filter = Filter { unFilter :: Text } deriving (Show, Ord, Eq, IsString) +instance Splittable Filter where+  split (Filter f) = Filter <$> splitOn "/" f++instance Semigroup Filter where+  (Filter a) <> (Filter b) = Filter (a <> "/" <> b)++-- | mkFilter creates a filter from a text representation of a valid filter.+mkFilter :: Text -> Maybe Filter+mkFilter "" = Nothing+mkFilter t = Filter <$> validate (splitOn "/" t)+  where+    validate ["#"]   = Just t+    validate ("#":_) = Nothing+    validate []      = Just t+    validate (_:xs)  = validate xs+ -- | match returns true iff the given pattern can be matched by the -- specified Topic as defined in the -- <http://docs.oasis-open.org/mqtt/mqtt/v3.1.1/os/mqtt-v3.1.1-os.html#_Toc398718107 MQTT 3.1.1 specification>. match :: Filter -> Topic -> Bool-match pat top = cmp (splitOn "/" pat) (splitOn "/" top)+match (Filter pat) (Topic top) = cmp (splitOn "/" pat) (splitOn "/" top)    where     cmp [] []   = True

@@ -3,11 +3,16 @@ import           Control.Monad                   (mapM_) import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.ByteString.Lazy            as L+import           Data.String                     (fromString)+import qualified Data.Text                       as T import           Data.Word                       (Word8) import           Network.MQTT.Arbitrary import           Network.MQTT.Topic import           Network.MQTT.Types              as MT+ import           Test.QuickCheck                 as QC+import           Test.QuickCheck.Checkers+import           Test.QuickCheck.Classes import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck           as QC@@ -98,6 +103,13 @@   mapM_ (\q -> assertEqual (show q) (Just q) (qosFromInt (fromEnum q))) [QoS0 ..]   assertEqual "invalid QoS" Nothing (qosFromInt 1939) +instance Arbitrary Filter where+  arbitrary = ttof <$> arbitrary+    where ttof = fromString . T.unpack . unTopic++instance EqProp Filter where (=-=) = eq+instance EqProp Topic where (=-=) = eq+ tests :: [TestTree] tests = [   localOption (QC.QuickCheckTests 10000) $ testProperty "header length rt (parser)" prop_rtLengthParser,@@ -112,6 +124,9 @@    testProperty "conn reasons" (byteRT :: ConnACKRC -> Bool),   testProperty "disco reasons" (byteRT :: DiscoReason -> Bool),++  testProperties "topic semigroup" (unbatch $ semigroup (undefined :: Topic, undefined :: Int)),+  testProperties "filter semigroup" (unbatch $ semigroup (undefined :: Filter, undefined :: Int)),    testGroup "topic matching" testTopicMatching,   testProperty "arbitrary topic matching" prop_TopicMatching