module Freckle.App.Test.Hspec.Runner
  ( run
  , runParConfig
  , runWith
  , makeParallelConfig
  ) where

import Freckle.App.Prelude

import Control.Concurrent (getNumCapabilities, setNumCapabilities)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Data.List (isInfixOf)
import System.Environment (getArgs, lookupEnv)
import Test.Hspec (Spec)
import Test.Hspec.JUnit
  ( configWithJUnit
  , setJUnitConfigOutputFile
  , setJUnitConfigSourcePathPrefix
  )
import Test.Hspec.JUnit.Config.Env (envJUnitConfig, envJUnitEnabled)
import Test.Hspec.Runner
  ( Config
  , Path
  , Summary
  , configConcurrentJobs
  , configSkipPredicate
  , defaultConfig
  , evaluateSummary
  , hspecWithResult
  , readConfig
  )
import qualified Prelude as Unsafe (read)

run :: String -> Spec -> IO ()
run :: [Char] -> Spec -> IO ()
run = Config -> [Char] -> Spec -> IO ()
runWith Config
defaultConfig

runParConfig :: String -> Spec -> IO ()
runParConfig :: [Char] -> Spec -> IO ()
runParConfig [Char]
name Spec
spec = do
  Config
config <- Config -> IO Config
makeParallelConfig Config
defaultConfig
  Config -> [Char] -> Spec -> IO ()
runWith Config
config [Char]
name Spec
spec

runWith :: Config -> String -> Spec -> IO ()
runWith :: Config -> [Char] -> Spec -> IO ()
runWith Config
config [Char]
name Spec
spec = do
  [[Char]]
args <- IO [[Char]]
getArgs

  -- Run unreliable tests first, so local dev errors are reported for reliable
  -- specs at the end
  [Char] -> IO ()
putStrLn [Char]
"Running UNRELIABLE tests; failures here should not fail the build"
  IO Summary -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Summary -> IO ()) -> IO Summary -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> (Config -> Config) -> Config -> IO Summary
runner ([Char]
"unreliable-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name) Config -> Config
forall a. a -> a
id
      (Config -> IO Summary) -> IO Config -> IO Summary
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[Char]] -> Config -> IO Config
load
        [[Char]]
args
        ((Path -> Bool) -> Config -> Config
skip Path -> Bool
reliableTests Config
config)

  [Char] -> IO ()
putStrLn [Char]
"Running RELIABLE"
  Summary
reliableSummary <-
    [Char] -> (Config -> Config) -> Config -> IO Summary
runner [Char]
name Config -> Config
forall a. a -> a
id
      (Config -> IO Summary) -> IO Config -> IO Summary
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[Char]] -> Config -> IO Config
load [[Char]]
args ((Path -> Bool) -> Config -> Config
skip ([Path -> Bool] -> Path -> Bool
forall a. [a -> Bool] -> a -> Bool
anys [Path -> Bool
unreliableTests, Path -> Bool
isolatedTests]) Config
config)

  [Char] -> IO ()
putStrLn [Char]
"Running ISOLATED"
  Summary
isolatedSummary <-
    [Char] -> (Config -> Config) -> Config -> IO Summary
runner ([Char]
"isolated-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name) Config -> Config
noConcurrency
      (Config -> IO Summary) -> IO Config -> IO Summary
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[Char]] -> Config -> IO Config
load [[Char]]
args ((Path -> Bool) -> Config -> Config
skip (Bool -> Bool
not (Bool -> Bool) -> (Path -> Bool) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Bool
isolatedTests) Config
config)

  Summary -> IO ()
evaluateSummary (Summary -> IO ()) -> Summary -> IO ()
forall a b. (a -> b) -> a -> b
$ Summary
reliableSummary Summary -> Summary -> Summary
forall a. Semigroup a => a -> a -> a
<> Summary
isolatedSummary
 where
  load :: [[Char]] -> Config -> IO Config
load = (Config -> [[Char]] -> IO Config)
-> [[Char]] -> Config -> IO Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip Config -> [[Char]] -> IO Config
readConfig
  runner :: [Char] -> (Config -> Config) -> Config -> IO Summary
runner [Char]
filename Config -> Config
changeConfig =
    (Spec
spec Spec -> ([Char], [Char]) -> Config -> IO Summary
`runWithJUnit` ([Char]
"/tmp/junit", [Char]
filename)) (Config -> IO Summary)
-> (Config -> Config) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Config
changeConfig
  noConcurrency :: Config -> Config
