buffet-0.3.0: src/Buffet/Test/TestDish.hs

module Buffet.Test.TestDish
  ( get
  ) where

import qualified Buffet.Ir.Ir as Ir
import qualified Buffet.Test.TestResult as TestResult
import qualified Buffet.Test.TestSetup as TestSetup
import qualified Data.Text as T
import Prelude (Bool, IO, Maybe, ($), (.), (==), pure, traverse)
import qualified System.Exit as Exit
import qualified System.Process.Typed as Process

get :: TestSetup.TestSetup -> IO TestResult.TestResult
get testSetup = do
  healthCheckPassed <- checkHealth testSetup
  pure
    TestResult.TestResult
      { TestResult.optionValue = TestSetup.optionValue testSetup
      , TestResult.healthCheckPassed = healthCheckPassed
      }

checkHealth :: TestSetup.TestSetup -> IO (Maybe Bool)
checkHealth testSetup = traverse run . Ir.healthCheck $ TestSetup.dish testSetup
  where
    run command = do
      exitCode <-
        Process.runProcess .
        Process.setStderr (Process.useHandleOpen log) .
        Process.setStdout (Process.useHandleOpen log) $
        Process.proc
          "docker"
          [ "run"
          , "--rm"
          , T.unpack $ TestSetup.image testSetup
          , "sh"
          , "-c"
          , T.unpack command
          ]
      pure $ exitCode == Exit.ExitSuccess
    log = TestSetup.log testSetup