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
  , defaultJUnitConfig
  , setJUnitConfigOutputFile
  )
import Test.Hspec.Runner
  ( Config
  , Path
  , Summary
  , configConcurrentJobs
  , configSkipPredicate
  , defaultConfig
  , evaluateSummary
  , readConfig
  , runSpec
  )
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
  Bool
isCircle <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"CIRCLECI"
  let runner :: [Char] -> (Config -> Config) -> Config -> IO Summary
runner = if Bool
isCircle then [Char] -> (Config -> Config) -> Config -> IO Summary
junit else [Char] -> (Config -> Config) -> Config -> IO Summary
hspec

  -- 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"
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    [Char] -> (Config -> Config) -> Config -> IO Summary
runner ([Char]
"unreliable-" forall a. Semigroup a => a -> a -> a
<> [Char]
name) forall a. a -> a
id
      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 forall a. a -> a
id
      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 (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-" forall a. Semigroup a => a -> a -> a
<> [Char]
name) Config -> Config
noConcurrency
      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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Bool
isolatedTests) Config
config)

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

runJUnitSpec :: Spec -> (FilePath, String) -> Config -> IO Summary
runJUnitSpec :: Spec -> ([Char], [Char]) -> Config -> IO Summary
runJUnitSpec Spec
spec ([Char]
path, [Char]
name) Config
config =
  Spec
spec Spec -> Config -> IO Summary
`runSpec` JUnitConfig -> Config -> Config
configWithJUnit JUnitConfig
junitConfig Config
config
 where
  filePath :: [Char]
filePath = [Char]
path forall a. Semigroup a => a -> a -> a
<> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
"/test_results.xml"
  junitConfig :: JUnitConfig
junitConfig =
    [Char] -> JUnitConfig -> JUnitConfig
setJUnitConfigOutputFile [Char]
filePath forall a b. (a -> b) -> a -> b
$ Text -> JUnitConfig
defaultJUnitConfig forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
name

makeParallelConfig :: Config -> IO Config
makeParallelConfig :: Config -> IO Config
makeParallelConfig Config
config = do
  Int
jobCores <-
    forall a. a -> Maybe a -> a
fromMaybe Int
1
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
        (forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Int)
lookupTestCapabilities forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Int)
lookupHostCapabilities)
  [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Running spec with " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
jobCores 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.
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config {configConcurrentJobs :: Maybe Int
configConcurrentJobs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
jobCores forall a. Num a => a -> a -> a
* Int
4}

lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Read a => [Char] -> a
Unsafe.read 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 = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
reduceCapabilities 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 = forall a. Ord a => a -> a -> a
max Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 :: Maybe (Path -> Bool)
configSkipPredicate = forall a. a -> Maybe a
Just Path -> Bool
predicate}

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

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

isolatedTests :: Path -> Bool
isolatedTests :: Path -> Bool
isolatedTests = ([Char]
"ISOLATED" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
or 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