{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| Definition of the B9 monad. It encapsulates logging, very basic command execution profiling, a reader for the "B9.B9Config" and access to the current build id, the current build directory and the artifact to build. This module is used by the _effectful_ functions in this library. -} module B9.B9Monad (B9, run, traceL, dbgL, infoL, errorL, getConfigParser, getConfig, getBuildId, getBuildDate, getBuildDir, getExecEnvType, getSelectedRemoteRepo, getRemoteRepos, getRepoCache, cmd) where import B9.B9Config import B9.ConfigUtils import B9.Repository import Control.Applicative import Control.Exception (bracket) import Control.Monad import Control.Monad.IO.Class import Control.Monad.State 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 ,bsCfgParser :: ConfigParser ,bsCfg :: B9Config ,bsBuildDir :: FilePath ,bsLogFileHandle :: Maybe SysIO.Handle ,bsSelectedRemoteRepo :: Maybe RemoteRepo ,bsRemoteRepos :: [RemoteRepo] ,bsRepoCache :: RepoCache ,bsProf :: [ProfilingEntry] ,bsStartTime :: UTCTime ,bsInheritStdIn :: Bool} data ProfilingEntry = IoActionDuration NominalDiffTime | LogEvent LogLevel String deriving (Eq,Show) run :: ConfigParser -> B9Config -> B9 a -> IO a run cfgParser cfg action = do buildId <- generateBuildId now <- getCurrentTime withBuildDir buildId (withLogFile . run' buildId now) where withLogFile f = maybe (f Nothing) (\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just)) (logFile cfg) withBuildDir buildId = bracket (createBuildDir buildId) removeBuildDir run' buildId now buildDir logFileHandle = do maybe (return ()) setCurrentDirectory (buildDirRoot cfg) -- Check repositories repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (repositoryCache cfg)) let remoteRepos = getConfiguredRemoteRepos cfgParser buildDate = formatTime undefined "%F-%T" now remoteRepos' <- mapM (initRemoteRepo repoCache) remoteRepos let ctx = BuildState buildId buildDate cfgParser cfg buildDir logFileHandle selectedRemoteRepo remoteRepos' repoCache [] now (interactive cfg) 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 -- Write a profiling report when (isJust (profileFile cfg)) $ writeFile (fromJust (profileFile cfg)) (unlines $ show <$> reverse (bsProf ctxOut)) return r createBuildDir 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 = case buildDirRoot cfg of Nothing -> return f Just root' -> do createDirectoryIfMissing True root' root <- canonicalizePath root' return $ root f removeBuildDir buildDir = when (uniqueBuildDirs cfg && not (keepTempDirs cfg)) $ removeDirectoryRecursive buildDir generateBuildId = printf "%08X" <$> (randomIO :: IO Word32) -- Run the action build action wrappedAction = do startTime <- gets bsStartTime r <- action now <- liftIO getCurrentTime let duration = show (now `diffUTCTime` startTime) infoL (printf "DURATION: %s" duration) return r getBuildId :: B9 FilePath getBuildId = gets bsBuildId getBuildDate :: B9 String getBuildDate = gets bsBuildDate getBuildDir :: B9 FilePath getBuildDir = gets bsBuildDir getConfigParser :: B9 ConfigParser getConfigParser = gets bsCfgParser 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 bsRemoteRepos getRepoCache :: B9 RepoCache getRepoCache = gets bsRepoCache -- getDownloader :: B9 Downloader -- getDownloader = gets bsDownloader -- -- -- | Configuration for a tool that retreives arbitrary URL and returns them to -- -- @stdout@. -- data Downloader = -- Downloader {downloaderCmd :: FilePath -- ,downloaderArgsBeforeUrl :: [String] -- ,downloaderUrlArgPrintfFormatString :: [String] -- ,downloaderArgsAfterUrl :: [String]} -- deriving (Read,Show,Eq,Ord,Typeable,Generic) -- -- readContentFromUrl :: String -> B9 B.ByteString -- readContentFromUrl url = do -- return expression 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 () -- TODO if we use 'ClosedStream' we get an error from 'virsh console' -- complaining about a missing controlling tty. Original source line: -- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream) 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 "COMMAND SUCCESS" checkExitCode ec@(ExitFailure e) = do errorL $ printf "COMMAND '%s' FAILED: %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 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