net-mqtt 0.8.5.0 → 0.8.6.0

raw patch · 9 files changed

+429/−43 lines, 9 filesdep +lensdep +monad-loopsdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, monad-loops, mtl, tasty-discover, time

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• net-mqtt.cabal +18/−2
• src/Data/Map/Strict/Decaying.hs +66/−0
• src/Data/Map/Strict/Expiring.hs +107/−0
• src/Network/MQTT/Client.hs +13/−16
• test/DecayingSpec.hs +50/−0
• test/ExpiringSpec.hs +122/−0
• test/Main.hs +1/−0
• test/Spec.hs +46/−25

@@ -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

@@ -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 <https://github.com/dustin/mqtt-hs#readme> 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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}

@@ -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