Main.hs 4.29 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Data.Either
import Data.List
import Prelude
import Test.Hspec

import Gargantext.Utils.Jobs.Map
import Gargantext.Utils.Jobs.Monad
import Gargantext.Utils.Jobs.Queue (applyPrios, defaultPrios)
import Gargantext.Utils.Jobs.State

data JobT = A | B deriving (Eq, Ord, Show, Enum, Bounded)

data Counts = Counts { countAs :: Int, countBs :: Int }
  deriving (Eq, Show)

inc, dec :: JobT -> Counts -> Counts
inc A cs = cs { countAs = countAs cs + 1 }
inc B cs = cs { countBs = countBs cs + 1 }
dec A cs = cs { countAs = countAs cs - 1 }
dec B cs = cs { countBs = countBs cs - 1 }

Alp Mestanogullari's avatar
Alp Mestanogullari committed
28
jobDuration, initialDelay :: Int
29 30
jobDuration = 100000
initialDelay = 20000
Alp Mestanogullari's avatar
Alp Mestanogullari committed
31 32

testMaxRunners :: IO ()
33 34 35
testMaxRunners = do
  -- max runners = 2 with default settings
  k <- genSecret
36
  let settings = defaultJobSettings 2 k
37 38
  st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  runningJs <- newTVarIO []
Alp Mestanogullari's avatar
Alp Mestanogullari committed
39
  let j num _inp _l = do
40
        atomically $ modifyTVar runningJs (\xs -> ("Job #" ++ show num) : xs)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
41
        threadDelay jobDuration
42
        atomically $ modifyTVar runningJs (\xs -> filter (/=("Job #" ++ show num)) xs)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
43 44 45
      jobs = [ j n | n <- [1..4::Int] ]
  _jids <- forM jobs $ \f -> pushJob A () f settings st
  threadDelay initialDelay
46 47
  r1 <- readTVarIO runningJs
  sort r1 `shouldBe` ["Job #1", "Job #2"]
Alp Mestanogullari's avatar
Alp Mestanogullari committed
48
  threadDelay jobDuration
49 50
  r2 <- readTVarIO runningJs
  sort r2 `shouldBe` ["Job #3", "Job #4"]
Alp Mestanogullari's avatar
Alp Mestanogullari committed
51
  threadDelay jobDuration
52 53 54
  r3 <- readTVarIO runningJs
  r3 `shouldBe` []

Alp Mestanogullari's avatar
Alp Mestanogullari committed
55
testPrios :: IO ()
56 57
testPrios = do
  k <- genSecret
58
  let settings = defaultJobSettings 2 k
59 60 61
  st :: JobsState JobT [String] () <- newJobsState settings $
    applyPrios [(B, 10)] defaultPrios -- B has higher priority
  runningJs <- newTVarIO (Counts 0 0)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
62
  let j jobt _inp _l = do
63
        atomically $ modifyTVar runningJs (inc jobt)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
64
        threadDelay jobDuration
65
        atomically $ modifyTVar runningJs (dec jobt)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
66 67 68 69
      jobs = [ (A, j A)
             , (A, j A)
             , (B, j B)
             , (B, j B)
70
             ]
Alp Mestanogullari's avatar
Alp Mestanogullari committed
71
  _jids <- forM jobs $ \(t, f) -> do
72
    pushJob t () f settings st
73
  threadDelay (2*initialDelay)
74 75
  r1 <- readTVarIO runningJs
  r1 `shouldBe` (Counts 0 2)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
76
  threadDelay jobDuration
77 78
  r2 <- readTVarIO runningJs
  r2 `shouldBe` (Counts 2 0)
Alp Mestanogullari's avatar
Alp Mestanogullari committed
79
  threadDelay jobDuration
80 81 82
  r3 <- readTVarIO runningJs
  r3 `shouldBe` (Counts 0 0)

Alp Mestanogullari's avatar
Alp Mestanogullari committed
83
testExceptions :: IO ()
84 85
testExceptions = do
  k <- genSecret
86
  let settings = defaultJobSettings 2 k
87 88 89 90
  st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  jid <- pushJob A ()
    (\_inp _log -> readFile "/doesntexist.txt" >>= putStrLn)
    settings st
Alp Mestanogullari's avatar
Alp Mestanogullari committed
91
  threadDelay initialDelay
92 93 94 95 96 97 98 99
  mjob <- lookupJob jid (jobsData st)
  case mjob of
    Nothing ->  error "boo"
    Just je ->  case jTask je of
      DoneJ _ r -> isLeft r `shouldBe` True
      _         -> error "boo2"
  return ()

Alp Mestanogullari's avatar
Alp Mestanogullari committed
100 101 102
testFairness :: IO ()
testFairness = do
  k <- genSecret
103
  let settings = defaultJobSettings 2 k
Alp Mestanogullari's avatar
Alp Mestanogullari committed
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
  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)
132 133 134 135 136 137 138 139 140 141

main :: IO ()
main = hspec $ do
  describe "job queue" $ do
    it "respects max runners limit" $
      testMaxRunners
    it "respects priorities" $
      testPrios
    it "can handle exceptions" $
      testExceptions
Alp Mestanogullari's avatar
Alp Mestanogullari committed
142 143
    it "fairly picks equal-priority-but-different-kind jobs" $
      testFairness