diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,5 +1,5 @@ name: b9 -version: 0.5.18 +version: 0.5.19 synopsis: A tool and library for building virtual machine images. diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -5,7 +5,6 @@ import Control.Exception import Data.Function (on) -import Data.List (groupBy) import Data.Maybe import Data.Version import Paths_b9 diff --git a/src/lib/B9.hs b/src/lib/B9.hs --- a/src/lib/B9.hs +++ b/src/lib/B9.hs @@ -25,26 +25,7 @@ import Text.Printf as X (printf) import Data.Version as X import B9.Builder as X - -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Data.Monoid -import Data.List -import Data.Maybe -import Text.Show.Pretty (ppShow) -import System.Exit ( exitWith - , ExitCode (..) ) -import System.FilePath ( takeDirectory - , takeFileName - , replaceExtension - , () - , (<.>) ) -import Text.Printf ( printf ) import Paths_b9 (version) -import Data.Version - -import B9.Builder import qualified B9.LibVirtLXC as LibVirtLXC -- | Merge 'existingConfig' with the configuration from the main b9 config diff --git a/src/lib/B9/ArtifactGeneratorImpl.hs b/src/lib/B9/ArtifactGeneratorImpl.hs --- a/src/lib/B9/ArtifactGeneratorImpl.hs +++ b/src/lib/B9/ArtifactGeneratorImpl.hs @@ -23,7 +23,6 @@ import Data.List import Data.Function import Control.Arrow -import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Writer diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs --- a/src/lib/B9/B9Monad.hs +++ b/src/lib/B9/B9Monad.hs @@ -1,144 +1,140 @@ {-# 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 +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 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 Text.Printf +import Control.Concurrent.Async (Concurrently(..)) +import Data.Conduit (($$)) import qualified Data.Conduit.List as CL -import Data.Conduit.Process +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 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) +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 - +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 @@ -167,12 +163,28 @@ 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 +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) @@ -183,32 +195,32 @@ -- 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 +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 @@ -223,44 +235,47 @@ 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 +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) +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 +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 " + LogError -> " ERROR " + LogInfo -> " INFO " + LogDebug -> " DEBUG " + LogTrace -> " TRACE " -newtype B9 a = B9 { runB9 :: StateT BuildState IO a } - deriving (Functor, Applicative, Monad, MonadState BuildState) +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 + 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 diff --git a/src/lib/B9/Content/AST.hs b/src/lib/B9/Content/AST.hs --- a/src/lib/B9/Content/AST.hs +++ b/src/lib/B9/Content/AST.hs @@ -36,6 +36,7 @@ import Control.Monad.Reader import B9.Content.StringTemplate +import B9.B9Monad(B9) import Test.QuickCheck import B9.QCUtil @@ -88,14 +89,13 @@ -- | Types of values that describe content, that can be created from an 'AST'. class (ConcatableSyntax a) => ASTish a where fromAST - :: (CanRender c, Applicative m, Monad m, MonadIO m, MonadReader Environment m) - => AST c a -> m a + :: (CanRender c) + => AST c a -> ReaderT Environment B9 a -- | Types of values that can be /rendered/ into a 'ByteString' class CanRender c where render - :: (Functor m, Applicative m, MonadIO m, MonadReader Environment m) - => c -> m B.ByteString + :: c -> ReaderT Environment B9 B.ByteString instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where arbitrary = diff --git a/src/lib/B9/Content/Generator.hs b/src/lib/B9/Content/Generator.hs --- a/src/lib/B9/Content/Generator.hs +++ b/src/lib/B9/Content/Generator.hs @@ -6,11 +6,15 @@ import Data.Binary import Data.Data import Data.Hashable +import Control.Monad.Trans (lift) import GHC.Generics (Generic) #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif +import B9.B9Monad +import Control.Monad.IO.Class +import System.Exit import B9.Content.AST import B9.Content.ErlangPropList import B9.Content.StringTemplate @@ -20,11 +24,14 @@ import Test.QuickCheck import B9.QCUtil +import System.Process + data Content = RenderErlang (AST Content ErlangPropList) | RenderYaml (AST Content YamlObject) | FromString String | FromTextFile SourceFile + | FromURL String deriving (Read,Show,Typeable,Eq,Data,Generic) instance Hashable Content @@ -35,10 +42,21 @@ arbitrary = oneof [FromTextFile <$> smaller arbitrary ,RenderErlang <$> smaller arbitrary ,RenderYaml <$> smaller arbitrary - ,FromString <$> smaller arbitrary] + ,FromString <$> smaller arbitrary + ,FromURL <$> smaller arbitrary] instance CanRender Content where render (RenderErlang ast) = encodeSyntax <$> fromAST ast render (RenderYaml ast) = encodeSyntax <$> fromAST ast render (FromTextFile s) = readTemplateFile s render (FromString str) = return (B.pack str) + render (FromURL url) = lift $ do + dbgL $ "Downloading: " ++ url + (exitcode,out,err) <- liftIO $ readProcessWithExitCode "curl" [url] "" + if exitcode == ExitSuccess then + do dbgL $ "Download finished. Bytes read: " ++ show (length out) + traceL $ "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n" + return $ B.pack out + else + do errorL $ "Download failed: " ++ err + liftIO $ exitWith exitcode diff --git a/src/lib/B9/DSL.hs b/src/lib/B9/DSL.hs --- a/src/lib/B9/DSL.hs +++ b/src/lib/B9/DSL.hs @@ -19,7 +19,7 @@ (Image(..), ImageSource(..), ImageDestination(..), FileSystem(..), Partition(..), ImageResize(..), ImageSize(..), ImageType(..), SizeUnit(..)) -import B9.ExecEnv (CPUArch(..), SharedDirectory(..)) +import B9.ExecEnv (CPUArch(..)) import B9.ShellScript (Script(..)) #if !MIN_VERSION_base(4,8,0) import Control.Applicative @@ -212,7 +212,7 @@ data MountOpts (Tagged ImageSource String) = MountImgNoOptions deriving Show defaultMountOpts _ = MountImgNoOptions mountArtifactS _ = SMountedImage - mountArtifact opts e src dest = (e, src, dest) + mountArtifact _opts e src dest = (e, src, dest) mount :: DSLCanMount src diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs --- a/src/lib/B9/LibVirtLXC.hs +++ b/src/lib/B9/LibVirtLXC.hs @@ -4,7 +4,6 @@ , setDefaultConfig ) where -import Control.Applicative import Control.Monad.IO.Class ( liftIO ) import System.Directory import System.FilePath diff --git a/src/lib/B9/VmBuilder.hs b/src/lib/B9/VmBuilder.hs --- a/src/lib/B9/VmBuilder.hs +++ b/src/lib/B9/VmBuilder.hs @@ -4,7 +4,6 @@ import Data.List import Control.Monad -import Control.Applicative import Control.Monad.IO.Class import System.Directory (createDirectoryIfMissing, canonicalizePath) import Text.Printf ( printf )