tests/queue/Main.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module Main where
   3
   4 import Control.Concurrent
   5 import Control.Concurrent.Async
   6 import Control.Concurrent.STM
   7 import Control.Monad
   8 import Data.Either
   9 import Data.List
  10 import Prelude
  11 import Test.Hspec
  12
  13 import Gargantext.Utils.Jobs
  14 import Gargantext.Utils.Jobs.Map
  15 import Gargantext.Utils.Jobs.Monad
  16 import Gargantext.Utils.Jobs.Queue (applyPrios, defaultPrios)
  17 import Gargantext.Utils.Jobs.Settings
  18 import Gargantext.Utils.Jobs.State
  19
  20 data JobT = A | B deriving (Eq, Ord, Show, Enum, Bounded)
  21
  22 data Counts = Counts { countAs :: Int, countBs :: Int }
  23   deriving (Eq, Show)
  24
  25 inc, dec :: JobT -> Counts -> Counts
  26 inc A cs = cs { countAs = countAs cs + 1 }
  27 inc B cs = cs { countBs = countBs cs + 1 }
  28 dec A cs = cs { countAs = countAs cs - 1 }
  29 dec B cs = cs { countBs = countBs cs - 1 }
  30
  31 testMaxRunners = do
  32   -- max runners = 2 with default settings
  33   k <- genSecret
  34   let settings = defaultJobSettings k
  35   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  36   runningJs <- newTVarIO []
  37   let j num _inp l = do
  38         atomically $ modifyTVar runningJs (\xs -> ("Job #" ++ show num) : xs)
  39         -- putStrLn $ "Job #" ++ show num ++ " started"
  40         threadDelay (5 * 1000000) -- 5s
  41         -- putStrLn $ "Job #" ++ show num ++ " done"
  42         atomically $ modifyTVar runningJs (\xs -> filter (/=("Job #" ++ show num)) xs)
  43       jobs = [ (n, j n) | n <- [1..4] ]
  44   jids <- forM jobs $ \(i, f) -> do
  45     -- putStrLn ("Submitting job #" ++ show i)
  46     pushJob A () f settings st
  47   threadDelay 10000 -- 10ms
  48   r1 <- readTVarIO runningJs
  49   -- putStrLn ("Jobs running: " ++ show r1)
  50   sort r1 `shouldBe` ["Job #1", "Job #2"]
  51   threadDelay (6 * 1000000) -- 6s
  52   r2 <- readTVarIO runningJs
  53   sort r2 `shouldBe` ["Job #3", "Job #4"]
  54   threadDelay (5 * 1000000) -- 5s
  55   r3 <- readTVarIO runningJs
  56   r3 `shouldBe` []
  57
  58 testPrios = do
  59   k <- genSecret
  60   let settings = defaultJobSettings k
  61   st :: JobsState JobT [String] () <- newJobsState settings $
  62     applyPrios [(B, 10)] defaultPrios -- B has higher priority
  63   runningJs <- newTVarIO (Counts 0 0)
  64   let j num jobt _inp l = do
  65         atomically $ modifyTVar runningJs (inc jobt)
  66         -- putStrLn $ "Job #" ++ show num ++ " started"
  67         threadDelay (5 * 1000000) -- 5s
  68         -- putStrLn $ "Job #" ++ show num ++ " done"
  69         atomically $ modifyTVar runningJs (dec jobt)
  70       jobs = [ (0, A, j 0 A)
  71              , (1, A, j 1 A)
  72              , (2, B, j 2 B)
  73              , (3, B, j 3 B)
  74              ]
  75   jids <- forM jobs $ \(i, t, f) -> do
  76     -- putStrLn ("Submitting job #" ++ show i)
  77     pushJob t () f settings st
  78   threadDelay 10000 -- 10ms
  79   r1 <- readTVarIO runningJs
  80   r1 `shouldBe` (Counts 0 2)
  81   threadDelay (6 * 1000000) -- 6s
  82   r2 <- readTVarIO runningJs
  83   r2 `shouldBe` (Counts 2 0)
  84   threadDelay (5 * 1000000) -- 5s
  85   r3 <- readTVarIO runningJs
  86   r3 `shouldBe` (Counts 0 0)
  87
  88 testExceptions = do
  89   -- max runners = 2 with default settings
  90   k <- genSecret
  91   let settings = defaultJobSettings k
  92   st :: JobsState JobT [String] () <- newJobsState settings defaultPrios
  93   jid <- pushJob A ()
  94     (\_inp _log -> readFile "/doesntexist.txt" >>= putStrLn)
  95     settings st
  96   threadDelay 50000
  97   mjob <- lookupJob jid (jobsData st)
  98   case mjob of
  99     Nothing ->  error "boo"
 100     Just je ->  case jTask je of
 101       DoneJ _ r -> isLeft r `shouldBe` True
 102       _         -> error "boo2"
 103   return ()
 104
 105
 106 main :: IO ()
 107 main = hspec $ do
 108   describe "job queue" $ do
 109     it "respects max runners limit" $
 110       testMaxRunners
 111     it "respects priorities" $
 112       testPrios
 113     it "can handle exceptions" $
 114       testExceptions