tests/queue/Main.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module Main where
   3
   4 import Control.Concurrent
   5 import Control.Concurrent.STM
   6 import Control.Monad
   7 import Data.Either
   8 import Data.List
   9 import Prelude
  10 import Test.Hspec
  11
  12 import Gargantext.Utils.Jobs.Map
  13 import Gargantext.Utils.Jobs.Monad
  14 import Gargantext.Utils.Jobs.Queue (applyPrios, defaultPrios)
  15 import Gargantext.Utils.Jobs.State
  16
  17 data JobT = A | B deriving (Eq, Ord, Show, Enum, Bounded)
  18
  19 data Counts = Counts { countAs :: Int, countBs :: Int }
  20   deriving (Eq, Show)
  21
  22 inc, dec :: JobT -> Counts -> Counts
  23 inc A cs = cs { countAs = countAs cs + 1 }
  24 inc B cs = cs { countBs = countBs cs + 1 }
  25 dec A cs = cs { countAs = countAs cs - 1 }
  26 dec B cs = cs { countBs = countBs cs - 1 }
  27
  28 jobDuration, initialDelay :: Int
  29 jobDuration = 100000
  30 initialDelay = 20000
  31
  32 testMaxRunners :: IO ()
  33 testMaxRunners = do
  34   -- max runners = 2 with default settings
  35   k <- genSecret
  36   let settings = defaultJobSettings 2 k
  37   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  38   runningJs <- newTVarIO []
  39   let j num _inp _l = do
  40         atomically $ modifyTVar runningJs (\xs -> ("Job #" ++ show num) : xs)
  41         threadDelay jobDuration
  42         atomically $ modifyTVar runningJs (\xs -> filter (/=("Job #" ++ show num)) xs)
  43       jobs = [ j n | n <- [1..4::Int] ]
  44   _jids <- forM jobs $ \f -> pushJob A () f settings st
  45   threadDelay initialDelay
  46   r1 <- readTVarIO runningJs
  47   sort r1 `shouldBe` ["Job #1", "Job #2"]
  48   threadDelay jobDuration
  49   r2 <- readTVarIO runningJs
  50   sort r2 `shouldBe` ["Job #3", "Job #4"]
  51   threadDelay jobDuration
  52   r3 <- readTVarIO runningJs
  53   r3 `shouldBe` []
  54
  55 testPrios :: IO ()
  56 testPrios = do
  57   k <- genSecret
  58   let settings = defaultJobSettings 2 k
  59   st :: JobsState JobT [String] () <- newJobsState settings $
  60     applyPrios [(B, 10)] defaultPrios -- B has higher priority
  61   runningJs <- newTVarIO (Counts 0 0)
  62   let j jobt _inp _l = do
  63         atomically $ modifyTVar runningJs (inc jobt)
  64         threadDelay jobDuration
  65         atomically $ modifyTVar runningJs (dec jobt)
  66       jobs = [ (A, j A)
  67              , (A, j A)
  68              , (B, j B)
  69              , (B, j B)
  70              ]
  71   _jids <- forM jobs $ \(t, f) -> do
  72     pushJob t () f settings st
  73   threadDelay initialDelay
  74   r1 <- readTVarIO runningJs
  75   r1 `shouldBe` (Counts 0 2)
  76   threadDelay jobDuration
  77   r2 <- readTVarIO runningJs
  78   r2 `shouldBe` (Counts 2 0)
  79   threadDelay jobDuration
  80   r3 <- readTVarIO runningJs
  81   r3 `shouldBe` (Counts 0 0)
  82
  83 testExceptions :: IO ()
  84 testExceptions = do
  85   k <- genSecret
  86   let settings = defaultJobSettings 2 k
  87   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  88   jid <- pushJob A ()
  89     (\_inp _log -> readFile "/doesntexist.txt" >>= putStrLn)
  90     settings st
  91   threadDelay initialDelay
  92   mjob <- lookupJob jid (jobsData st)
  93   case mjob of
  94     Nothing ->  error "boo"
  95     Just je ->  case jTask je of
  96       DoneJ _ r -> isLeft r `shouldBe` True
  97       _         -> error "boo2"
  98   return ()
  99
 100 testFairness :: IO ()
 101 testFairness = do
 102   k <- genSecret
 103   let settings = defaultJobSettings 2 k
 104   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
 105   runningJs <- newTVarIO (Counts 0 0)
 106   let j jobt _inp _l = do
 107         atomically $ modifyTVar runningJs (inc jobt)
 108         threadDelay jobDuration
 109         atomically $ modifyTVar runningJs (dec jobt)
 110       jobs = [ (A, j A)
 111              , (A, j A)
 112              , (B, j B)
 113              , (A, j A)
 114              , (A, j A)
 115              ]
 116   _jids <- forM jobs $ \(t, f) -> do
 117     pushJob t () f settings st
 118   threadDelay initialDelay
 119   r1 <- readTVarIO runningJs
 120   r1 `shouldBe` (Counts 2 0)
 121   threadDelay jobDuration
 122   r2 <- readTVarIO runningJs
 123   r2 `shouldBe` (Counts 1 1) -- MOST IMPORTANT CHECK: the B got picked after the
 124                              -- two As, because it was inserted right after them
 125                              -- and has equal priority.
 126   threadDelay jobDuration
 127   r3 <- readTVarIO runningJs
 128   r3 `shouldBe` (Counts 1 0)
 129   threadDelay jobDuration
 130   r4 <- readTVarIO runningJs
 131   r4 `shouldBe` (Counts 0 0)
 132
 133 main :: IO ()
 134 main = hspec $ do
 135   describe "job queue" $ do
 136     it "respects max runners limit" $
 137       testMaxRunners
 138     it "respects priorities" $
 139       testPrios
 140     it "can handle exceptions" $
 141       testExceptions
 142     it "fairly picks equal-priority-but-different-kind jobs" $
 143       testFairness