diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,11 @@ # Changelog for net-mqtt +## 0.8.6.0 + +Can forget in-flight and correlation data over time. + +Thanks to Alberto Valverde + ## 0.8.5.0 Switch to crypton-connection 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.5.0 +version: 0.8.6.0 synopsis: An MQTT Protocol Implementation. description: Please see the README on GitHub at category: Network @@ -27,6 +27,8 @@ library exposed-modules: + Data.Map.Strict.Decaying + Data.Map.Strict.Expiring Network.MQTT.Arbitrary Network.MQTT.Client Network.MQTT.Topic @@ -48,10 +50,12 @@ , containers >=0.5.0 && <0.7 , crypton-connection >=0.3.0 , deepseq >=1.4.3.0 && <1.5 + , monad-loops >=0.4.3 , network-conduit-tls ==1.4.* , network-uri >=2.6.1 && <2.7 , stm >=2.4.0 && <2.6 , text >=1.2.3 && <2.1.0 + , time >=1.9 , websockets >=0.12.5.3 && <0.13 default-language: Haskell2010 @@ -75,11 +79,13 @@ , containers >=0.5.0 && <0.7 , crypton-connection >=0.3.0 , deepseq >=1.4.3.0 && <1.5 + , monad-loops >=0.4.3 , net-mqtt , network-conduit-tls ==1.4.* , network-uri >=2.6.1 && <2.7 , stm >=2.4.0 && <2.6 , text >=1.2.3 && <2.1.0 + , time >=1.9 , websockets >=0.12.5.3 && <0.13 default-language: Haskell2010 @@ -103,21 +109,26 @@ , containers >=0.5.0 && <0.7 , crypton-connection >=0.3.0 , deepseq >=1.4.3.0 && <1.5 + , monad-loops >=0.4.3 , net-mqtt , network-conduit-tls ==1.4.* , network-uri >=2.6.1 && <2.7 , optparse-applicative , stm >=2.4.0 && <2.6 , text >=1.2.3 && <2.1.0 + , time >=1.9 , websockets >=0.12.5.3 && <0.13 default-language: Haskell2010 test-suite mqtt-test type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Main.hs other-modules: + DecayingSpec Example1 Example2 + ExpiringSpec + Spec Paths_net_mqtt hs-source-dirs: test @@ -137,13 +148,18 @@ , containers >=0.5.0 && <0.7 , crypton-connection >=0.3.0 , deepseq >=1.4.3.0 && <1.5 + , lens + , monad-loops >=0.4.3 + , mtl , net-mqtt , network-conduit-tls ==1.4.* , network-uri >=2.6.1 && <2.7 , stm >=2.4.0 && <2.6 , tasty + , tasty-discover , tasty-hunit , tasty-quickcheck , text >=1.2.3 && <2.1.0 + , time >=1.9 , websockets >=0.12.5.3 && <0.13 default-language: Haskell2010 diff --git a/src/Data/Map/Strict/Decaying.hs b/src/Data/Map/Strict/Decaying.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Strict/Decaying.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} +module Data.Map.Strict.Decaying + ( Map, + new, + insert, + delete, + elems, + findWithDefault, + updateLookupWithKey, + + -- * Testing Hooks + tick, + ) +where + +import Control.Concurrent.Async (async, cancel, link) +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar (TVar, mkWeakTVar, modifyTVar', newTVarIO, readTVar, stateTVar, writeTVar) +import Control.Exception (mask) +import Control.Monad (forever, join, void, (<=<)) +import Control.Monad.Loops (whileJust_) +import Data.Foldable (toList) +import qualified Data.Map.Strict.Expiring as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time (NominalDiffTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import GHC.Conc (threadDelay) +import System.Mem.Weak (deRefWeak) + +data Map k a = Map { + mapVar :: TVar (Map.Map POSIXTime k a), + maxAge :: NominalDiffTime +} + +expiry :: NominalDiffTime -> Map.Map POSIXTime k a -> POSIXTime +expiry ma = (+ ma) . Map.generation + +insert :: Ord k => k -> v -> Map k v -> STM () +insert k v (Map m ma) = modifyTVar' m (\m -> Map.insert (expiry ma m) k v m) + +delete :: Ord k => k -> Map k v -> STM () +delete k (Map m _) = modifyTVar' m (Map.delete k) + +findWithDefault :: Ord k => v -> k -> Map k v -> STM v +findWithDefault d k Map{..} = fromMaybe d . Map.lookup k <$> readTVar mapVar + +-- | All visible records. +elems :: Map k a -> STM [a] +elems Map{..} = toList <$> readTVar mapVar + +tick :: Ord k => Map k v -> IO () +tick Map{..} = getPOSIXTime >>= \t -> atomically $ modifyTVar' mapVar (Map.newGen t) + +updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> STM (Maybe a) +updateLookupWithKey f k (Map mv ma) = stateTVar mv (\m -> Map.updateLookupWithKey (expiry ma m) f k m) + +new :: Ord k => NominalDiffTime -> IO (Map k a) +new maxAge = mask $ \restore -> do + now <- getPOSIXTime + var <- newTVarIO (Map.new now) + wVar <- mkWeakTVar var $ pure () + let m = Map var maxAge + link <=< restore $ async $ whileJust_ (deRefWeak wVar) (\m' -> tick' m' *> threadDelay 1000000) + pure m + where + tick' m = getPOSIXTime >>= \t -> atomically $ modifyTVar' m (Map.newGen t) diff --git a/src/Data/Map/Strict/Expiring.hs b/src/Data/Map/Strict/Expiring.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Strict/Expiring.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Data.Map.Strict.Expiring ( + Map, + new, + generation, + newGen, + + insert, + delete, + lookup, + updateLookupWithKey, + assocs, + + -- * for testing + inspect +) where + +import Data.Foldable (fold) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (lookup, map) + +data Entry g a = Entry { + value :: !a, + gen :: !g +} deriving (Functor, Show) + +-- | A map of values that expire after a given generation. +data Map g k a = Map { + -- | Primary store of values. + map :: !(Map.Map k (Entry g a)), + -- | The current generation + generation :: !g, + -- | A map of generations to keys that are expiring at that generation. + aging :: !(Map.Map g (Set k)) +} deriving (Functor, Show) + +instance Ord g => Foldable (Map g k) where + foldMap f = foldMap (f . value) . Map.elems . map + +-- | Make a new empty Map at the starting generation. +new :: g -> Map g k a +new g = Map Map.empty g Map.empty + +-- | 𝑂(log𝑛). Assign the next generation and expire any data this new generation invalidates. +-- The generation may never decrease. Attempts to decrease it are ignored. +newGen :: (Ord k, Ord g) => g -> Map g k a -> Map g k a +newGen g m + | g > generation m = expire m { generation = g } + | otherwise = m + +-- | 𝑂(log𝑛). Insert a new value into the map to expire after the given generation. +-- alterF :: (Functor f, Ord k) => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) +insert :: (Ord k, Ord g) => g -> k -> a -> Map g k a -> Map g k a +insert g _ _ m | g < generation m = m +insert g k v m@Map{..} = case Map.alterF (, Just (Entry v g)) k map of + (Just old, m') -> m{map=m', aging = Map.insertWith (<>) g (Set.singleton k) (removeAging (gen old) k aging)} + (Nothing, m') -> m{map=m', aging = Map.insertWith (<>) g (Set.singleton k) aging} + +-- | 𝑂(log𝑛). Lookup and update. +-- The function returns changed value, if it is updated. Returns the original key value if the map entry is deleted. +updateLookupWithKey :: (Ord g, Ord k) => g -> (k -> a -> Maybe a) -> k -> Map g k a -> (Maybe a, Map g k a) +updateLookupWithKey g _ _ m | g < generation m = (Nothing, m) +updateLookupWithKey g f k m@Map{..} = case Map.alterF f' k map of + ((Nothing, _), m') -> (Nothing, m) + ((Just old, Nothing), m') -> (Just (value old), m{map=m', aging = removeAging (gen old) k aging}) + ((Just old, Just new), m') -> (Just (value new), m{map=m', aging = Map.insertWith (<>) g (Set.singleton k) (removeAging (gen old) k aging)}) + where + f' Nothing = ((Nothing, Nothing), Nothing) + f' (Just e) = case f k (value e) of + Nothing -> ((Just e, Nothing), Nothing) + Just v -> ((Just e, Just (Entry v g)), Just (Entry v g)) + +removeAging :: (Ord g, Ord k) => g -> k -> Map.Map g (Set k) -> Map.Map g (Set k) +removeAging g k = Map.update (nonNull . Set.delete k) g + where nonNull s = if Set.null s then Nothing else Just s + +-- | 𝑂(log𝑛). Lookup a value in the map. +-- This will not return any items that have expired. +lookup :: (Ord k, Ord g) => k -> Map g k a -> Maybe a +lookup k = fmap value . Map.lookup k . map + +-- | 𝑂(log𝑛). Delete an item. +delete :: (Ord k, Ord g) => k -> Map g k a -> Map g k a +delete k m@Map{..} = case Map.lookup k map of + Nothing -> m + Just Entry{..} -> m { map = Map.delete k map, aging = removeAging gen k aging } + +-- | 𝑂(𝑛). Return all current key/value associations. +assocs :: Ord g => Map g k a -> [(k,a)] +assocs Map{..} = fmap value <$> Map.assocs map + +-- | 𝑂(log𝑛). Expire older generation items. +expire :: (Ord g, Ord k) => Map g k a -> Map g k a +expire m@Map{..} = m{ map = map', aging = aging'} + where + (todo, exact, later) = Map.splitLookup generation aging + aging' = later <> maybe mempty (Map.singleton generation) exact + map' = foldr Map.delete map (fold todo) + +-- | Inspect stored size for testing. +inspect :: Ord k => Map g k a -> (Int, g, Int) +inspect Map{..} = (Map.size map, generation, length $ fold aging) 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 @@ -59,6 +59,7 @@ import Data.Foldable (traverse_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict.Decaying as Decaying import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import qualified Data.Text.Encoding as TE @@ -106,6 +107,7 @@ -- | A low level callback that is ordered. | OrderedLowLevelCallback (MQTTClient -> PublishRequest -> IO ()) + -- | The MQTT client. -- -- See 'connectURI' for the most straightforward example. @@ -114,13 +116,13 @@ , _pktID :: TVar Word16 , _cb :: MessageCallback , _acks :: TVar (Map (DispatchType,Word16) (TChan MQTTPkt)) - , _inflight :: TVar (Map Word16 PublishRequest) + , _inflight :: Decaying.Map Word16 PublishRequest , _st :: TVar ConnState , _ct :: TVar (Maybe (Async ())) , _outA :: TVar (Map Topic Word16) , _inA :: TVar (Map Word16 Topic) , _connACKFlags :: TVar ConnACKFlags - , _corr :: TVar (Map BL.ByteString MessageCallback) + , _corr :: Decaying.Map BL.ByteString MessageCallback , _cbM :: MVar (IO ()) , _cbHandle :: TVar (Maybe (Async ())) } @@ -291,13 +293,13 @@ _ch <- newTChanIO _pktID <- newTVarIO 1 _acks <- newTVarIO mempty - _inflight <- newTVarIO mempty + _inflight <- Decaying.new 60 _st <- newTVarIO Starting _ct <- newTVarIO Nothing _outA <- newTVarIO mempty _inA <- newTVarIO mempty _connACKFlags <- newTVarIO (ConnACKFlags NewSession ConnUnspecifiedError mempty) - _corr <- newTVarIO mempty + _corr <- Decaying.new 600 _cbM <- newEmptyMVar _cbHandle <- newTVarIO Nothing let _cb = _msgCB @@ -437,22 +439,17 @@ notify (Just (PubACKPkt (PubACK _pubPktID 0 mempty))) =<< atomically (resolve p) pub p@PublishRequest{_pubQoS=QoS2} = atomically $ do p'@PublishRequest{..} <- resolve p - modifyTVar' _inflight (Map.insert _pubPktID p') + Decaying.insert _pubPktID p' _inflight sendPacket c (PubRECPkt (PubREC _pubPktID 0 mempty)) - pubd i = do - mp <- atomically $ do - r <- Map.lookup i <$> readTVar _inflight - modifyTVar' _inflight (Map.delete i) - pure r - case mp of + pubd i = atomically (Decaying.updateLookupWithKey (\_ _ -> Nothing) i _inflight) >>= \case Nothing -> sendPacketIO c (PubCOMPPkt (PubCOMP i 0x92 mempty)) Just p -> notify (Just (PubCOMPPkt (PubCOMP i 0 mempty))) p notify rpkt p@PublishRequest{..} = do - atomically $ modifyTVar' _inflight (Map.delete _pubPktID) - corrs <- readTVarIO _corr - E.evaluate . force =<< case maybe _cb (\cd -> Map.findWithDefault _cb cd corrs) cdata of + atomically $ Decaying.delete _pubPktID _inflight + cb <- maybe (pure _cb) (\cd -> atomically (Decaying.findWithDefault _cb cd _corr)) cdata + E.evaluate . force =<< case cb of NoCallback -> pure () SimpleCallback f -> call (f c (blToTopic _pubTopic) _pubBody _pubProps) OrderedCallback f -> callOrd (f c (blToTopic _pubTopic) _pubBody _pubProps) @@ -750,8 +747,8 @@ -- -- This registration will remain in place until unregisterCorrelated is called to remove it. registerCorrelated :: MQTTClient -> BL.ByteString -> MessageCallback -> STM () -registerCorrelated MQTTClient{_corr} bs = modifyTVar' _corr . Map.insert bs +registerCorrelated MQTTClient{_corr} bs cb = Decaying.insert bs cb _corr -- | Unregister a callback handler for the given correlated data identifier. unregisterCorrelated :: MQTTClient -> BL.ByteString -> STM () -unregisterCorrelated MQTTClient{_corr} = modifyTVar' _corr . Map.delete +unregisterCorrelated MQTTClient{_corr} bs = Decaying.delete bs _corr diff --git a/test/DecayingSpec.hs b/test/DecayingSpec.hs new file mode 100644 --- /dev/null +++ b/test/DecayingSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module DecayingSpec where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (STM, atomically) +import Control.Monad (foldM, mapM_) +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.ByteString.Lazy as L +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict.Decaying as DecayingMap +import Data.Set (Set) +import qualified Data.Set as Set + +import Test.QuickCheck + +prop_decayingMapWorks :: [Int] -> Property +prop_decayingMapWorks keys = idempotentIOProperty $ do + m <- DecayingMap.new 60 + atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys + found <- atomically $ traverse (\x -> DecayingMap.findWithDefault maxBound x m) keys + pure $ found === keys + +prop_decayingMapDecays :: [Int] -> Property +prop_decayingMapDecays keys = idempotentIOProperty $ do + m <- DecayingMap.new 0.001 + atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys + threadDelay 5000 + DecayingMap.tick m + found <- atomically $ DecayingMap.elems m + pure $ found === [] + +prop_decayingMapUpdates :: Set Int -> Property +prop_decayingMapUpdates (Set.toList -> keys) = idempotentIOProperty $ do + m <- DecayingMap.new 60 + atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys + updated <- atomically $ traverse (\x -> DecayingMap.updateLookupWithKey (\_ v -> Just (v + 1)) x m) keys + found <- atomically $ traverse (\x -> DecayingMap.findWithDefault maxBound x m) keys + pure $ (found === fmap (+ 1) keys .&&. Just found === sequenceA updated) + +prop_decayingMapDeletes :: Set Int -> Property +prop_decayingMapDeletes (Set.toList -> keys) = (not . null) keys ==> idempotentIOProperty $ do + m <- DecayingMap.new 60 + atomically $ traverse_ (\x -> DecayingMap.insert x x m) keys + atomically $ traverse (`DecayingMap.delete` m) (tail keys) + found <- atomically $ DecayingMap.elems m + pure $ found === take 1 keys diff --git a/test/ExpiringSpec.hs b/test/ExpiringSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExpiringSpec.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module ExpiringSpec where + +import Control.Lens +import Data.Bool (bool) +import Data.Foldable (foldl', toList, traverse_) +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict.Expiring as ExpiringMap +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) + +import Test.QuickCheck + +data SomeKey = Key1 | Key2 | Key3 | Key4 | Key5 + deriving (Bounded, Enum, Eq, Ord, Show) + +instance Arbitrary SomeKey where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum + +newtype GenOffset = GenOffset { getOffset :: Int } + deriving (Eq, Ord) + deriving newtype (Show, Num, Bounded) + +instance Arbitrary GenOffset where + arbitrary = GenOffset <$> choose (0, 5) + shrink = fmap GenOffset . shrink . getOffset + +data Mutation = Insert GenOffset SomeKey Int + | Delete SomeKey + | Update GenOffset SomeKey Int + | UpdateNothing GenOffset SomeKey + | NewGeneration GenOffset + deriving (Show, Generic) + +makePrisms ''Mutation + +instance Arbitrary Mutation where + arbitrary = oneof [Insert <$> arbitrary <*> arbitrary <*> arbitrary, + Delete <$> arbitrary, + Update <$> arbitrary <*> arbitrary <*> arbitrary, + UpdateNothing <$> arbitrary <*> arbitrary, + NewGeneration <$> arbitrary + ] + shrink = genericShrink + +allOpTypes :: [String] +allOpTypes = ["Insert", "Delete", "Update", "UpdateNothing", "NewGeneration"] + +-- Verify that after a series of operations, the map and expiring map return the same values for the given keys. +prop_doesMapStuff :: [Mutation] -> [SomeKey] -> Property +prop_doesMapStuff ops lookups = + coverTable "mutation types" ((,5) <$> allOpTypes) $ -- The test paths should hit every mutation type (5% min) + tabulate "mutation types" (takeWhile (/= ' ') . show <$> ops) $ -- We can identify one by the first word in its constructor + checkCoverage $ + ((`Map.lookup` massocs) <$> lookups) === ((`ExpiringMap.lookup` eassocs) <$> lookups) + where + massocs = degenerate $ foldl' applyOpM (0, mempty) ops + eassocs = foldl' applyOpE (ExpiringMap.new 0) ops + + -- The emulation stores the generation along with the value, so when we're done, we fmap away the generation. + degenerate :: (GenOffset, Map.Map SomeKey (GenOffset, Int)) -> Map.Map SomeKey Int + degenerate = fmap snd . snd + + applyOpM (gen, m) = \case + Insert g k v -> (gen, Map.insert k (gen+g, v) m) + Delete k -> (gen, Map.delete k m) + Update g k v -> (gen, snd $ Map.updateLookupWithKey (\_ _ -> Just (gen+g, v)) k m) + UpdateNothing _ k -> (gen, snd $ Map.updateLookupWithKey (\_ _ -> Nothing) k m) + NewGeneration n -> (gen + n, Map.filter ((>= gen + n) . fst) m) + + applyOpE m = \case + Insert g k v -> ExpiringMap.insert (gen + g) k v m + Delete k -> ExpiringMap.delete k m + Update g k v -> snd $ ExpiringMap.updateLookupWithKey (gen + g) (\k' _ -> bool Nothing (Just v) (k == k')) k m + UpdateNothing g k -> snd $ ExpiringMap.updateLookupWithKey (gen + g) (\_ _ -> Nothing) k m + NewGeneration g -> ExpiringMap.newGen (gen + g) m + where gen = ExpiringMap.generation m + +prop_updateReturn :: Int -> Property +prop_updateReturn x = (Just plus2, Just plus2, Nothing, Just plus2) === (up1, ExpiringMap.lookup x m', up2, up3) + where + m = ExpiringMap.insert 0 x 0 $ ExpiringMap.new 0 + plus2 = x + 2 + (up1, m') = ExpiringMap.updateLookupWithKey 0 (\_ v -> Just (x + 2)) x m -- New value returns new value + (up2, m'') = ExpiringMap.updateLookupWithKey 0 (\_ v -> Just (x + 3)) (x + 1) m' -- Missing returns nothing + up3 = fst $ ExpiringMap.updateLookupWithKey 0 (\_ v -> Nothing) x m'' -- Nothing returns previous value + +prop_cannotAcceptExpired :: Positive Int -> Positive Int -> Int -> Property +prop_cannotAcceptExpired (Positive lowGen) (Positive offset) k = ExpiringMap.inspect m === ExpiringMap.inspect m' + where + highGen = lowGen + offset + m = ExpiringMap.new highGen :: ExpiringMap.Map Int Int Int + m' = ExpiringMap.insert lowGen k k m + +prop_cannotUpdateExpired :: Positive Int -> Positive Int -> Int -> Property +prop_cannotUpdateExpired (Positive lowGen) (Positive offset) k = mv === Nothing .&&. ExpiringMap.lookup k m' === Just True + where + highGen = lowGen + offset + m = ExpiringMap.insert highGen k True $ ExpiringMap.new highGen + (mv, m') = ExpiringMap.updateLookupWithKey lowGen (\_ _ -> Just False) k m + +prop_assocs :: [SomeKey] -> Property +prop_assocs keys = ExpiringMap.assocs m === Map.assocs (Map.fromList $ zip keys keys) + where + m = foldr (\k -> ExpiringMap.insert 0 k k) (ExpiringMap.new 0) keys + +prop_generation :: Int -> Int -> Property +prop_generation g1 g2 = ExpiringMap.inspect m === (0, max g1 g2, 0) + where + m :: ExpiringMap.Map Int Int Int + m = ExpiringMap.newGen g2 $ ExpiringMap.new g1 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -import Control.Monad (mapM_) + +module Spec where + import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.ByteString.Lazy as L +import Data.Foldable (toList, traverse_) import Data.String (fromString) import qualified Data.Text as T import Data.Word (Word8) @@ -19,7 +24,9 @@ prop_rtLengthParser :: SizeT -> QC.Property prop_rtLengthParser (SizeT x) = - label (show (length e) <> "B") $ + coverTable "Sizes" [("1B", 10), ("2B", 10), ("3B", 10), ("4B", 10)] $ + tabulate "Sizes" [show (length e) <> "B"] $ + checkCoverage $ d e == x where e = encodeLength x @@ -41,22 +48,46 @@ f@A.Fail{} -> assertFailure (show f) (A.Done _ x') -> assertEqual (show s) x x' +allPktTypes :: [String] +allPktTypes = [ + "ConnPkt", + "ConnACKPkt", + "PublishPkt", + "PubACKPkt", + "PubRECPkt", + "PubRELPkt", + "PubCOMPPkt", + "SubscribePkt", + "SubACKPkt", + "UnsubscribePkt", + "UnsubACKPkt", + "PingPkt", + "PongPkt", + "DisconnectPkt", + "AuthPkt" + ] + prop_PacketRT50 :: MQTTPkt -> QC.Property -prop_PacketRT50 p = label (lab p) $ case A.parse (parsePacket Protocol50) (toByteString Protocol50 p) of - A.Fail{} -> False - (A.Done _ r) -> r == p +prop_PacketRT50 p = + coverTable "pkt types" ((,1) <$> allPktTypes) $ + tabulate "pkt types" [lab p] $ + checkCoverage $ + case A.parse (parsePacket Protocol50) (toByteString Protocol50 p) of + A.Fail{} -> False + (A.Done _ r) -> r == p - where lab x = let (s,_) = break (== ' ') . show $ x in s + where lab = takeWhile (/= ' ') . show prop_PacketRT311 :: MQTTPkt -> QC.Property prop_PacketRT311 p = available p ==> - let p' = v311mask p in - label (lab p') $ case A.parse (parsePacket Protocol311) (toByteString Protocol311 p') of - A.Fail{} -> False - (A.Done _ r) -> r == p' + label (lab p) $ + case A.parse (parsePacket Protocol311) (toByteString Protocol311 p') of + A.Fail{} -> False + (A.Done _ r) -> r == p' where - lab x = let (s,_) = break (== ' ') . show $ x in s + lab = takeWhile (/= ' ') . show + p' = v311mask p available (AuthPkt _) = False available _ = True @@ -66,7 +97,7 @@ A.Fail{} -> False (A.Done _ r) -> r == p - where lab x = let (s,_) = break (== ' ') . show $ x in s + where lab = takeWhile (/= ' ') . show prop_SubOptionsRT :: SubOptions -> Bool prop_SubOptionsRT o = case A.parse parseSubOptions (toByteString Protocol50 o) of @@ -93,7 +124,7 @@ prop_TopicMatching :: MatchingTopic -> QC.Property prop_TopicMatching (MatchingTopic (t,ms)) = counterexample (show ms <> " doesn't match " <> show t) $ - all (\m -> match m t) ms + all (`match` t) ms byteRT :: (ByteSize a, Show a, Eq a) => a -> Bool byteRT x = x == (fromByte . toByte) x @@ -106,16 +137,9 @@ instance EqProp Filter where (=-=) = eq instance EqProp Topic where (=-=) = eq -tests :: [TestTree] -tests = [ - localOption (QC.QuickCheckTests 10000) $ testProperty "header length rt (parser)" prop_rtLengthParser, - +test_Spec :: [TestTree] +test_Spec = [ testCase "rt some packets" testPacketRT, - localOption (QC.QuickCheckTests 1000) $ testProperty "rt packets 3.11" prop_PacketRT311, - localOption (QC.QuickCheckTests 1000) $ testProperty "rt packets 5.0" prop_PacketRT50, - 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), @@ -127,6 +151,3 @@ testGroup "topic matching" testTopicMatching, testProperty "arbitrary topic matching" prop_TopicMatching ] - -main :: IO () -main = defaultMain $ testGroup "All Tests" tests