net-mqtt 0.8.6.5 → 0.8.7.0
raw patch · 5 files changed
+161/−39 lines, 5 files
Files
- Changelog.md +4/−1
- net-mqtt.cabal +1/−1
- src/Network/MQTT/Topic.hs +19/−12
- src/Network/MQTT/Types.hs +50/−23
- test/Spec.hs +87/−2
Changelog.md view
@@ -1,5 +1,9 @@ # Changelog for net-mqtt +## 0.8.7.0++Protocol strictness enhancements.+ ## 0.8.6.1 Use `def` for TLS settings.@@ -338,4 +342,3 @@ ### Other Updated to stackage LTS 13.2-
net-mqtt.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: net-mqtt-version: 0.8.6.5+version: 0.8.7.0 synopsis: An MQTT Protocol Implementation. description: Please see the README on GitHub at <https://github.com/dustin/mqtt-hs#readme> category: Network
src/Network/MQTT/Topic.hs view
@@ -19,6 +19,7 @@ import Data.String (IsString (..)) import Data.Text (Text, isPrefixOf, splitOn)+import qualified Data.Text as T class Splittable a where -- | split separates a `Filter` or `Topic` into its `/`-separated components.@@ -36,12 +37,10 @@ -- | 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+mkTopic t+ -- A topic name has no wildcards [MQTT-4.7.0-1].+ | T.any (`elem` ['#', '+']) t = Nothing+ | otherwise = Just (Topic t) -- | An MQTT topic filter. newtype Filter = Filter { unFilter :: Text } deriving (Show, Ord, Eq, IsString)@@ -57,26 +56,34 @@ mkFilter "" = Nothing mkFilter t = Filter <$> validate (splitOn "/" t) where+ -- A wildcard is a whole level, and # is only the last one+ -- [MQTT-4.7.1-1], [MQTT-4.7.1-2], [MQTT-4.7.1-3]. validate ["#"] = Just t validate ("#":_) = Nothing validate [] = Just t- validate (_:xs) = validate xs+ validate (x:xs)+ | x /= "+" && T.any (`elem` ['#', '+']) x = Nothing+ | otherwise = 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>.+--+-- A wildcard at the start of a filter doesn't match a topic beginning+-- with @$@, but wildcards further in match @$@ levels like any other+-- [MQTT-4.7.2-1]. match :: Filter -> Topic -> Bool-match (Filter pat) (Topic top) = cmp (splitOn "/" pat) (splitOn "/" top)+match (Filter pat) (Topic top) = case (splitOn "/" pat, splitOn "/" top) of+ (p:_, t:_) | p `elem` ["#", "+"] && "$" `isPrefixOf` t -> False+ (ps, ts) -> cmp ps ts where cmp [] [] = True cmp [] _ = False- cmp ["#"] [] = True+ cmp ["#"] _ = True cmp _ [] = False- cmp ["#"] (t:_) = not $ "$" `isPrefixOf` t cmp (p:ps) (t:ts)- | p == t = cmp ps ts- | p == "+" && not ("$" `isPrefixOf` t) = cmp ps ts+ | p == t || p == "+" = cmp ps ts | otherwise = False -- | Convert a 'Topic' to a 'Filter' as all 'Topic's are valid 'Filter's
src/Network/MQTT/Types.hs view
@@ -53,6 +53,11 @@ wQos :: Word8 -> QoS wQos = toEnum . fromIntegral +-- | Parse a QoS from its two bits; 3 isn't one.+pQos :: Word8 -> A.Parser QoS+pQos 3 = fail "invalid QoS"+pQos x = pure (wQos x)+ -- | Parse a valid QoS value from an Int. qosFromInt :: Int -> Maybe QoS qosFromInt 0 = Just QoS0@@ -420,24 +425,34 @@ parseConnect :: A.Parser MQTTPkt parseConnect = do _ <- A.word8 0x10- _ <- parseHdrLen- _ <- A.string "\NUL\EOTMQTT" -- "MQTT"- pl <- parseLevel+ hl <- parseHdrLen+ -- The fields are parsed within the Remaining Length, and must use all+ -- of it.+ body <- A.take hl+ either fail pure $ AS.parseOnly (connectBody <* AS.endOfInput) body - connFlagBits <- A.anyWord8- keepAlive <- aWord16- props <- parseProperties pl- cid <- aString- lwt <- parseLwt pl connFlagBits- u <- mstr (testBit connFlagBits 7)- p <- mstr (testBit connFlagBits 6)+ where+ connectBody = do+ _ <- A.string "\NUL\EOTMQTT" -- "MQTT"+ pl <- parseLevel - pure $ ConnPkt ConnectRequest{_connID=cid, _username=u, _password=p,- _lastWill=lwt, _keepAlive=keepAlive,- _cleanSession=testBit connFlagBits 1,- _connProperties=props} pl+ connFlagBits <- A.anyWord8+ -- The reserved flag is 0 [MQTT-3.1.2-3], and without a will, so are+ -- the will QoS and retain [MQTT-3.1.2-11], [MQTT-3.1.2-13], [MQTT-3.1.2-15].+ when (testBit connFlagBits 0) $ fail "reserved CONNECT flag set"+ when (not (testBit connFlagBits 2) && connFlagBits .&. 0x38 /= 0) $ fail "will flags set without a will"+ keepAlive <- aWord16+ props <- parseProperties pl+ cid <- aString+ lwt <- parseLwt pl connFlagBits+ u <- mstr (testBit connFlagBits 7)+ p <- mstr (testBit connFlagBits 6) - where+ pure $ ConnPkt ConnectRequest{_connID=cid, _username=u, _password=p,+ _lastWill=lwt, _keepAlive=keepAlive,+ _cleanSession=testBit connFlagBits 1,+ _connProperties=props} pl+ mstr :: Bool -> A.Parser (Maybe BL.ByteString) mstr False = pure Nothing mstr True = Just <$> aString@@ -450,9 +465,10 @@ props <- parseProperties pl top <- aString msg <- aString+ q <- pQos $ (bits ≫ 3) .&. 0x3 pure $ Just LastWill{_willTopic=top, _willMsg=msg, _willRetain=testBit bits 5,- _willQoS=wQos $ (bits ≫ 3) .&. 0x3,+ _willQoS=q, _willProps = props} | otherwise = pure Nothing @@ -576,8 +592,8 @@ parsePublish prot = do w <- A.satisfy (\x -> x .&. 0xf0 == 0x30) plen <- parseHdrLen+ _pubQoS <- pQos $ (w ≫ 1) .&. 3 -- [MQTT-3.3.1-4] let _pubDup = w .&. 0x8 == 0x8- _pubQoS = wQos $ (w ≫ 1) .&. 3 _pubRetain = w .&. 1 == 1 _pubTopic <- aString _pubPktID <- if _pubQoS == QoS0 then pure 0 else aWord16@@ -629,16 +645,21 @@ parseSubOptions :: A.Parser SubOptions parseSubOptions = do w <- A.anyWord8- let rh = case w ≫ 4 of- 1 -> SendOnSubscribeNew- 2 -> DoNotSendOnSubscribe- _ -> SendOnSubscribe+ -- The reserved bits are 0, and Retain Handling 3 is a protocol error+ -- [MQTT-3.8.3-5].+ when (w .&. 0xc0 /= 0) $ fail "reserved subscription option bits set"+ rh <- case w ≫ 4 of+ 0 -> pure SendOnSubscribe+ 1 -> pure SendOnSubscribeNew+ 2 -> pure DoNotSendOnSubscribe+ _ -> fail "invalid retain handling"+ q <- pQos (w .&. 0x3) pure $ SubOptions{ _retainHandling=rh, _retainAsPublished=testBit w 3, _noLocal=testBit w 2,- _subQoS=wQos (w .&. 0x3)}+ _subQoS=q} subOptionsBytes :: ProtocolLevel -> [(BL.ByteString, SubOptions)] -> BL.ByteString subOptionsBytes prot = foldMap (\(bs,so) -> toByteString prot bs <> toByteString prot so)@@ -717,8 +738,14 @@ parseSubscribe :: ProtocolLevel -> A.Parser MQTTPkt parseSubscribe prot = do- (pid, props, subs) <- parseSubHdr 0x82 prot $ A.many1 (liftA2 (,) aString parseSubOptions)+ (pid, props, subs) <- parseSubHdr 0x82 prot $ A.many1 (liftA2 (,) aString (v311 *> parseSubOptions)) pure $ SubscribePkt (SubscribeRequest pid subs props)++ where+ -- In 3.1.1, everything but the QoS is reserved [MQTT-3-8.3-4].+ v311+ | prot == Protocol311 = A.peekWord8' >>= \w -> when (w .&. 0xfc /= 0) (fail "reserved subscription option bits set")+ | otherwise = pure () data SubscribeResponse = SubscribeResponse PktID [Either SubErr QoS] [Property] deriving (Eq, Show)
test/Spec.hs view
@@ -112,16 +112,36 @@ testTopicMatching :: [TestTree] testTopicMatching = let allTopics = ["a", "a/b", "a/b/c/d", "b/a/c/d", "$SYS/a/b", "a/$SYS/b"]- tsts = [("a", ["a"]), ("a/#", ["a", "a/b", "a/b/c/d"]),+ -- Wildcards don't match a $ level only at the start of+ -- the topic [MQTT-4.7.2-1].+ tsts = [("a", ["a"]), ("a/#", ["a", "a/b", "a/b/c/d", "a/$SYS/b"]), ("+/b", ["a/b"]), ("+/+/c/+", ["a/b/c/d", "b/a/c/d"]),- ("+/+/b", []),+ ("+/+/b", ["a/$SYS/b"]),+ ("#", ["a", "a/b", "a/b/c/d", "b/a/c/d", "a/$SYS/b"]),+ ("+/#", ["a", "a/b", "a/b/c/d", "b/a/c/d", "a/$SYS/b"]),+ ("+/a/b", []), ("+/$SYS/b", ["a/$SYS/b"]), ("$SYS/#", ["$SYS/a/b"]), ("+/$SYS/+", ["a/$SYS/b"]), ("#/b", [])] in map (\(p,want) -> testCase (show p) $ assertEqual "" want (filter (match p) allTopics)) tsts +-- Wildcards must occupy a whole level, # only the last+-- [MQTT-4.7.1-1], [MQTT-4.7.1-2], [MQTT-4.7.1-3], and a topic name has+-- none [MQTT-4.7.0-1].+testFilterValidation :: Assertion+testFilterValidation = do+ mapM_ (\f -> assertEqual (show f) (Just f) (unFilter <$> mkFilter f))+ ["a", "#", "+", "a/#", "a/+/b", "+/+", "/", "a//b", "$SYS/#", "+/#"]+ mapM_ (\f -> assertEqual (show f) Nothing (unFilter <$> mkFilter f))+ ["", "a+", "a/b+/c", "a#", "a/#b", "#/a", "a/#/b", "+a"]++testTopicValidation :: Assertion+testTopicValidation = do+ mapM_ (\t -> assertEqual (show t) (Just t) (unTopic <$> mkTopic t)) ["a", "a/b", "/", "a//b", "$SYS/x"]+ mapM_ (\t -> assertEqual (show t) Nothing (unTopic <$> mkTopic t)) ["", "#", "+", "a/+", "a/#", "a+b", "a#", "a/b+"]+ prop_TopicMatching :: MatchingTopic -> QC.Property prop_TopicMatching (MatchingTopic (t,ms)) = counterexample (show ms <> " doesn't match " <> show t) $ all (`match` t) ms@@ -149,6 +169,8 @@ testProperties "filter semigroup" (unbatch $ semigroup (undefined :: Filter, undefined :: Int)), testGroup "topic matching" testTopicMatching,+ testCase "filter validation" testFilterValidation,+ testCase "topic validation" testTopicValidation, testProperty "arbitrary topic matching" prop_TopicMatching ] @@ -175,3 +197,66 @@ -- A Remaining Length of 1 is a reason code with no properties [MQTT 5 §3.15.2.2.1]. unit_authReasonOnly50 :: Assertion unit_authReasonOnly50 = parses50 [0xf0, 0x01, 0x18] (AuthPkt (AuthRequest 0x18 []))++-- | The given bytes aren't a valid packet at the given level.+rejects :: A.Parser MQTTPkt -> [Word8] -> Assertion+rejects p bs = case A.parse p (L.pack bs) of+ A.Fail{} -> pure ()+ A.Done _ pk -> assertFailure (show bs <> " parsed as " <> show pk)++subscribeWith :: ProtocolLevel -> Word8 -> [Word8]+subscribeWith Protocol50 o = [0x82, 0x07, 0x00, 0x01, 0x00, 0x00, 0x01, 0x61, o]+subscribeWith Protocol311 o = [0x82, 0x06, 0x00, 0x01, 0x00, 0x01, 0x61, o]++-- Retain Handling 3 is a protocol error, and the reserved bits must be 0+-- [MQTT-3.8.3-5]. So must a QoS of 3 [MQTT-3-8.3-4].+unit_subOptionsRetainHandling3 :: Assertion+unit_subOptionsRetainHandling3 = rejects (parsePacket Protocol50) (subscribeWith Protocol50 0x30)++unit_subOptionsReserved :: Assertion+unit_subOptionsReserved = mapM_ (rejects (parsePacket Protocol50) . subscribeWith Protocol50) [0x40, 0x80]++unit_subOptionsQoS3 :: Assertion+unit_subOptionsQoS3 = rejects (parsePacket Protocol50) (subscribeWith Protocol50 0x03)++unit_subOptionsValid :: Assertion+unit_subOptionsValid = parses50 (subscribeWith Protocol50 0x2e)+ (SubscribePkt (SubscribeRequest 1 [("a", SubOptions{_retainHandling=DoNotSendOnSubscribe, _retainAsPublished=True,+ _noLocal=True, _subQoS=QoS2})] []))++-- In 3.1.1, everything but the QoS is reserved [MQTT-3-8.3-4].+unit_subOptionsReserved311 :: Assertion+unit_subOptionsReserved311 = mapM_ (rejects (parsePacket Protocol311) . subscribeWith Protocol311) [0x04, 0x08, 0x10]++-- A PUBLISH can't have QoS 3 [MQTT-3.3.1-4].+unit_publishQoS3 :: Assertion+unit_publishQoS3 = rejects (parsePacket Protocol311) [0x36, 0x05, 0x00, 0x01, 0x61, 0x00, 0x01]++connectWithFlags :: Word8 -> [Word8] -> [Word8]+connectWithFlags flags rest = [0x10, fromIntegral (13 + length rest), 0x00, 0x04, 0x4d, 0x51, 0x54, 0x54, 0x04, flags,+ 0x00, 0x3c, 0x00, 0x01, 0x78] <> rest++-- The CONNECT flags' reserved bit must be 0 [MQTT-3.1.2-3].+unit_connectReservedFlag :: Assertion+unit_connectReservedFlag = rejects parseConnect (connectWithFlags 0x03 [])++-- Without a will, the will QoS and retain must be 0 [MQTT-3.1.2-11],+-- [MQTT-3.1.2-13], [MQTT-3.1.2-15]; with one, its QoS isn't 3 [MQTT-3.1.2-14].+unit_connectWillFlags :: Assertion+unit_connectWillFlags = do+ mapM_ (rejects parseConnect . (`connectWithFlags` [])) [0x0a, 0x12, 0x22]+ rejects parseConnect (connectWithFlags 0x1e [0x00, 0x01, 0x74, 0x00, 0x01, 0x6d])++unit_connectValid :: Assertion+unit_connectValid = case A.parse parseConnect (L.pack (connectWithFlags 0x2e [0x00, 0x01, 0x74, 0x00, 0x01, 0x6d])) of+ A.Done "" (ConnPkt ConnectRequest{_lastWill=Just LastWill{_willQoS=QoS1, _willRetain=True}} Protocol311) -> pure ()+ x -> assertFailure (show x)++-- A CONNECT is parsed within its Remaining Length. The will fields+-- aren't read from whatever follows it [MQTT-3.1.2-9]...+unit_connectWillFieldsMissing :: Assertion+unit_connectWillFieldsMissing = rejects parseConnect (connectWithFlags 0x06 [] <> [0x00, 0x01, 0x74, 0x00, 0x01, 0x6d])++-- ...and bytes left over after its fields make it malformed.+unit_connectTrailingBytes :: Assertion+unit_connectTrailingBytes = rejects parseConnect (connectWithFlags 0x02 [0x00])