bricoleur/src/Bricoleur/Commands/Test.hs

{-# LANGUAGE OverloadedStrings #-}

module Bricoleur.Commands.Test (runTest) where

import           Control.Monad (forM_)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified GHC.IO.Exception as Exn
import           System.FilePath ((</>))
import qualified System.FilePath as Sys
import qualified System.Process as Sys

import Bricoleur.Opts
import Bricoleur.Config
import Bricoleur.Utils


runTest :: Config -> Options -> IO ()
runTest conf opts = do
  let root = Sys.takeDirectory (optFile opts)
  cDebug ("running tests for " % shown) (confDocument conf)
  forM_ (confSources conf) $ \ samp -> do
    cDebug ("- running test for " % stext) (sourceName samp)
    runCommand root samp


runCommand :: FilePath -> Source -> IO ()
runCommand root src = do
  forM_ (sourceCommands src) $ \ln -> do
    let dir = root </> sourceDir src
    cDebug ("  $ " % string % " (in '" % string % "')") ln dir
    (outH, inH) <- Sys.createPipe
    let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src)
                                 , Sys.std_out = Sys.UseHandle inH
                                 , Sys.std_err = Sys.UseHandle inH
                                 }
    (_, _, _, p) <- Sys.createProcess process
    bufOutput <- B.hGetContents outH
    code <- Sys.waitForProcess p
    case code of
      Exn.ExitSuccess -> return ()
      Exn.ExitFailure n -> do
        let idtext = map (B.append "  - ") (B.lines bufOutput)
        cError ("\nCommand '" % string %
                "' exited with error (" % shown %
                ")") ln n
        mapM_ bsErrorLn idtext