{-# 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.Hashable
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 ( (.|)
, runConduit
)
import qualified Data.Conduit.List as CL
import Data.Foldable
import Data.Conduit.Process
data BuildState =
BuildState {bsBuildId :: String
,bsBuildDate :: String
,bsCfg :: B9Config
,bsBuildDir :: FilePath
,bsLogFileHandle :: Maybe SysIO.Handle
,bsSelectedRemoteRepo :: Maybe RemoteRepo
,bsRepoCache :: RepoCache
,bsProf :: [ProfilingEntry]
,bsStartTime :: UTCTime
,bsInheritStdIn :: Bool}
data ProfilingEntry
= IoActionDuration NominalDiffTime
| LogEvent LogLevel
String
deriving (Eq,Show)
run :: MonadIO m => B9 a -> B9ConfigAction m a
run action = do
cfg <- askRuntimeConfig
liftIO $ do
buildId <- liftIO $ generateBuildId cfg
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 ?~ 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
when (isJust (_profileFile cfg)) $ writeFile
(fromJust (_profileFile cfg))
(unlines $ show <$> reverse (bsProf ctxOut))
return r
createBuildDir cfg buildId = 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 cfg =
let cfgHash = hash (show cfg) in
if _uniqueBuildDirs cfg then
do salt <- randomIO :: IO Word32
return (printf "%08X-%08X" cfgHash salt)
else
return (printf "%08X" cfgHash)
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 (runConduit (cpOut .| outPipe))
*> Concurrently (runConduit (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
modify $ \ctx -> ctx { bsProf = LogEvent level msg : bsProf ctx }
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 = do
start <- B9 $ liftIO getCurrentTime
res <- B9 $ liftIO m
stop <- B9 $ liftIO getCurrentTime
let durMS = IoActionDuration (stop `diffUTCTime` start)
modify $ \ctx -> ctx { bsProf = durMS : bsProf ctx }
return res