b9 0.5.18 → 0.5.19

raw patch · 10 files changed

+228/−218 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• b9.cabal +1/−1
• src/cli/Main.hs +0/−1
• src/lib/B9.hs +0/−19
• src/lib/B9/ArtifactGeneratorImpl.hs +0/−1
• src/lib/B9/B9Monad.hs +202/−187
• src/lib/B9/Content/AST.hs +4/−4
• src/lib/B9/Content/Generator.hs +19/−1
• src/lib/B9/DSL.hs +2/−2
• src/lib/B9/LibVirtLXC.hs +0/−1
• src/lib/B9/VmBuilder.hs +0/−1

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.18+version:             0.5.19  synopsis:            A tool and library for building virtual machine images. 

@@ -5,7 +5,6 @@  import Control.Exception import Data.Function                   (on)-import Data.List                       (groupBy) import Data.Maybe import Data.Version import Paths_b9

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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

@@ -4,7 +4,6 @@                      , setDefaultConfig                      ) where -import Control.Applicative import Control.Monad.IO.Class ( liftIO ) import System.Directory import System.FilePath

@@ -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 )