diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 - diff --git a/net-mqtt.cabal b/net-mqtt.cabal --- a/net-mqtt.cabal +++ b/net-mqtt.cabal @@ -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 category: Network 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 @@ -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 -- . +-- +-- 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 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 @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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])