add fairness test

tests/queue/Main.hs

@@ -2,7 +2,6 @@
 module Main where
 
 import Control.Concurrent
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Data.Either
@@ -10,11 +9,9 @@ import Data.List
 import Prelude
 import Test.Hspec
 
-import Gargantext.Utils.Jobs
 import Gargantext.Utils.Jobs.Map
 import Gargantext.Utils.Jobs.Monad
 import Gargantext.Utils.Jobs.Queue (applyPrios, defaultPrios)
-import Gargantext.Utils.Jobs.Settings
 import Gargantext.Utils.Jobs.State
 
 data JobT = A | B deriving (Eq, Ord, Show, Enum, Bounded)
@@ -28,72 +25,70 @@ inc B cs = cs { countBs = countBs cs + 1 }
 dec A cs = cs { countAs = countAs cs - 1 }
 dec B cs = cs { countBs = countBs cs - 1 }
 
+jobDuration, initialDelay :: Int
+jobDuration = 100000 -- 100ms
+initialDelay = 30000 -- 10ms
+
+testMaxRunners :: IO ()
 testMaxRunners = do
   -- max runners = 2 with default settings
   k <- genSecret
   let settings = defaultJobSettings 2 k
   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
   runningJs <- newTVarIO []
-  let j num _inp l = do
+  let j num _inp _l = do
         atomically $ modifyTVar runningJs (\xs -> ("Job #" ++ show num) : xs)
-        -- putStrLn $ "Job #" ++ show num ++ " started"
-        threadDelay (5 * 1000000) -- 5s
-        -- putStrLn $ "Job #" ++ show num ++ " done"
+        threadDelay jobDuration
         atomically $ modifyTVar runningJs (\xs -> filter (/=("Job #" ++ show num)) xs)
-      jobs = [ (n, j n) | n <- [1..4] ]
-  jids <- forM jobs $ \(i, f) -> do
-    -- putStrLn ("Submitting job #" ++ show i)
-    pushJob A () f settings st
-  threadDelay 10000 -- 10ms
+      jobs = [ j n | n <- [1..4::Int] ]
+  _jids <- forM jobs $ \f -> pushJob A () f settings st
+  threadDelay initialDelay
   r1 <- readTVarIO runningJs
-  -- putStrLn ("Jobs running: " ++ show r1)
   sort r1 `shouldBe` ["Job #1", "Job #2"]
-  threadDelay (6 * 1000000) -- 6s
+  threadDelay jobDuration
   r2 <- readTVarIO runningJs
   sort r2 `shouldBe` ["Job #3", "Job #4"]
-  threadDelay (5 * 1000000) -- 5s
+  threadDelay jobDuration
   r3 <- readTVarIO runningJs
   r3 `shouldBe` []
 
+testPrios :: IO ()
 testPrios = do
   k <- genSecret
   let settings = defaultJobSettings 2 k
   st :: JobsState JobT [String] () <- newJobsState settings $
     applyPrios [(B, 10)] defaultPrios -- B has higher priority
   runningJs <- newTVarIO (Counts 0 0)
-  let j num jobt _inp l = do
+  let j jobt _inp _l = do
         atomically $ modifyTVar runningJs (inc jobt)
-        -- putStrLn $ "Job #" ++ show num ++ " started"
-        threadDelay (5 * 1000000) -- 5s
-        -- putStrLn $ "Job #" ++ show num ++ " done"
+        threadDelay jobDuration
         atomically $ modifyTVar runningJs (dec jobt)
-      jobs = [ (0, A, j 0 A)
-             , (1, A, j 1 A)
-             , (2, B, j 2 B)
-             , (3, B, j 3 B)
+      jobs = [ (A, j A)
+             , (A, j A)
+             , (B, j B)
+             , (B, j B)
              ]
-  jids <- forM jobs $ \(i, t, f) -> do
-    -- putStrLn ("Submitting job #" ++ show i)
+  _jids <- forM jobs $ \(t, f) -> do
     pushJob t () f settings st
-  threadDelay 10000 -- 10ms
+  threadDelay initialDelay
   r1 <- readTVarIO runningJs
   r1 `shouldBe` (Counts 0 2)
-  threadDelay (6 * 1000000) -- 6s
+  threadDelay jobDuration
   r2 <- readTVarIO runningJs
   r2 `shouldBe` (Counts 2 0)
-  threadDelay (5 * 1000000) -- 5s
+  threadDelay jobDuration
   r3 <- readTVarIO runningJs
   r3 `shouldBe` (Counts 0 0)
 
+testExceptions :: IO ()
 testExceptions = do
-  -- max runners = 2 with default settings
   k <- genSecret
   let settings = defaultJobSettings 2 k
   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
   jid <- pushJob A ()
     (\_inp _log -> readFile "/doesntexist.txt" >>= putStrLn)
     settings st
-  threadDelay 50000
+  threadDelay initialDelay
   mjob <- lookupJob jid (jobsData st)
   case mjob of
     Nothing ->  error "boo"
@@ -102,6 +97,38 @@ testExceptions = do
       _         -> error "boo2"
   return ()
 
+testFairness :: IO ()
+testFairness = do
+  k <- genSecret
+  let settings = defaultJobSettings k
+  st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
+  runningJs <- newTVarIO (Counts 0 0)
+  let j jobt _inp _l = do
+        atomically $ modifyTVar runningJs (inc jobt)
+        threadDelay jobDuration
+        atomically $ modifyTVar runningJs (dec jobt)
+      jobs = [ (A, j A)
+             , (A, j A)
+             , (B, j B)
+             , (A, j A)
+             , (A, j A)
+             ]
+  _jids <- forM jobs $ \(t, f) -> do
+    pushJob t () f settings st
+  threadDelay initialDelay
+  r1 <- readTVarIO runningJs
+  r1 `shouldBe` (Counts 2 0)
+  threadDelay jobDuration
+  r2 <- readTVarIO runningJs
+  r2 `shouldBe` (Counts 1 1) -- MOST IMPORTANT CHECK: the B got picked after the
+                             -- two As, because it was inserted right after them
+                             -- and has equal priority.
+  threadDelay jobDuration
+  r3 <- readTVarIO runningJs
+  r3 `shouldBe` (Counts 1 0)
+  threadDelay jobDuration
+  r4 <- readTVarIO runningJs
+  r4 `shouldBe` (Counts 0 0)
 
 main :: IO ()
 main = hspec $ do
@@ -112,3 +139,5 @@ main = hspec $ do
       testPrios
     it "can handle exceptions" $
       testExceptions
+    it "fairly picks equal-priority-but-different-kind jobs" $
+      testFairness