diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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. 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 @@ -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) 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: 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 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 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 @@ -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 ("#":_) = ["#"] 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 @@ -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 } diff --git a/src/Network/MQTT/Topic.hs b/src/Network/MQTT/Topic.hs --- a/src/Network/MQTT/Topic.hs +++ b/src/Network/MQTT/Topic.hs @@ -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 -- . 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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