Internal.hs

module Craft.Run.Internal where

import           Conduit                 as C
import           Control.Monad.Logger    (LoggingT, askLoggerIO, logDebugNS,
                                          runLoggingT)
import qualified Control.Monad.Trans     as Trans
import qualified Data.Conduit.List       as CL
import           Data.Conduit.Process    (sourceProcessWithStreams)
import           Data.Conduit.Text       as CT
import           Data.Monoid             ((<>))
import qualified Data.Text               as T
import           System.Exit
import           System.Process
import qualified System.Process.ListLike as SPLL

import           Craft.Types


isSuccessCode :: ExitCode -> Bool
isSuccessCode ExitSuccess     = True
isSuccessCode (ExitFailure _) = False


execProc :: CreateProcess -> LoggingT IO ExecResult
execProc p = do
  logDebugNS "exec|process" $ T.pack $ showProc p
  (exit', stdoutRaw, stderrRaw) <- Trans.lift $ SPLL.readCreateProcessWithExitCode p "" {- stdin -}
  let stdout' = trimNL stdoutRaw
  let stderr' = trimNL stderrRaw
  return $ case exit' of
    ExitSuccess      -> ExecSucc $ SuccResult stdout' stderr' p
    ExitFailure code -> ExecFail $ FailResult code stdout' stderr' p


execProc_ :: String -> CreateProcess -> LoggingT IO ()
execProc_ src p = do
  let p' = p { std_in  = CreatePipe
             , std_out = CreatePipe
             , std_err = CreatePipe
             }
  logDebugNS "exec_|process" $ T.pack $ showProc p

  logger <- askLoggerIO
  let src' = "exec_|" <> T.pack src
      srcOut = src' <> "|stdout"
      srcErr = src' <> "|stderr"

  (ec, _, _) <- Trans.lift $ sourceProcessWithStreams
                               p'
                               (CL.sourceNull)
                               (pipeConsumer logger srcOut)
                               (pipeConsumer logger srcErr)
  case ec of
    ExitFailure n -> $craftError $ "exec_ `" ++ src ++ "` failed with code: " ++ show n
    ExitSuccess   -> return ()
 where
   pipeConsumer logger s = decodeUtf8C =$= CT.lines =$ awaitForever (\txt ->
     (`runLoggingT` logger) (logDebugNS s txt))


-- | Remove a single trailing newline character from the end of the String
trimNL :: String -> String
trimNL = reverse . rmNL . reverse
 where
  rmNL []        = []
  rmNL ('\n':xs) = rmCR xs
  rmNL xs        = xs
  rmCR []        = []
  rmCR ('\r':xs) = xs
  rmCR xs        = xs