noConcurrency Config
x = Config
x {configConcurrentJobs = Just 1}

runWithJUnit :: Spec -> (FilePath, String) -> Config -> IO Summary
runWithJUnit :: Spec -> ([Char], [Char]) -> Config -> IO Summary
runWithJUnit Spec
spec ([Char]
path, [Char]
name) Config
config = do
  Bool
junitEnabled <- IO Bool
envJUnitEnabled
  JUnitConfig
baseJUnitConfig <- IO JUnitConfig
envJUnitConfig
  let modify :: Config -> Config
modify = if Bool
junitEnabled then JUnitConfig -> Config -> Config
configWithJUnit (JUnitConfig -> Config -> Config)
-> JUnitConfig -> Config -> Config
forall a b. (a -> b) -> a -> b
$ JUnitConfig -> JUnitConfig
withOverride JUnitConfig
baseJUnitConfig else Config -> Config
forall a. a -> a
id
  Spec
spec Spec -> Config -> IO Summary
`runSpec` Config -> Config
modify Config
config
 where
  runSpec :: Spec -> Config -> IO Summary
runSpec = (Config -> Spec -> IO Summary) -> Spec -> Config -> IO Summary
forall a b c. (a -> b -> c) -> b -> a -> c
flip Config -> Spec -> IO Summary
hspecWithResult
  filePath :: [Char]
filePath = [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/test_results.xml"
  withOverride :: JUnitConfig -> JUnitConfig
withOverride =
    [Char] -> JUnitConfig -> JUnitConfig
setJUnitConfigSourcePathPrefix [Char]
name (JUnitConfig -> JUnitConfig)
-> (JUnitConfig -> JUnitConfig) -> JUnitConfig -> JUnitConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> JUnitConfig -> JUnitConfig
setJUnitConfigOutputFile [Char]
filePath

makeParallelConfig :: Config -> IO Config
makeParallelConfig :: Config -> IO Config
makeParallelConfig Config
config = do
  Int
jobCores <-
    Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1
      (Maybe Int -> Int) -> IO (Maybe Int) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT IO Int -> IO (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
        (IO (Maybe Int) -> MaybeT IO Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Int)
lookupTestCapabilities MaybeT IO Int -> MaybeT IO Int -> MaybeT IO Int
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO (Maybe Int) -> MaybeT IO Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Int)
lookupHostCapabilities)
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Running spec with " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
jobCores [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" cores"
  Int -> IO ()
setNumCapabilities Int
jobCores
  -- Api specs are IO bound, having more jobs than cores allows for more
  -- cooperative IO from green thread interleaving.
  Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config {configConcurrentJobs = Just $ jobCores * 4}

lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities = ([Char] -> Int) -> Maybe [Char] -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Int
forall a. Read a => [Char] -> a
Unsafe.read (Maybe [Char] -> Maybe Int) -> IO (Maybe [Char]) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TEST_CAPABILITIES"

lookupHostCapabilities :: IO (Maybe Int)
lookupHostCapabilities :: IO (Maybe Int)
lookupHostCapabilities = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
reduceCapabilities (Int -> Maybe Int) -> IO Int -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getNumCapabilities

-- Reduce capabilities to avoid contention with postgres
reduceCapabilities :: Int -> Int
reduceCapabilities :: Int -> Int
reduceCapabilities = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)

skip :: (Path -> Bool) -> Config -> Config
skip :: (Path -> Bool) -> Config -> Config
skip Path -> Bool
predicate Config
config = Config
config {configSkipPredicate = Just predicate}

unreliableTests :: Path -> Bool
unreliableTests :: Path -> Bool
unreliableTests = ([Char]
"UNRELIABLE" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) ([Char] -> Bool) -> (Path -> [Char]) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [Char]
forall a b. (a, b) -> b
snd

reliableTests :: Path -> Bool
reliableTests :: Path -> Bool
reliableTests = Bool -> Bool
not (Bool -> Bool) -> (Path -> Bool) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Bool
unreliableTests

isolatedTests :: Path -> Bool
isolatedTests :: Path -> Bool
isolatedTests = ([Char]
"ISOLATED" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) ([Char] -> Bool) -> (Path -> [Char]) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [Char]
forall a b. (a, b) -> b
snd

anys :: [a -> Bool] -> a -> Bool
anys :: forall a. [a -> Bool] -> a -> Bool
anys [a -> Bool]
xs a
a = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((a -> Bool) -> Bool) -> [a -> Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a -> Bool
f -> a -> Bool
f a
a) [a -> Bool]
xs