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 qualified Prelude as Unsafe (read)
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
  )

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