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 :: String -> Spec -> IO ()
run = Config -> String -> Spec -> IO ()
runWith Config
defaultConfig

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

runWith :: Config -> String -> Spec -> IO ()
runWith :: Config -> String -> Spec -> IO ()
runWith Config
config String
name Spec
spec = do
  [String]
args <- IO [String]
getArgs
  Bool
isCircle <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"CIRCLECI"
  let runner :: String -> (Config -> Config) -> Config -> IO Summary
runner = if Bool
isCircle then String -> (Config -> Config) -> Config -> IO Summary
junit else String -> (Config -> Config) -> Config -> IO Summary
hspec

  -- Run unreliable tests first, so local dev errors are reported for reliable
  -- specs at the end
  String -> IO ()
putStrLn String
"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
$ String -> (Config -> Config) -> Config -> IO Summary
runner (String
"unreliable-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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
=<< [String] -> Config -> IO Config
load
    [String]
args
    ((Path -> Bool) -> Config -> Config
skip Path -> Bool
reliableTests Config
config)

  String -> IO ()
putStrLn String
"Running RELIABLE"
  Summary
reliableSummary <- String -> (Config -> Config) -> Config -> IO Summary
runner String
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
=<< [String] -> Config -> IO Config
load [String]
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)

  String -> IO ()
putStrLn String
"Running ISOLATED"
  Summary
isolatedSummary <- String -> (Config -> Config) -> Config -> IO Summary
runner (String
"isolated-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name) Config -> Config
noConcurrency
    (Config -> IO Summary) -> IO Config -> IO Summary
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> Config -> IO Config
load [String]
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 :: [String] -> Config -> IO Config
load = (Config -> [String] -> IO Config)
-> [String] -> Config -> IO Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip Config -> [String] -> IO Config
readConfig
  junit :: String -> (Config -> Config) -> Config -> IO Summary
junit String
filename Config -> Config
changeConfig =
    (Spec
spec Spec -> (String, String) -> Config -> IO Summary
`runJUnitSpec` (String
"/tmp/junit", String
filename)) (Config -> IO Summary)
-> (Config -> Config) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Config
changeConfig
  hspec :: String -> (Config -> Config) -> Config -> IO Summary
hspec String
_ Config -> Config
changeConfig = Spec -> Config -> IO Summary
runSpec Spec
spec (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 :: Maybe Int
configConcurrentJobs = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1 }

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

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 (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)
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running spec with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
jobCores String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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 (f :: * -> *) a. Applicative f => a -> f a
pure Config
config { configConcurrentJobs :: Maybe Int
configConcurrentJobs = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
jobCores Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 }

lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities :: IO (Maybe Int)
lookupTestCapabilities = (String -> Int) -> Maybe String -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
forall a. Read a => String -> a
Unsafe.read (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"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 :: Maybe (Path -> Bool)
configSkipPredicate = (Path -> Bool) -> Maybe (Path -> Bool)
forall a. a -> Maybe a
Just Path -> Bool
predicate }

unreliableTests :: Path -> Bool
unreliableTests :: Path -> Bool
unreliableTests = (String
"UNRELIABLE" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) (String -> Bool) -> (Path -> String) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> String
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 = (String
"ISOLATED" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) (String -> Bool) -> (Path -> String) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> String
forall a b. (a, b) -> b
snd

anys :: [a -> Bool] -> a -> Bool
anys :: [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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a -> Bool
f -> a -> Bool
f a
a) [a -> Bool]
xs