TestInternal.hs

module Buffet.Test.TestInternal
  ( get
  ) where

import qualified Buffet.Assemble.AssembleInternal as AssembleInternal
import qualified Buffet.Ir.Ir as Ir
import qualified Buffet.Test.Configuration as Configuration
import qualified Buffet.Test.ParseArguments as ParseArguments
import qualified Buffet.Test.TestDish as TestDish
import qualified Buffet.Test.TestResult as TestResult
import qualified Buffet.Test.TestSetup as TestSetup
import qualified Buffet.Test.UsingDockerImage as UsingDockerImage
import qualified Buffet.Toolbox.TextTools as TextTools
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import Prelude (Bool(True), IO, ($), (.), (<$>), and, fmap, sequenceA)
import qualified System.IO as IO

type TestResults = Map.Map Ir.Option TestResult.TestResult

get :: Configuration.Configuration -> Ir.Buffet -> IO (Bool, T.Text)
get configuration buffet = do
  arguments <- ParseArguments.get configuration
  let use image = evaluateTestResults <$> sequenceA tests
        where
          tests = Map.mapMaybeWithKey test $ Ir.optionToDish buffet
          test option dish = testSetup <$> Map.lookup option arguments
            where
              testSetup optionValue =
                TestDish.get
                  TestSetup.TestSetup
                    { TestSetup.log = log
                    , TestSetup.image = image
                    , TestSetup.option = option
                    , TestSetup.optionValue = optionValue
                    , TestSetup.dish = dish
                    }
      imageConfiguration =
        UsingDockerImage.Configuration
          { UsingDockerImage.log = log
          , UsingDockerImage.dockerBuild =
              UsingDockerImage.DockerBuild
                { UsingDockerImage.dockerfile = AssembleInternal.get buffet
                , UsingDockerImage.arguments = arguments
                }
          }
  UsingDockerImage.get use imageConfiguration
  where
    log = IO.stderr

evaluateTestResults :: TestResults -> (Bool, T.Text)
evaluateTestResults testResults =
  (and $ fmap isSuccess testResults, TextTools.prettyPrintJson testResults)

isSuccess :: TestResult.TestResult -> Bool
isSuccess = Maybe.fromMaybe True . TestResult.healthCheckPassed