{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module B9.B9Monad
(B9, run, traceL, dbgL, infoL, errorL, errorExitL, getConfig,
getBuildId, getBuildDate, getBuildDir, getExecEnvType,
getSelectedRemoteRepo, getRemoteRepos, getRepoCache, cmd)
where
import B9.B9Config
import B9.Repository
import Control.Applicative
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Lens((&), (.~), (^.), (%~))
import qualified Data.ByteString.Char8 as B
import Data.Functor ()
import Data.Maybe
import Data.Time.Clock
import Data.Time.Format
import Data.Word (Word32)
import System.Directory
import System.Exit
import System.FilePath
import System.Random (randomIO)
import qualified System.IO as SysIO
import Text.Printf
import Control.Concurrent.Async (Concurrently(..))
import Data.Conduit (($$))
import qualified Data.Conduit.List as CL
import Data.Conduit.Process
data BuildState =
BuildState {bsBuildId :: String
,bsBuildDate :: String
,bsCfg :: B9Config
,bsBuildDir :: FilePath
,bsLogFileHandle :: Maybe SysIO.Handle
,bsSelectedRemoteRepo :: Maybe RemoteRepo
,bsRepoCache :: RepoCache
,bsStartTime :: UTCTime
,bsInheritStdIn :: Bool}
run :: MonadIO m => B9 a -> B9ConfigAction m a
run action = do
cfg <- askRuntimeConfig
liftIO $ do
buildId <- liftIO $ generateBuildId
now <- liftIO $ getCurrentTime
liftIO
$ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)
where
resolveBuildDirRoot cfg = case _buildDirRoot cfg of
Nothing -> getCurrentDirectory >>= canonicalizePath
Just root' -> do
createDirectoryIfMissing True root'
canonicalizePath root'
withLogFile cfg f = maybe
(f Nothing)
(\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just))
(_logFile cfg)
withBuildDir cfg buildId =
bracket (createBuildDir cfg buildId) (removeBuildDir cfg)
runImpl cfg buildId now buildDir logFileHandle = do
repoCache <- initRepoCache
(fromMaybe defaultRepositoryCache (_repositoryCache cfg))
let buildDate = formatTime undefined "%F-%T" now
remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)
buildDirRootAbs <- resolveBuildDirRoot cfg
let finalCfg =
( cfg
& remoteRepos
.~ remoteRepos'
& buildDirRoot
.~ Just buildDirRootAbs
& envVars
%~ mappend [("buildDirRoot", buildDirRootAbs)]
)
let
ctx = BuildState buildId
buildDate
finalCfg
buildDir
logFileHandle
selectedRemoteRepo
repoCache
now
(_interactive finalCfg)
selectedRemoteRepo = do
sel <- _repository cfg
lookupRemoteRepo remoteRepos' sel <|> error
( printf
"selected remote repo '%s' not configured, valid remote repos are: '%s'"
sel
(show remoteRepos')
)
(r, ctxOut) <- runStateT (runB9 wrappedAction) ctx
return r
createBuildDir cfg buildId = if _uniqueBuildDirs cfg
then do
let subDir = "BUILD-" ++ buildId
buildDir <- resolveBuildDir subDir
createDirectory buildDir
canonicalizePath buildDir
else do
let subDir = "BUILD-" ++ buildId
buildDir <- resolveBuildDir subDir
createDirectoryIfMissing True buildDir
canonicalizePath buildDir
where
resolveBuildDir f = do
root <- resolveBuildDirRoot cfg
return $ root </> f
removeBuildDir cfg buildDir =
when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))
$ removeDirectoryRecursive buildDir
generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)
wrappedAction = do
b9cfg <- getConfig
traverse (traceL . printf "Root Build Directory: %s")
(b9cfg ^. buildDirRoot)
startTime <- gets bsStartTime
r <- action
now <- liftIO getCurrentTime
let duration = show (now `diffUTCTime` startTime)
infoL (printf "DURATION: %s" duration)
return r
getBuildId :: B9 String
getBuildId = gets bsBuildId
getBuildDate :: B9 String
getBuildDate = gets bsBuildDate
getBuildDir :: B9 FilePath
getBuildDir = gets bsBuildDir
getConfig :: B9 B9Config
getConfig = gets bsCfg
getExecEnvType :: B9 ExecEnvType
getExecEnvType = gets (_execEnvType . bsCfg)
getSelectedRemoteRepo :: B9 (Maybe RemoteRepo)
getSelectedRemoteRepo = gets bsSelectedRemoteRepo
getRemoteRepos :: B9 [RemoteRepo]
getRemoteRepos = gets (_remoteRepos . bsCfg)
getRepoCache :: B9 RepoCache
getRepoCache = gets bsRepoCache
cmd :: String -> B9 ()
cmd str = do
inheritStdIn <- gets bsInheritStdIn
if inheritStdIn then interactiveCmd str else nonInteractiveCmd str
interactiveCmd :: String -> B9 ()
interactiveCmd str = void (cmdWithStdIn True str :: B9 Inherited)
nonInteractiveCmd :: String -> B9 ()
nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 Inherited)
cmdWithStdIn :: (InputSource stdin) => Bool -> String -> B9 stdin
cmdWithStdIn toStdOut cmdStr = do
traceL $ "COMMAND: " ++ cmdStr
cmdLogger <- getCmdLogger
let outPipe = if toStdOut then CL.mapM_ B.putStr else cmdLogger LogTrace
(cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)
e <-
liftIO
$ runConcurrently
$ Concurrently (cpOut $$ outPipe)
*> Concurrently (cpErr $$ cmdLogger LogInfo)
*> Concurrently (waitForStreamingProcess cph)
checkExitCode e
return cpIn
where
getCmdLogger = do
lv <- gets $ _verbosity . bsCfg
lfh <- gets bsLogFileHandle
return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack)
checkExitCode ExitSuccess =
traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr
checkExitCode ec@(ExitFailure e) = do
errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e
liftIO $ exitWith ec
traceL :: String -> B9 ()
traceL = b9Log LogTrace
dbgL :: String -> B9 ()
dbgL = b9Log LogDebug
infoL :: String -> B9 ()
infoL = b9Log LogInfo
errorL :: String -> B9 ()
errorL = b9Log LogError
errorExitL :: String -> B9 a
errorExitL e = b9Log LogError e >> fail e
b9Log :: LogLevel -> String -> B9 ()
b9Log level msg = do
lv <- gets $ _verbosity . bsCfg
lfh <- gets bsLogFileHandle
B9 $ liftIO $ logImpl lv lfh level msg
logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()
logImpl minLevel mh level msg = do
lm <- formatLogMsg level msg
when (isJust minLevel && level >= fromJust minLevel) (putStr lm)
when (isJust mh) $ do
SysIO.hPutStr (fromJust mh) lm
SysIO.hFlush (fromJust mh)
formatLogMsg :: LogLevel -> String -> IO String
formatLogMsg l msg = do
utct <- getCurrentTime
let time = formatTime defaultTimeLocale "%H:%M:%S" utct
return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg
printLevel :: LogLevel -> String
printLevel l = case l of
LogNothing -> "NOTHING"
LogError -> " ERROR "
LogInfo -> " INFO "
LogDebug -> " DEBUG "
LogTrace -> " TRACE "
newtype B9 a =
B9 {runB9 :: StateT BuildState IO a}
deriving (Functor,Applicative,Monad,MonadState BuildState)
instance MonadIO B9 where
liftIO m = B9 $ liftIO m