wip

hbs2-tests/test/TestSKey.hs

@@ -2,12 +2,13 @@ module Main where
 
 import HBS2.Net.Proto.Sessions
 import HBS2.Hash
+import HBS2.Clock
 
 
 import Control.Monad
 import Control.Concurrent.STM
 import Data.ByteString (ByteString)
-import Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 qualified as B
 import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.Map qualified as Map
@@ -16,6 +17,7 @@ import System.Random.MWC
 import System.TimeIt
 import Test.QuickCheck
 import Data.HashMap.Strict qualified as HashMap
+import Control.Concurrent.Async
 
 main :: IO ()
 main = do
@@ -27,79 +29,85 @@ main = do
           bytes <- replicateM 256 $ uniformM g :: IO [Char]
           pure $ hashObject @HbSync (B.pack bytes)
 
-  timeItNamed "Cache (Hash HbSync)" $ do
+  race ( pause ( 3 :: Timeout 'Seconds ) >> putStrLn "Cache (Hash HbSync) failed") $ do
 
-    replicateM_ 1000 $ do
+    timeItNamed "Cache (Hash HbSync)" $ do
 
-      m1 <- Cache.newCache Nothing :: IO (Cache (Hash HbSync) ())
+      replicateM_ 1000 $ do
 
-      forM_ ss $ \key -> Cache.insert m1 key ()
-      forM_ ss $ \key -> Cache.lookup' m1 key
+        m1 <- Cache.newCache Nothing :: IO (Cache (Hash HbSync) ())
+
+        forM_ ss $ \key -> Cache.insert m1 key ()
+        forM_ ss $ \key -> Cache.lookup' m1 key
+
+  race ( pause ( 3 :: Timeout 'Seconds ) >> putStrLn "Cache (SKey) failed") $ do
+
+    timeItNamed "Cache (SKey)" $ do
+
+      let keys = fmap newSKey ss
+
+      replicateM_ 1000 $ do
+
+        m1 <- Cache.newCache Nothing
+
+        forM_ keys $ \key -> Cache.insert m1 key ()
+        forM_ keys $ \key -> Cache.lookup' m1 key
+
+  race ( pause ( 3 :: Timeout 'Seconds ) >> putStrLn "HashMap (Hash HbSync) failed") $ do
+
+    timeItNamed "HashMap (Hash HbSync)" $ do
+
+      let keys = ss
+
+      replicateM_ 1000 $ do
+
+        m1 <- newTVarIO mempty -- .newCache Nothing
+
+        forM_ keys $ \key -> do
+          atomically $ modifyTVar' m1 (HashMap.insert key ())
+          -- Cache.insert m1 key ()
+
+        forM_ keys $ \key -> do
+          m <- readTVarIO m1
+          let !x = HashMap.lookup key m
+          pure ()
+
+  race ( pause ( 3 :: Timeout 'Seconds ) >> putStrLn "HashMap (SKey) failed") $ do
+    timeItNamed "HashMap (Skey)" $ do
+
+      let keys = fmap newSKey ss
+
+      replicateM_ 1000 $ do
+
+        m1 <- newTVarIO mempty -- .newCache Nothing
+
+        forM_ keys $ \key -> do
+          atomically $ modifyTVar' m1 (HashMap.insert key ())
+          -- Cache.insert m1 key ()
+
+        forM_ keys $ \key -> do
+          m <- readTVarIO m1
+          let !x = HashMap.lookup key m
+          pure ()
 
 
-  timeItNamed "Cache (SKey)" $ do
+  race ( pause ( 3 :: Timeout 'Seconds ) >> putStrLn "Map (Hash HbSync) failed") $ do
+    timeItNamed "Map (Hash HbSync)" $ do
 
-    let keys = fmap newSKey ss
+      let keys = ss
 
-    replicateM_ 1000 $ do
+      replicateM_ 1000 $ do
 
-      m1 <- Cache.newCache Nothing
+        m1 <- newTVarIO mempty -- .newCache Nothing
 
-      forM_ keys $ \key -> Cache.insert m1 key ()
-      forM_ keys $ \key -> Cache.lookup' m1 key
+        forM_ keys $ \key -> do
+          atomically $ modifyTVar' m1 (Map.insert key ())
+          -- Cache.insert m1 key ()
 
-
-  timeItNamed "HashMap (Hash HbSync)" $ do
-
-    let keys = ss
-
-    replicateM_ 1000 $ do
-
-      m1 <- newTVarIO mempty -- .newCache Nothing
-
-      forM_ keys $ \key -> do
-        atomically $ modifyTVar' m1 (HashMap.insert key ())
-        -- Cache.insert m1 key ()
-
-      forM_ keys $ \key -> do
-        m <- readTVarIO m1
-        let !x = HashMap.lookup key m
-        pure ()
-
-  timeItNamed "HashMap (Skey)" $ do
-
-    let keys = fmap newSKey ss
-
-    replicateM_ 1000 $ do
-
-      m1 <- newTVarIO mempty -- .newCache Nothing
-
-      forM_ keys $ \key -> do
-        atomically $ modifyTVar' m1 (HashMap.insert key ())
-        -- Cache.insert m1 key ()
-
-      forM_ keys $ \key -> do
-        m <- readTVarIO m1
-        let !x = HashMap.lookup key m
-        pure ()
-
-
-  timeItNamed "Map (Hash HbSync)" $ do
-
-    let keys = ss
-
-    replicateM_ 1000 $ do
-
-      m1 <- newTVarIO mempty -- .newCache Nothing
-
-      forM_ keys $ \key -> do
-        atomically $ modifyTVar' m1 (Map.insert key ())
-        -- Cache.insert m1 key ()
-
-      forM_ keys $ \key -> do
-        m <- readTVarIO m1
-        let !x = Map.lookup key m
-        pure ()
+        forM_ keys $ \key -> do
+          m <- readTVarIO m1
+          let !x = Map.lookup key m
+          pure ()
 
 
   pure ()