b9 0.5.51 → 0.5.52
raw patch · 10 files changed
+793/−684 lines, 10 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- B9: [networkId] :: LibVirtLXCConfig -> Maybe String
- B9.B9Config.LibVirtLXC: [networkId] :: LibVirtLXCConfig -> Maybe String
+ B9: [_customLibVirtNetwork] :: B9ConfigOverride -> Maybe (Maybe String)
+ B9: [_networkId] :: LibVirtLXCConfig -> Maybe String
+ B9: customLibVirtNetwork :: Lens' B9ConfigOverride (Maybe (Maybe String))
+ B9: networkId :: Lens' LibVirtLXCConfig (Maybe String)
+ B9.B9Config: [_customLibVirtNetwork] :: B9ConfigOverride -> Maybe (Maybe String)
+ B9.B9Config: customLibVirtNetwork :: Lens' B9ConfigOverride (Maybe (Maybe String))
+ B9.B9Config.LibVirtLXC: [_networkId] :: LibVirtLXCConfig -> Maybe String
+ B9.B9Config.LibVirtLXC: networkId :: Lens' LibVirtLXCConfig (Maybe String)
- B9: B9ConfigOverride :: Maybe SystemPath -> B9Config -> B9ConfigOverride
+ B9: B9ConfigOverride :: Maybe SystemPath -> B9Config -> Maybe (Maybe String) -> B9ConfigOverride
- B9.B9Config: B9ConfigOverride :: Maybe SystemPath -> B9Config -> B9ConfigOverride
+ B9.B9Config: B9ConfigOverride :: Maybe SystemPath -> B9Config -> Maybe (Maybe String) -> B9ConfigOverride
Files
- b9.cabal +1/−1
- src/cli/Main.hs +76/−47
- src/lib/B9/B9Config.hs +158/−115
- src/lib/B9/B9Config/LibVirtLXC.hs +17/−16
- src/lib/B9/B9Monad.hs +73/−51
- src/lib/B9/Content/YamlObject.hs +1/−1
- src/lib/B9/DiskImageBuilder.hs +360/−365
- src/lib/B9/LibVirtLXC.hs +26/−22
- src/lib/B9/Shake/SharedImageRules.hs +76/−64
- stack.yaml +5/−2
b9.cabal view
@@ -1,5 +1,5 @@ name: b9-version: 0.5.51+version: 0.5.52 synopsis: A tool and library for building virtual machine images.
src/cli/Main.hs view
@@ -1,9 +1,17 @@-module Main(main) where+module Main+ ( main+ )+where -import Options.Applicative hiding (action)-import Options.Applicative.Help.Pretty hiding ((</>))-import B9-import Control.Lens ((.~), (&), over, (^.))+import Options.Applicative hiding ( action )+import Options.Applicative.Help.Pretty+ hiding ( (</>) )+import B9+import Control.Lens ( (.~)+ , (&)+ , over+ , (^.)+ ) main :: IO () main = do@@ -21,13 +29,15 @@ type Cmd = B9ConfigAction IO () +hostNetworkMagicValue :: String+hostNetworkMagicValue = "host"+ applyB9RunParameters :: B9RunParameters -> IO () applyB9RunParameters (B9RunParameters overrides act vars) = let cfg = noB9ConfigOverride & customB9Config- %~ ( over envVars (++ vars)- . const (overrides ^. customB9Config)+ %~ (over envVars (++ vars) . const (overrides ^. customB9Config) ) & maybe id overrideB9ConfigPath@@ -36,7 +46,7 @@ parseCommandLine :: IO B9RunParameters parseCommandLine = execParser- ( info+ (info (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars)) ( fullDesc <> progDesc@@ -53,7 +63,7 @@ globals = toGlobalOpts <$> optional- ( strOption+ (strOption ( help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c'@@ -69,7 +79,7 @@ <*> switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*> optional- ( strOption+ (strOption ( help "Path to a logfile" <> short 'l' <> long "log-file"@@ -77,14 +87,14 @@ ) ) <*> optional- ( strOption+ (strOption ( help "Output file for a command/timing profile" <> long "profile-file" <> metavar "FILENAME" ) ) <*> optional- ( strOption+ (strOption ( help "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${buildDirRoot}." <> short 'b'@@ -93,15 +103,15 @@ ) ) <*> switch- ( help "Keep build directories after exit" <> short 'k' <> long+ (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir" ) <*> switch- ( help "Predictable build directory names" <> short 'u' <> long+ (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir" ) <*> optional- ( strOption+ (strOption ( help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache"@@ -109,13 +119,24 @@ ) ) <*> optional- ( strOption+ (strOption ( help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID" ) )+ <*> optional+ (strOption+ ( help+ ("Override the libvirt-lxc network setting.\nThe special value '"+ ++ hostNetworkMagicValue+ ++ "' disables restricted container networking."+ )+ <> long "network"+ <> metavar "NETWORK_ID"+ )+ ) where toGlobalOpts :: Maybe FilePath@@ -128,9 +149,11 @@ -> Bool -> Maybe FilePath -> Maybe String+ -> Maybe String -> B9ConfigOverride- toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique mRepoCache repo- = let minLogLevel = if verbose+ toGlobalOpts cfg verbose quiet logF profF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet+ = let+ minLogLevel = if verbose then Just LogTrace else if quiet then Just LogError else Nothing b9cfg =@@ -146,93 +169,99 @@ & keepTempDirs .~ keep & uniqueBuildDirs- .~ not notUnique+ .~ not predictableBuildDir & repository .~ repo & repositoryCache .~ (Path <$> mRepoCache)- in B9ConfigOverride- { _customB9ConfigPath = Path <$> cfg- , _customB9Config = b9cfg+ in+ B9ConfigOverride+ { _customB9ConfigPath = Path <$> cfg+ , _customB9Config = b9cfg+ , _customLibVirtNetwork =+ (\n -> if n == hostNetworkMagicValue+ then Just n+ else Nothing+ )+ <$> libvirtNet } cmds :: Parser Cmd cmds = subparser ( command "version"- ( info (pure runShowVersion)- (progDesc "Show program version and exit.")+ (info (pure runShowVersion)+ (progDesc "Show program version and exit.") ) <> command "build"- ( info+ (info (void . runBuildArtifacts <$> buildFileParser) (progDesc "Merge all build file and generate all artifacts.") ) <> command "run"- ( info- ( (\x y -> void (runRun x y))- <$> sharedImageNameParser- <*> many (strArgument idm)+ (info+ ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many+ (strArgument idm) )- ( progDesc+ (progDesc "Run a command on the lastest version of the specified shared image. All modifications are lost on exit." ) ) <> command "push"- ( info+ (info (runPush <$> sharedImageNameParser)- ( progDesc+ (progDesc "Push the lastest shared image from cache to the selected remote repository." ) ) <> command "pull"- ( info+ (info (runPull <$> optional sharedImageNameParser)- ( progDesc+ (progDesc "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version." ) ) <> command "clean-local"- ( info+ (info (pure runGcLocalRepoCache)- ( progDesc+ (progDesc "Remove old versions of shared images from the local cache." ) ) <> command "clean-remote"- ( info+ (info (pure runGcRemoteRepoCache)- ( progDesc+ (progDesc "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories." ) ) <> command "list"- ( info (pure (void runListSharedImages))- (progDesc "List shared images.")+ (info (pure (void runListSharedImages))+ (progDesc "List shared images.") ) <> command "add-repo"- ( info (runAddRepo <$> remoteRepoParser)- (progDesc "Add a remote repo.")+ (info (runAddRepo <$> remoteRepoParser)+ (progDesc "Add a remote repo.") ) <> command "reformat"- ( info (runFormatBuildFiles <$> buildFileParser)- (progDesc "Re-Format all build files.")+ (info (runFormatBuildFiles <$> buildFileParser)+ (progDesc "Re-Format all build files.") ) ) buildFileParser :: Parser [FilePath] buildFileParser = helper <*> some- ( strOption+ (strOption ( help "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <> short 'f'@@ -258,7 +287,7 @@ ( help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY" )- <*> ( SshPrivKey <$> strArgument+ <*> (SshPrivKey <$> strArgument ( help "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE"@@ -279,7 +308,7 @@ ) ) )- <*> ( SshRemoteUser <$> strArgument+ <*> (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER") ) )
src/lib/B9/B9Config.hs view
@@ -2,74 +2,99 @@ Static B9 configuration. Read, write and merge configurable properties. The properties are independent of specific build targets. -}-module B9.B9Config ( B9Config(..)- , verbosity- , logFile- , buildDirRoot- , keepTempDirs- , execEnvType- , profileFile- , envVars- , uniqueBuildDirs- , repositoryCache- , repository- , interactive- , libVirtLXCConfigs- , remoteRepos- , maxLocalSharedImageRevisions- , B9ConfigOverride(..)- , noB9ConfigOverride- , B9ConfigAction()- , execB9ConfigAction- , invokeB9- , askRuntimeConfig- , localRuntimeConfig- , modifyPermanentConfig- , customB9Config- , customB9ConfigPath- , overrideB9ConfigPath- , overrideB9Config- , overrideWorkingDirectory- , overrideVerbosity- , overrideKeepBuildDirs- , defaultB9ConfigFile- , defaultRepositoryCache- , defaultB9Config- , openOrCreateB9Config- , writeB9CPDocument- , readB9Config- , parseB9Config- , appendPositionalArguments- , modifyCPDocument- , b9ConfigToCPDocument- , LogLevel(..)- , ExecEnvType (..)- , BuildVariables- , module X- ) where+module B9.B9Config+ ( B9Config(..)+ , verbosity+ , logFile+ , buildDirRoot+ , keepTempDirs+ , execEnvType+ , profileFile+ , envVars+ , uniqueBuildDirs+ , repositoryCache+ , repository+ , interactive+ , libVirtLXCConfigs+ , remoteRepos+ , maxLocalSharedImageRevisions+ , B9ConfigOverride(..)+ , noB9ConfigOverride+ , B9ConfigAction()+ , execB9ConfigAction+ , invokeB9+ , askRuntimeConfig+ , localRuntimeConfig+ , modifyPermanentConfig+ , customB9Config+ , customB9ConfigPath+ , customLibVirtNetwork+ , overrideB9ConfigPath+ , overrideB9Config+ , overrideWorkingDirectory+ , overrideVerbosity+ , overrideKeepBuildDirs+ , defaultB9ConfigFile+ , defaultRepositoryCache+ , defaultB9Config+ , openOrCreateB9Config+ , writeB9CPDocument+ , readB9Config+ , parseB9Config+ , appendPositionalArguments+ , modifyCPDocument+ , b9ConfigToCPDocument+ , LogLevel(..)+ , ExecEnvType(..)+ , BuildVariables+ , module X+ )+where -import Data.Maybe (fromMaybe)-import Control.Exception-import Data.Function (on)-import Control.Lens as Lens (makeLenses, (^.), (.~), over, set)-import Control.Monad ((>=>))-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.Writer-import System.Directory-import System.IO.B9Extras (SystemPath(..), resolve, ensureDir)-import qualified Data.Semigroup as Sem-import Data.List (partition, sortBy)-import Data.ConfigFile.B9Extras- ( CPDocument, CPError, CPGet- , CPOptionSpec, readCPDocument- , CPReadException(..), mergeCP, toStringCP- , addSectionCP, emptyCP, setShowCP, readCP )-import B9.B9Config.LibVirtLXC as X-import B9.B9Config.Repository as X-import Text.Printf (printf)+import Data.Maybe ( fromMaybe )+import Control.Exception+import Data.Function ( on )+import Control.Lens as Lens+ ( makeLenses+ , (^.)+ , (?~)+ , (.~)+ , (&)+ , over+ , set+ , _Just+ )+import Control.Monad ( (>=>) )+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Writer+import System.Directory+import System.IO.B9Extras ( SystemPath(..)+ , resolve+ , ensureDir+ )+import qualified Data.Semigroup as Sem+import Data.List ( partition+ , sortBy+ )+import Data.ConfigFile.B9Extras ( CPDocument+ , CPError+ , CPGet+ , CPOptionSpec+ , readCPDocument+ , CPReadException(..)+ , mergeCP+ , toStringCP+ , addSectionCP+ , emptyCP+ , setShowCP+ , readCP+ )+import B9.B9Config.LibVirtLXC as X+import B9.B9Config.Repository as X+import Text.Printf ( printf ) -type BuildVariables = [(String,String)]+type BuildVariables = [(String, String)] data ExecEnvType = LibVirtLXC deriving (Eq, Show, Ord, Read) @@ -93,46 +118,61 @@ } deriving (Show) instance Sem.Semigroup B9Config where- c <> c' =- B9Config { _verbosity = getLast $ on mappend (Last . _verbosity) c c'- , _logFile = getLast $ on mappend (Last . _logFile) c c'- , _buildDirRoot = getLast $ on mappend (Last . _buildDirRoot) c c'- , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'- , _execEnvType = LibVirtLXC- , _profileFile = getLast $ on mappend (Last . _profileFile) c c'- , _envVars = on mappend _envVars c c'- , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')- , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'- , _repository = getLast ((mappend `on` (Last . _repository)) c c')- , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')- , _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')- , _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c')- , _remoteRepos = (mappend `on` _remoteRepos) c c'- }+ c <> c' = B9Config+ { _verbosity = getLast $ on mappend (Last . _verbosity) c c'+ , _logFile = getLast $ on mappend (Last . _logFile) c c'+ , _buildDirRoot = getLast $ on mappend (Last . _buildDirRoot) c c'+ , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'+ , _execEnvType = LibVirtLXC+ , _profileFile = getLast $ on mappend (Last . _profileFile) c c'+ , _envVars = on mappend _envVars c c'+ , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')+ , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'+ , _repository = getLast ((mappend `on` (Last . _repository)) c c')+ , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')+ , _maxLocalSharedImageRevisions =+ getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')+ , _libVirtLXCConfigs = getLast+ ((mappend `on` (Last . _libVirtLXCConfigs)) c c')+ , _remoteRepos = (mappend `on` _remoteRepos) c c'+ } instance Monoid B9Config where mappend = (Sem.<>)- mempty = B9Config Nothing Nothing Nothing False LibVirtLXC Nothing [] True- Nothing Nothing False Nothing Nothing []+ mempty = B9Config Nothing+ Nothing+ Nothing+ False+ LibVirtLXC+ Nothing+ []+ True+ Nothing+ Nothing+ False+ Nothing+ Nothing+ [] -- | Override b9 configuration items and/or the path of the b9 configuration file. -- This is useful, i.e. when dealing with command line parameters. data B9ConfigOverride = B9ConfigOverride- { _customB9ConfigPath :: Maybe SystemPath- , _customB9Config :: B9Config+ { _customB9ConfigPath :: Maybe SystemPath+ , _customB9Config :: B9Config+ , _customLibVirtNetwork :: Maybe (Maybe String) } deriving Show -- | An empty default 'B9ConfigOverride' value, that will neither apply any -- additional 'B9Config' nor change the path of the configuration file. noB9ConfigOverride :: B9ConfigOverride-noB9ConfigOverride = B9ConfigOverride Nothing mempty+noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty makeLenses ''B9Config makeLenses ''B9ConfigOverride -- | Convenience utility to override the B9 configuration file path. overrideB9ConfigPath :: SystemPath -> B9ConfigOverride -> B9ConfigOverride-overrideB9ConfigPath p = customB9ConfigPath .~ Just p+overrideB9ConfigPath p = customB9ConfigPath ?~ p -- | Modify the runtime configuration. overrideB9Config@@ -141,7 +181,7 @@ -- | Define the current working directory to be used when building. overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride-overrideWorkingDirectory p = customB9Config . buildDirRoot .~ Just p+overrideWorkingDirectory p = customB9Config . buildDirRoot ?~ p -- | Overwrite the 'verbosity' settings in the configuration with those given.@@ -197,14 +237,18 @@ cp <- openOrCreateB9Config cfgPath case parseB9Config cp of- Left e -> do- fail- ( printf "Internal configuration load error, please report this: %s\n"- (show e)- )+ Left e -> fail+ (printf "Internal configuration load error, please report this: %s\n"+ (show e)+ ) Right permanentConfig -> do- let runtimeCfg = permanentConfig Sem.<> (cfg ^. customB9Config)+ let runtimeCfg =+ let rc = permanentConfig Sem.<> (cfg ^. customB9Config)+ in case cfg ^. customLibVirtNetwork of+ Just overridenNetwork ->+ rc & libVirtLXCConfigs . _Just . networkId .~ overridenNetwork+ Nothing -> rc (res, permanentB9ConfigUpdates) <- runWriterT (runReaderT (runB9ConfigAction act) runtimeCfg) @@ -214,7 +258,7 @@ else Just (mconcat permanentB9ConfigUpdates) cpExt <- maybe (return Nothing)- ( either+ (either ( fail . printf "Internal configuration update error! Please report this: %s\n"@@ -258,22 +302,21 @@ defaultB9Config :: B9Config-defaultB9Config = B9Config- { _verbosity = Just LogInfo- , _logFile = Nothing- , _buildDirRoot = Nothing- , _keepTempDirs = False- , _execEnvType = LibVirtLXC- , _profileFile = Nothing- , _envVars = []- , _uniqueBuildDirs = True- , _repository = Nothing- , _repositoryCache = Just defaultRepositoryCache- , _interactive = False- , _maxLocalSharedImageRevisions = Just 2- , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig- , _remoteRepos = []- }+defaultB9Config = B9Config { _verbosity = Just LogInfo+ , _logFile = Nothing+ , _buildDirRoot = Nothing+ , _keepTempDirs = False+ , _execEnvType = LibVirtLXC+ , _profileFile = Nothing+ , _envVars = []+ , _uniqueBuildDirs = True+ , _repository = Nothing+ , _repositoryCache = Just defaultRepositoryCache+ , _interactive = False+ , _maxLocalSharedImageRevisions = Just 2+ , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig+ , _remoteRepos = []+ } defaultRepositoryCache :: SystemPath defaultRepositoryCache = InB9UserDir "repo-cache"@@ -329,9 +372,9 @@ (_maxLocalSharedImageRevisions c) cpB <- setShowCP cpA cfgFileSection repositoryCacheK (_repositoryCache c) cpC <-- ( foldr (>=>)- return- (libVirtLXCConfigToCPDocument <$> (_libVirtLXCConfigs c))+ (foldr (>=>)+ return+ (libVirtLXCConfigToCPDocument <$> (_libVirtLXCConfigs c)) ) cpB cpFinal <- (foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c))
src/lib/B9/B9Config/LibVirtLXC.hs view
@@ -1,21 +1,24 @@-module B9.B9Config.LibVirtLXC (- libVirtLXCConfigToCPDocument- , defaultLibVirtLXCConfig- , parseLibVirtLXCConfig- , LibVirtLXCConfig(..)- , LXCGuestCapability(..)- ) where+module B9.B9Config.LibVirtLXC+ ( libVirtLXCConfigToCPDocument+ , defaultLibVirtLXCConfig+ , parseLibVirtLXCConfig+ , LibVirtLXCConfig(..)+ , networkId+ , LXCGuestCapability(..)+ )+where -import B9.DiskImages-import B9.ExecEnv-import Data.ConfigFile.B9Extras+import B9.DiskImages+import B9.ExecEnv+import Data.ConfigFile.B9Extras+import Control.Lens ( makeLenses ) data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool , virshPath :: FilePath , emulator :: FilePath , virshURI :: FilePath- , networkId :: Maybe String+ , _networkId :: Maybe String , guestCapabilities :: [LXCGuestCapability] , guestRamSize :: RamSize } deriving (Read, Show)@@ -62,6 +65,8 @@ | CAP_WAKE_ALARM deriving (Read, Show) +makeLenses ''LibVirtLXCConfig+ defaultLibVirtLXCConfig :: LibVirtLXCConfig defaultLibVirtLXCConfig = LibVirtLXCConfig True@@ -106,7 +111,7 @@ cp3 <- setCP cp2 cfgFileSection virshPathK $ virshPath c cp4 <- setCP cp3 cfgFileSection emulatorK $ emulator c cp5 <- setCP cp4 cfgFileSection virshURIK $ virshURI c- cp6 <- setShowCP cp5 cfgFileSection networkIdK $ networkId c+ cp6 <- setShowCP cp5 cfgFileSection networkIdK $ _networkId c cp7 <- setShowCP cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c setShowCP cp7 cfgFileSection guestRamSizeK $ guestRamSize c @@ -122,7 +127,3 @@ <*> (getr networkIdK) <*> (getr guestCapabilitiesK) <*> (getr guestRamSizeK)----
src/lib/B9/B9Monad.hs view
@@ -7,35 +7,58 @@ This module is used by the _effectful_ functions in this library. -} module B9.B9Monad- (B9, run, traceL, dbgL, infoL, errorL, errorExitL, getConfig,- getBuildId, getBuildDate, getBuildDir, getExecEnvType,- getSelectedRemoteRepo, getRemoteRepos, getRepoCache, cmd)- where+ ( 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+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@@ -60,7 +83,7 @@ run action = do cfg <- askRuntimeConfig liftIO $ do- buildId <- liftIO $ generateBuildId+ buildId <- liftIO $ generateBuildId cfg now <- liftIO $ getCurrentTime liftIO $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)@@ -87,8 +110,7 @@ ( cfg & remoteRepos .~ remoteRepos'- & buildDirRoot- .~ Just buildDirRootAbs+ & (buildDirRoot ?~ buildDirRootAbs) & envVars %~ mappend [("buildDirRoot", buildDirRootAbs)] )@@ -106,7 +128,7 @@ selectedRemoteRepo = do sel <- _repository cfg lookupRemoteRepo remoteRepos' sel <|> error- ( printf+ (printf "selected remote repo '%s' not configured, valid remote repos are: '%s'" sel (show remoteRepos')@@ -117,13 +139,7 @@ (fromJust (_profileFile cfg)) (unlines $ show <$> reverse (bsProf ctxOut)) return r- createBuildDir cfg buildId = if _uniqueBuildDirs cfg- then do- let subDir = "BUILD-" ++ buildId- buildDir <- resolveBuildDir subDir- createDirectory buildDir- canonicalizePath buildDir- else do+ createBuildDir cfg buildId = do let subDir = "BUILD-" ++ buildId buildDir <- resolveBuildDir subDir createDirectoryIfMissing True buildDir@@ -135,12 +151,18 @@ removeBuildDir cfg buildDir = when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ removeDirectoryRecursive buildDir- generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)+ 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) -- Run the action build action wrappedAction = do b9cfg <- getConfig- traverse (traceL . printf "Root Build Directory: %s")- (b9cfg ^. buildDirRoot)+ traverse_ (traceL . printf "Root Build Directory: %s")+ (b9cfg ^. buildDirRoot) startTime <- gets bsStartTime r <- action now <- liftIO getCurrentTime@@ -211,8 +233,8 @@ e <- liftIO $ runConcurrently- $ Concurrently (cpOut $$ outPipe)- *> Concurrently (cpErr $$ cmdLogger LogInfo)+ $ Concurrently (runConduit (cpOut .| outPipe))+ *> Concurrently (runConduit (cpErr .| cmdLogger LogInfo)) *> Concurrently (waitForStreamingProcess cph) checkExitCode e return cpIn@@ -276,10 +298,10 @@ 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
src/lib/B9/Content/YamlObject.hs view
@@ -38,7 +38,7 @@ put = put . encode . _fromYamlObject get = do v <- get- return $ YamlObject $ fromJust $ decode v+ return $ YamlObject $ fromJust $ decodeThrow v instance Read YamlObject where readsPrec _ = readsYamlObject
src/lib/B9/DiskImageBuilder.hs view
@@ -1,51 +1,56 @@ {-# LANGUAGE ScopedTypeVariables #-} {-| Effectful functions that create and convert disk image files. -}-module B9.DiskImageBuilder (materializeImageSource- ,substImageTarget- ,preferredDestImageTypes- ,preferredSourceImageTypes- ,resolveImageSource- ,createDestinationImage- ,resizeImage- ,importImage- ,exportImage- ,exportAndRemoveImage- ,convertImage- ,shareImage- ,ensureAbsoluteImageDirExists- ,pushSharedImageLatestVersion- ,lookupSharedImages- ,getSharedImages- ,getSharedImagesCacheDir- ,getSelectedRepos- ,pullRemoteRepos- ,pullLatestImage- ,) where+module B9.DiskImageBuilder+ ( materializeImageSource+ , substImageTarget+ , preferredDestImageTypes+ , preferredSourceImageTypes+ , resolveImageSource+ , createDestinationImage+ , resizeImage+ , importImage+ , exportImage+ , exportAndRemoveImage+ , convertImage+ , shareImage+ , ensureAbsoluteImageDirExists+ , pushSharedImageLatestVersion+ , lookupSharedImages+ , getSharedImages+ , getSharedImagesCacheDir+ , getSelectedRepos+ , pullRemoteRepos+ , pullLatestImage+ )+where -import System.IO.Error (isDoesNotExistError)-import System.Directory (removeFile)-import System.IO.B9Extras (ensureDir, prettyPrintToFile, consult)-import Control.Lens ((^.))-import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import System.Directory-import System.FilePath-import Text.Printf (printf)-import Data.Maybe-import Data.Function-import Text.Show.Pretty (ppShow)-import Data.List-import Data.Data-import Data.Generics.Schemes-import Data.Generics.Aliases-import B9.B9Monad-import B9.B9Config-import B9.Repository-import B9.RepositoryIO-import B9.DiskImages-import qualified B9.PartitionTable as P-import B9.Content.StringTemplate+import System.IO.Error ( isDoesNotExistError )+import System.Directory ( removeFile )+import System.IO.B9Extras ( ensureDir+ , prettyPrintToFile+ , consult+ )+import Control.Lens ( (^.) )+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import System.Directory+import System.FilePath+import Text.Printf ( printf )+import Data.Maybe+import Data.Function+import Text.Show.Pretty ( ppShow )+import Data.List+import Data.Data+import Data.Generics.Schemes+import Data.Generics.Aliases+import B9.B9Monad+import B9.B9Config+import B9.Repository+import B9.RepositoryIO+import B9.DiskImages+import qualified B9.PartitionTable as P+import B9.Content.StringTemplate -- -- | Convert relative file paths of images, sources and mounted host directories -- -- to absolute paths relative to '_buildDirRoot'.@@ -57,92 +62,79 @@ -- where mkAbs = mkT -- | Replace $... variables inside an 'ImageTarget'-substImageTarget :: [(String,String)] -> ImageTarget -> ImageTarget+substImageTarget :: [(String, String)] -> ImageTarget -> ImageTarget substImageTarget env = everywhere gsubst- where- gsubst :: Data a => a -> a- gsubst = mkT substMountPoint- `extT` substImage- `extT` substImageSource- `extT` substDiskTarget+ where+ gsubst :: Data a => a -> a+ gsubst =+ mkT substMountPoint+ `extT` substImage+ `extT` substImageSource+ `extT` substDiskTarget - substMountPoint NotMounted = NotMounted- substMountPoint (MountPoint x) = MountPoint (sub x)+ substMountPoint NotMounted = NotMounted+ substMountPoint (MountPoint x) = MountPoint (sub x) - substImage (Image fp t fs) = Image (sub fp) t fs+ substImage (Image fp t fs) = Image (sub fp) t fs - substImageSource (From n s) = From (sub n) s- substImageSource (EmptyImage l f t s) = EmptyImage (sub l) f t s- substImageSource s = s+ substImageSource (From n s ) = From (sub n) s+ substImageSource (EmptyImage l f t s) = EmptyImage (sub l) f t s+ substImageSource s = s - substDiskTarget (Share n t s) = Share (sub n) t s- substDiskTarget (LiveInstallerImage name outDir resize) =- LiveInstallerImage (sub name) (sub outDir) resize- substDiskTarget s = s+ substDiskTarget (Share n t s) = Share (sub n) t s+ substDiskTarget (LiveInstallerImage name outDir resize) =+ LiveInstallerImage (sub name) (sub outDir) resize+ substDiskTarget s = s - sub = subst env+ sub = subst env -- | Resolve an ImageSource to an 'Image'. The ImageSource might -- not exist, as is the case for 'EmptyImage'. resolveImageSource :: ImageSource -> B9 Image-resolveImageSource src =- case src of- (EmptyImage fsLabel fsType imgType _size) ->- let img = Image fsLabel imgType fsType- in return (changeImageFormat imgType img)- (SourceImage srcImg _part _resize) ->- ensureAbsoluteImageDirExists srcImg- (CopyOnWrite backingImg) ->- ensureAbsoluteImageDirExists backingImg- (From name _resize) ->- getLatestImageByName (SharedImageName name)- >>= maybe (errorExitL (printf "Nothing found for %s."- (show (SharedImageName name))))- ensureAbsoluteImageDirExists+resolveImageSource src = case src of+ (EmptyImage fsLabel fsType imgType _size) ->+ let img = Image fsLabel imgType fsType+ in return (changeImageFormat imgType img)+ (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg+ (CopyOnWrite backingImg ) -> ensureAbsoluteImageDirExists backingImg+ (From name _resize) ->+ getLatestImageByName (SharedImageName name)+ >>= maybe+ (errorExitL+ (printf "Nothing found for %s." (show (SharedImageName name)))+ )+ ensureAbsoluteImageDirExists -- | Return all valid image types sorted by preference. preferredDestImageTypes :: ImageSource -> B9 [ImageType]-preferredDestImageTypes src =- case src of- (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]- (EmptyImage _label NoFileSystem fmt _size) ->- return (nub [fmt, Raw, QCow2, Vmdk])- (EmptyImage _label _fs _fmt _size) -> return [Raw]- (SourceImage _img (Partition _) _resize) -> return [Raw]- (SourceImage (Image _file fmt _fs) _pt resize) ->- return- (nub [fmt, Raw, QCow2, Vmdk]- `intersect`- allowedImageTypesForResize resize)- (From name resize) ->- getLatestImageByName (SharedImageName name)- >>= maybe (errorExitL (printf "Nothing found for %s."- (show (SharedImageName name))))- (\sharedImg ->- preferredDestImageTypes (SourceImage sharedImg NoPT resize))+preferredDestImageTypes src = case src of+ (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]+ (EmptyImage _label NoFileSystem fmt _size) ->+ return (nub [fmt, Raw, QCow2, Vmdk])+ (EmptyImage _label _fs _fmt _size ) -> return [Raw]+ (SourceImage _img (Partition _) _resize) -> return [Raw]+ (SourceImage (Image _file fmt _fs) _pt resize ) -> return+ (nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize)+ (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe+ (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+ (\sharedImg -> preferredDestImageTypes (SourceImage sharedImg NoPT resize)) -- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion' -- in the preferred order. preferredSourceImageTypes :: ImageDestination -> [ImageType]-preferredSourceImageTypes dest =- case dest of- (Share _ fmt resize) ->- nub [fmt, Raw, QCow2, Vmdk]- `intersect` allowedImageTypesForResize resize- (LocalFile (Image _ fmt _) resize) ->- nub [fmt, Raw, QCow2, Vmdk]- `intersect` allowedImageTypesForResize resize- Transient ->- [Raw, QCow2, Vmdk]- (LiveInstallerImage _name _repo _imgResize) ->- [Raw]+preferredSourceImageTypes dest = case dest of+ (Share _ fmt resize) ->+ nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+ (LocalFile (Image _ fmt _) resize) ->+ nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+ Transient -> [Raw, QCow2, Vmdk]+ (LiveInstallerImage _name _repo _imgResize) -> [Raw] allowedImageTypesForResize :: ImageResize -> [ImageType]-allowedImageTypesForResize r =- case r of- Resize _ -> [Raw]- ShrinkToMinimum -> [Raw]- _ -> [Raw, QCow2, Vmdk]+allowedImageTypesForResize r = case r of+ Resize _ -> [Raw]+ ShrinkToMinimum -> [Raw]+ _ -> [Raw, QCow2, Vmdk] -- | Create the parent directories for the file that contains the 'Image'. -- If the path to the image file is relative, prepend '_buildDirRoot' from@@ -151,11 +143,12 @@ ensureAbsoluteImageDirExists img@(Image path _ _) = do b9cfg <- getConfig let dir =- let dirRel = takeDirectory path- in if isRelative dirRel then- let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)- in prefix </> dirRel- else dirRel+ let dirRel = takeDirectory path+ in if isRelative dirRel+ then+ let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)+ in prefix </> dirRel+ else dirRel liftIO $ do createDirectoryIfMissing True dir@@ -166,182 +159,170 @@ -- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist. materializeImageSource :: ImageSource -> Image -> B9 ()-materializeImageSource src dest =- case src of- (EmptyImage fsLabel fsType _imgType size) ->- let (Image _ imgType _) = dest- in createEmptyImage fsLabel fsType imgType size dest- (SourceImage srcImg part resize) ->- createImageFromImage srcImg part resize dest- (CopyOnWrite backingImg) ->- createCOWImage backingImg dest- (From name resize) -> do- getLatestImageByName (SharedImageName name)- >>= maybe (errorExitL (printf "Nothing found for %s."- (show (SharedImageName name))))- (\sharedImg ->- materializeImageSource- (SourceImage sharedImg NoPT resize) dest)+materializeImageSource src dest = case src of+ (EmptyImage fsLabel fsType _imgType size) ->+ let (Image _ imgType _) = dest+ in createEmptyImage fsLabel fsType imgType size dest+ (SourceImage srcImg part resize) ->+ createImageFromImage srcImg part resize dest+ (CopyOnWrite backingImg) -> createCOWImage backingImg dest+ (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe+ (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+ (\sharedImg ->+ materializeImageSource (SourceImage sharedImg NoPT resize) dest+ ) createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 () createImageFromImage src part size out = do- importImage src out- extractPartition part out- resizeImage size out- where- extractPartition :: Partition -> Image -> B9 ()- extractPartition NoPT _ = return ()- extractPartition (Partition partIndex) (Image outFile Raw _) = do- (start,len,blockSize) <- liftIO (P.getPartition partIndex outFile)- let tmpFile = outFile <.> "extracted"- dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)- cmd- (printf- "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"- outFile- tmpFile- blockSize- start- len)- cmd (printf "mv '%s' '%s'" tmpFile outFile)- extractPartition (Partition partIndex) (Image outFile fmt _) =- error- (printf- "Extract partition %i from image '%s': Invalid format %s"- partIndex- outFile- (imageFileExtension fmt))+ importImage src out+ extractPartition part out+ resizeImage size out+ where+ extractPartition :: Partition -> Image -> B9 ()+ extractPartition NoPT _ = return ()+ extractPartition (Partition partIndex) (Image outFile Raw _) = do+ (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)+ let tmpFile = outFile <.> "extracted"+ dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)+ cmd+ (printf "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"+ outFile+ tmpFile+ blockSize+ start+ len+ )+ cmd (printf "mv '%s' '%s'" tmpFile outFile)+ extractPartition (Partition partIndex) (Image outFile fmt _) = error+ (printf "Extract partition %i from image '%s': Invalid format %s"+ partIndex+ outFile+ (imageFileExtension fmt)+ ) -- | Convert some 'Image', e.g. a temporary image used during the build phase -- to the final destination. createDestinationImage :: Image -> ImageDestination -> B9 ()-createDestinationImage buildImg dest =- case dest of- (Share name imgType imgResize) -> do- resizeImage imgResize buildImg- let shareableImg = changeImageFormat imgType buildImg- exportAndRemoveImage buildImg shareableImg- void (shareImage shareableImg (SharedImageName name))- (LocalFile destImg imgResize) -> do- resizeImage imgResize buildImg- exportAndRemoveImage buildImg destImg- (LiveInstallerImage name repo imgResize) -> do- resizeImage imgResize buildImg- let destImg = Image destFile Raw buildImgFs- (Image _ _ buildImgFs) = buildImg- destFile =- repo </> "machines" </> name </> "disks" </> "raw" </>- "0.raw"- sizeFile =- repo </> "machines" </> name </> "disks" </> "raw" </>- "0.size"- versFile =- repo </> "machines" </> name </> "disks" </> "raw" </>- "VERSION"- exportAndRemoveImage buildImg destImg- cmd- (printf- "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"- destFile- sizeFile)- buildDate <- getBuildDate- buildId <- getBuildId- liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))- Transient -> return ()+createDestinationImage buildImg dest = case dest of+ (Share name imgType imgResize) -> do+ resizeImage imgResize buildImg+ let shareableImg = changeImageFormat imgType buildImg+ exportAndRemoveImage buildImg shareableImg+ void (shareImage shareableImg (SharedImageName name))+ (LocalFile destImg imgResize) -> do+ resizeImage imgResize buildImg+ exportAndRemoveImage buildImg destImg+ (LiveInstallerImage name repo imgResize) -> do+ resizeImage imgResize buildImg+ let+ destImg = Image destFile Raw buildImgFs+ (Image _ _ buildImgFs) = buildImg+ destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"+ sizeFile =+ repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"+ versFile =+ repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"+ exportAndRemoveImage buildImg destImg+ cmd+ (printf+ "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"+ destFile+ sizeFile+ )+ buildDate <- getBuildDate+ buildId <- getBuildId+ liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))+ Transient -> return () -createEmptyImage :: String- -> FileSystem- -> ImageType- -> ImageSize- -> Image- -> B9 ()+createEmptyImage+ :: String -> FileSystem -> ImageType -> ImageSize -> Image -> B9 () createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType')- | fsType /= fsType' =- error- (printf- "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."- (show fsType)- (show fsType'))- | imgType /= imgType' =- error- (printf- "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."- (show imgType)- (show imgType'))+ | fsType /= fsType' = error+ (printf+ "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."+ (show fsType)+ (show fsType')+ )+ | imgType /= imgType' = error+ (printf+ "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."+ (show imgType)+ (show imgType')+ ) | otherwise = do- let (Image imgFile imgFmt imgFs) = dest- qemuImgOpts = conversionOptions imgFmt- dbgL- (printf- "Creating empty raw image '%s' with size %s and options %s"- imgFile- (toQemuSizeOptVal imgSize)- qemuImgOpts)- cmd- (printf- "qemu-img create -f %s %s '%s' '%s'"- (imageFileExtension imgFmt)- qemuImgOpts- imgFile- (toQemuSizeOptVal imgSize))- case (imgFmt, imgFs) of- (Raw,Ext4_64) -> do- let fsCmd = "mkfs.ext4"- dbgL (printf "Creating file system %s" (show imgFs))- cmd (printf "%s -F -L '%s' -O 64bit -q '%s'" fsCmd fsLabel imgFile)- (Raw,Ext4) -> do- let fsCmd = "mkfs.ext4"- dbgL (printf "Creating file system %s" (show imgFs))- cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile)- (it,fs) ->- error- (printf- "Cannot create file system %s in image type %s"- (show fs)- (show it))+ let (Image imgFile imgFmt imgFs) = dest+ qemuImgOpts = conversionOptions imgFmt+ dbgL+ (printf "Creating empty raw image '%s' with size %s and options %s"+ imgFile+ (toQemuSizeOptVal imgSize)+ qemuImgOpts+ )+ cmd+ (printf "qemu-img create -f %s %s '%s' '%s'"+ (imageFileExtension imgFmt)+ qemuImgOpts+ imgFile+ (toQemuSizeOptVal imgSize)+ )+ case (imgFmt, imgFs) of+ (Raw, Ext4_64) -> do+ let fsCmd = "mkfs.ext4"+ dbgL (printf "Creating file system %s" (show imgFs))+ cmd (printf "%s -F -L '%s' -O 64bit -q '%s'" fsCmd fsLabel imgFile)+ (Raw, Ext4) -> do+ let fsCmd = "mkfs.ext4"+ dbgL (printf "Creating file system %s" (show imgFs))+ cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile)+ (it, fs) -> error+ (printf "Cannot create file system %s in image type %s"+ (show fs)+ (show it)+ ) createCOWImage :: Image -> Image -> B9 () createCOWImage (Image backingFile _ _) (Image imgOut imgFmt _) = do dbgL (printf "Creating COW image '%s' backed by '%s'" imgOut backingFile) cmd- (printf- "qemu-img create -f %s -o backing_file='%s' '%s'"- (imageFileExtension imgFmt)- backingFile- imgOut)+ (printf "qemu-img create -f %s -o backing_file='%s' '%s'"+ (imageFileExtension imgFmt)+ backingFile+ imgOut+ ) -- | Resize an image, including the file system inside the image. resizeImage :: ImageResize -> Image -> B9 () resizeImage KeepSize _ = return ()-resizeImage (Resize newSize) (Image img Raw fs)- | fs == Ext4 || fs == Ext4_64- = do- let sizeOpt = toQemuSizeOptVal newSize- dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)- cmd (printf "e2fsck -p '%s'" img)- cmd (printf "resize2fs -f '%s' %s" img sizeOpt)+resizeImage (Resize newSize) (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =+ do+ let sizeOpt = toQemuSizeOptVal newSize+ dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)+ cmd (printf "e2fsck -p '%s'" img)+ cmd (printf "resize2fs -f '%s' %s" img sizeOpt) resizeImage (ResizeImage newSize) (Image img _ _) = do let sizeOpt = toQemuSizeOptVal newSize dbgL (printf "Resizing image to %s" sizeOpt) cmd (printf "qemu-img resize -q '%s' %s" img sizeOpt) -resizeImage ShrinkToMinimum (Image img Raw fs)- | fs == Ext4 || fs == Ext4_64- = do- dbgL "Shrinking image to minimum size"- cmd (printf "e2fsck -p '%s'" img)- cmd (printf "resize2fs -f -M '%s'" img)+resizeImage ShrinkToMinimum (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =+ do+ dbgL "Shrinking image to minimum size"+ cmd (printf "e2fsck -p '%s'" img)+ cmd (printf "resize2fs -f -M '%s'" img) -resizeImage _ img =- error (printf "Invalid image type or filesystem, cannot resize image: %s" (show img))+resizeImage _ img = error+ (printf "Invalid image type or filesystem, cannot resize image: %s" (show img)+ ) -- | Import a disk image from some external source into the build directory -- if necessary convert the image. importImage :: Image -> Image -> B9 ()-importImage = convert False+importImage imgIn imgOut@(Image imgOutPath _ _) = do+ alreadyThere <- liftIO (doesFileExist imgOutPath)+ unless alreadyThere (convert False imgIn imgOut) -- | Export a disk image from the build directory; if necessary convert the image. exportImage :: Image -> Image -> B9 ()@@ -353,38 +334,40 @@ -- | Convert an image in the build directory to another format and return the new image. convertImage :: Image -> Image -> B9 ()-convertImage = convert True+convertImage imgIn imgOut@(Image imgOutPath _ _) = do+ alreadyThere <- liftIO (doesFileExist imgOutPath)+ unless alreadyThere (convert True imgIn imgOut) -- | Convert/Copy/Move images convert :: Bool -> Image -> Image -> B9 () convert doMove (Image imgIn fmtIn _) (Image imgOut fmtOut _) | imgIn == imgOut = do- ensureDir imgOut- dbgL (printf "No need to convert: '%s'" imgIn)+ ensureDir imgOut+ dbgL (printf "No need to convert: '%s'" imgIn) | doMove && fmtIn == fmtOut = do- ensureDir imgOut- dbgL (printf "Moving '%s' to '%s'" imgIn imgOut)- liftIO (renameFile imgIn imgOut)+ ensureDir imgOut+ dbgL (printf "Moving '%s' to '%s'" imgIn imgOut)+ liftIO (renameFile imgIn imgOut) | otherwise = do- ensureDir imgOut- dbgL- (printf- "Converting %s to %s: '%s' to '%s'"- (imageFileExtension fmtIn)- (imageFileExtension fmtOut)- imgIn- imgOut)- cmd- (printf- "qemu-img convert -q -f %s -O %s %s '%s' '%s'"- (imageFileExtension fmtIn)- (imageFileExtension fmtOut)- (conversionOptions fmtOut)- imgIn- imgOut)- when doMove $ do- dbgL (printf "Removing '%s'" imgIn)- liftIO (removeFile imgIn)+ ensureDir imgOut+ dbgL+ (printf "Converting %s to %s: '%s' to '%s'"+ (imageFileExtension fmtIn)+ (imageFileExtension fmtOut)+ imgIn+ imgOut+ )+ cmd+ (printf "qemu-img convert -q -f %s -O %s %s '%s' '%s'"+ (imageFileExtension fmtIn)+ (imageFileExtension fmtOut)+ (conversionOptions fmtOut)+ imgIn+ imgOut+ )+ when doMove $ do+ dbgL (printf "Removing '%s'" imgIn)+ liftIO (removeFile imgIn) conversionOptions :: ImageType -> String conversionOptions Vmdk = " -o adapter_type=lsilogic "@@ -396,7 +379,7 @@ GB -> "G" MB -> "M" KB -> "K"- B -> ""+ B -> "" -- | Publish an sharedImage made from an image and image meta data to the -- configured repository@@ -412,8 +395,14 @@ getSharedImageFromImageInfo :: SharedImageName -> Image -> B9 SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do buildId <- getBuildId- date <- getBuildDate- return (SharedImage name (SharedImageDate date) (SharedImageBuildId buildId) imgType imgFS)+ date <- getBuildDate+ return+ (SharedImage name+ (SharedImageDate date)+ (SharedImageBuildId buildId)+ imgType+ imgFS+ ) -- | Convert the disk image and serialize the base image data structure. -- If the 'maxLocalSharedImageRevisions' configuration is set to @Just n@@@ -422,7 +411,7 @@ createSharedImageInCache img sname@(SharedImageName name) = do dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name) sharedImg <- getSharedImageFromImageInfo sname img- dir <- getSharedImagesCacheDir+ dir <- getSharedImagesCacheDir convertImage img (changeImageDirectory dir (sharedImageImage sharedImg)) prettyPrintToFile (dir </> sharedImageFileName sharedImg) sharedImg dbgL (printf "CREATED SHARED IMAGE IN CACHE '%s'" (ppShow sharedImg))@@ -433,12 +422,13 @@ -- selected repository from the cache. pushSharedImageLatestVersion :: SharedImageName -> B9 () pushSharedImageLatestVersion name@(SharedImageName imgName) =- getLatestSharedImageByNameFromCache name- >>= maybe (errorExitL (printf "Nothing found for %s." (show imgName)))- (\sharedImage -> do- dbgL (printf "PUSHING '%s'" (ppShow sharedImage))- pushToSelectedRepo sharedImage- infoL (printf "PUSHED '%s'" imgName))+ getLatestSharedImageByNameFromCache name >>= maybe+ (errorExitL (printf "Nothing found for %s." (show imgName)))+ (\sharedImage -> do+ dbgL (printf "PUSHING '%s'" (ppShow sharedImage))+ pushToSelectedRepo sharedImage+ infoL (printf "PUSHED '%s'" imgName)+ ) -- | Upload a shared image from the cache to a selected remote repository pushToSelectedRepo :: SharedImage -> B9 ()@@ -451,7 +441,7 @@ cachedInfoFile = c </> sharedImageFileName i repoImgFile = sharedImagesRootDirectory </> imgFile' repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName i- pushToRepo (fromJust r) cachedImgFile repoImgFile+ pushToRepo (fromJust r) cachedImgFile repoImgFile pushToRepo (fromJust r) cachedInfoFile repoInfoFile -- | Pull metadata files from all remote repositories.@@ -460,15 +450,16 @@ repos <- getSelectedRepos mapM_ dl repos - where- dl = pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension)+ where+ dl =+ pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension) -- | Pull the latest version of an image, either from the selected remote -- repo or from the repo that has the latest version. pullLatestImage :: SharedImageName -> B9 (Maybe SharedImageBuildId) pullLatestImage name@(SharedImageName dbgName) = do repos <- getSelectedRepos- let repoPredicate Cache = False+ let repoPredicate Cache = False repoPredicate (Remote repoId) = repoId `elem` repoIds repoIds = map remoteRepoRepoId repos hasName sharedImage = name == sharedImageName sharedImage@@ -477,20 +468,23 @@ if null candidates then do errorL- (printf "No shared image named '%s' on these remote repositories: '%s'" dbgName- (ppShow repoIds))+ (printf+ "No shared image named '%s' on these remote repositories: '%s'"+ dbgName+ (ppShow repoIds)+ ) return Nothing else do dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image)) cacheDir <- getSharedImagesCacheDir- let (Image imgFile' _imgType _fs) = sharedImageImage image- cachedImgFile = cacheDir </> imgFile'- cachedInfoFile = cacheDir </> sharedImageFileName image- repoImgFile = sharedImagesRootDirectory </> imgFile'- repoInfoFile = sharedImagesRootDirectory- </> sharedImageFileName image- repo = fromJust (lookupRemoteRepo repos repoId)- pullFromRepo repo repoImgFile cachedImgFile+ let+ (Image imgFile' _imgType _fs) = sharedImageImage image+ cachedImgFile = cacheDir </> imgFile'+ cachedInfoFile = cacheDir </> sharedImageFileName image+ repoImgFile = sharedImagesRootDirectory </> imgFile'+ repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName image+ repo = fromJust (lookupRemoteRepo repos repoId)+ pullFromRepo repo repoImgFile cachedImgFile pullFromRepo repo repoInfoFile cachedInfoFile infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId) cleanOldSharedImageRevisionsFromCache name@@ -501,13 +495,11 @@ getLatestImageByName :: SharedImageName -> B9 (Maybe Image) getLatestImageByName name = do sharedImage <- getLatestSharedImageByNameFromCache name- cacheDir <- getSharedImagesCacheDir+ cacheDir <- getSharedImagesCacheDir let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage case image of- Just i ->- dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))- Nothing ->- errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name))+ Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))+ Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name)) return image -- | Return the latest version of a shared image named 'name' from the local cache.@@ -515,55 +507,54 @@ getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName) case reverse imgs of- (Cache, sharedImage):_rest ->- return (Just sharedImage)- _ -> do+ (Cache, sharedImage) : _rest -> return (Just sharedImage)+ _ -> do errorL (printf "No image(s) named '%s' found." dbgName) return Nothing -- | Return a list of all existing sharedImages from cached repositories. getSharedImages :: B9 [(Repository, [SharedImage])] getSharedImages = do- reposAndFiles <- repoSearch sharedImagesRootDirectory (FileExtension sharedImageFileExtension)- mapM (\(repo, files) -> ((repo,) . catMaybes) <$> mapM consult' files) reposAndFiles+ reposAndFiles <- repoSearch sharedImagesRootDirectory+ (FileExtension sharedImageFileExtension)+ mapM (\(repo, files) -> ((repo, ) . catMaybes) <$> mapM consult' files)+ reposAndFiles - where- consult' f = do- r <- liftIO (try (consult f))- case r of- Left (e :: SomeException) -> do- dbgL- (printf "Failed to load shared image meta-data from '%s': '%s'" (takeFileName f)- (show e))- dbgL (printf "Removing bad meta-data file '%s'" f)- liftIO (removeFile f)- return Nothing- Right c ->- return (Just c)+ where+ consult' f = do+ r <- liftIO (try (consult f))+ case r of+ Left (e :: SomeException) -> do+ dbgL+ (printf "Failed to load shared image meta-data from '%s': '%s'"+ (takeFileName f)+ (show e)+ )+ dbgL (printf "Removing bad meta-data file '%s'" f)+ liftIO (removeFile f)+ return Nothing+ Right c -> return (Just c) -- | Find shared images and the associated repos from two predicates. The result -- is the concatenated result of the sorted shared images satisfying 'imgPred'.-lookupSharedImages :: (Repository -> Bool)- -> (SharedImage -> Bool)- -> B9 [(Repository, SharedImage)]+lookupSharedImages+ :: (Repository -> Bool)+ -> (SharedImage -> Bool)+ -> B9 [(Repository, SharedImage)] lookupSharedImages repoPred imgPred = do xs <- getSharedImages- let rs = [(r, s) | (r, ss) <- xs- , s <- ss]+ let rs = [ (r, s) | (r, ss) <- xs, s <- ss ] matchingRepo = filter (repoPred . fst) rs- matchingImg = filter (imgPred . snd) matchingRepo- sorted = sortBy (compare `on` snd) matchingImg+ matchingImg = filter (imgPred . snd) matchingRepo+ sorted = sortBy (compare `on` snd) matchingImg return (mconcat (pure <$> sorted)) -- | Return either all remote repos or just the single selected repo. getSelectedRepos :: B9 [RemoteRepo] getSelectedRepos = do- allRepos <- getRemoteRepos+ allRepos <- getRemoteRepos selectedRepo <- getSelectedRemoteRepo- let repos = maybe- allRepos- return- selectedRepo -- 'Maybe' a repo+ let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo return repos -- | Return the path to the sub directory in the cache that contains files of@@ -578,24 +569,28 @@ -- images with the given name from the local cache. cleanOldSharedImageRevisionsFromCache :: SharedImageName -> B9 () cleanOldSharedImageRevisionsFromCache sn = do- b9Cfg <- getConfig- forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do- toDelete <- take maxRevisions <$> newestSharedImages- imgDir <- getSharedImagesCacheDir- let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)- infoFiles = sharedImageFileName <$> toDelete- imgFiles = imageFileName . sharedImageImage <$> toDelete- unless (null filesToDelete) $ do- traceL (printf "DELETING %d OBSOLETE REVISIONS OF: %s"- (length filesToDelete) (show sn))- mapM_ traceL filesToDelete- mapM_ removeIfExists filesToDelete- where- newestSharedImages :: B9 [SharedImage]- newestSharedImages =- reverse . map snd <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName)+ b9Cfg <- getConfig+ forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do+ toDelete <- take maxRevisions <$> newestSharedImages+ imgDir <- getSharedImagesCacheDir+ let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)+ infoFiles = sharedImageFileName <$> toDelete+ imgFiles = imageFileName . sharedImageImage <$> toDelete+ unless (null filesToDelete) $ do+ traceL+ (printf "DELETING %d OBSOLETE REVISIONS OF: %s"+ (length filesToDelete)+ (show sn)+ )+ mapM_ traceL filesToDelete+ mapM_ removeIfExists filesToDelete+ where+ newestSharedImages :: B9 [SharedImage]+ newestSharedImages = reverse . map snd <$> lookupSharedImages+ (== Cache)+ ((sn ==) . sharedImageName) - removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists- where- handleExists e | isDoesNotExistError e = return ()- | otherwise = throwIO e+ removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists+ where+ handleExists e | isDoesNotExistError e = return ()+ | otherwise = throwIO e
src/lib/B9/LibVirtLXC.hs view
@@ -1,23 +1,27 @@ {-| Implementation of an execution environment that uses "libvirt-lxc". -}-module B9.LibVirtLXC ( runInEnvironment- , supportedImageTypes- , logLibVirtLXCConfig- , module X- ) where+module B9.LibVirtLXC+ ( runInEnvironment+ , supportedImageTypes+ , logLibVirtLXCConfig+ , module X+ )+where -import Control.Monad.IO.Class ( liftIO )-import System.Directory-import System.FilePath-import Text.Printf ( printf )-import Data.Char (toLower)-import Control.Lens (view)-import B9.ShellScript-import B9.B9Monad-import B9.B9Config (libVirtLXCConfigs)-import B9.DiskImages-import B9.ExecEnv-import B9.B9Config.LibVirtLXC as X-import System.IO.B9Extras (UUID(), randomUUID)+import Control.Monad.IO.Class ( liftIO )+import System.Directory+import System.FilePath+import Text.Printf ( printf )+import Data.Char ( toLower )+import Control.Lens ( view )+import B9.ShellScript+import B9.B9Monad+import B9.B9Config ( libVirtLXCConfigs )+import B9.DiskImages+import B9.ExecEnv+import B9.B9Config.LibVirtLXC as X+import System.IO.B9Extras ( UUID()+ , randomUUID+ ) logLibVirtLXCConfig :: LibVirtLXCConfig -> B9 () logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)@@ -50,9 +54,9 @@ script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest] buildDir = buildBaseDir </> uuid' liftIO $ do- createDirectoryIfMissing True scriptDirHost- writeSh (scriptDirHost </> initScript) script- writeFile domainFile domain+ createDirectoryIfMissing True scriptDirHost+ writeSh (scriptDirHost </> initScript) script+ writeFile domainFile domain return $ Context scriptDirHost uuid domainFile cfg successMarkerCmd scriptDirGuest =@@ -116,7 +120,7 @@ ++ emulator cfg ++ "</emulator>\n" ++ unlines- ( libVirtNetwork (networkId cfg)+ ( libVirtNetwork (_networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e) )
@@ -1,71 +1,82 @@ -- | A crude, unsafe and preliminary solution to building B9 'SharedImage's -- from Shake.-module B9.Shake.SharedImageRules ( customSharedImageAction- , needSharedImage- , enableSharedImageRules) where+module B9.Shake.SharedImageRules+ ( customSharedImageAction+ , needSharedImage+ , enableSharedImageRules+ )+where -import Development.Shake-import Development.Shake.Classes-import Development.Shake.Rule-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Lazy as LazyByteString-import qualified Data.Binary as Binary-import B9+import Development.Shake+import Development.Shake.Classes+import Development.Shake.Rule+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Binary as Binary+import B9 -- | In order to use 'needSharedImage' and 'customSharedImageAction' you need to -- call this action before using any of the afore mentioned. enableSharedImageRules :: B9ConfigOverride -> Rules () enableSharedImageRules b9inv = addBuiltinRule noLint go where- go :: SharedImageName- -> Maybe ByteString.ByteString- -> Bool- -> Action (RunResult SharedImageBuildId)+ go+ :: SharedImageName+ -> Maybe ByteString.ByteString+ -> Bool+ -> Action (RunResult SharedImageBuildId) go nameQ mSerlializedBuildId dependenciesChanged = let mOld = decodeBuildId <$> mSerlializedBuildId- in do- (rebuilt, newBuildId) <-- if dependenciesChanged then (True,) <$> rebuild- else- do mNewBuildId <- getImgBuildId- maybe ((\i -> (True, i)) <$> rebuild)- (\i -> return (False, i))- mNewBuildId+ in do+ (rebuilt, newBuildId) <- if dependenciesChanged+ then (True, ) <$> rebuild+ else do+ mNewBuildId <- getImgBuildId+ maybe ((\i -> (True, i)) <$> rebuild)+ (\i -> return (False, i))+ mNewBuildId let newBuildIdBin = encodeBuildId newBuildId- change =- if rebuilt then- maybe ChangedRecomputeDiff- (\buildIdChanged ->- if buildIdChanged then ChangedRecomputeSame- else ChangedRecomputeSame )- ((/= newBuildId) <$> mOld)- else- maybe ChangedStore- (\buildIdChanged ->- if buildIdChanged then ChangedRecomputeSame- else ChangedRecomputeSame )- ((/= newBuildId) <$> mOld)+ change = if rebuilt+ then maybe+ ChangedRecomputeDiff+ (\buildIdChanged -> if buildIdChanged+ then ChangedRecomputeSame+ else ChangedRecomputeSame+ )+ ((/= newBuildId) <$> mOld)+ else maybe+ ChangedStore+ (\buildIdChanged -> if buildIdChanged+ then ChangedRecomputeSame+ else ChangedRecomputeSame+ )+ ((/= newBuildId) <$> mOld) result = RunResult change newBuildIdBin newBuildId return result- where- getImgBuildId = execB9ConfigAction (runLookupLocalSharedImage nameQ) b9inv+ where+ getImgBuildId = execB9ConfigAction (runLookupLocalSharedImage nameQ) b9inv - decodeBuildId :: ByteString.ByteString -> SharedImageBuildId- decodeBuildId = Binary.decode . LazyByteString.fromStrict+ decodeBuildId :: ByteString.ByteString -> SharedImageBuildId+ decodeBuildId = Binary.decode . LazyByteString.fromStrict - encodeBuildId :: SharedImageBuildId -> ByteString.ByteString- encodeBuildId = LazyByteString.toStrict . Binary.encode+ encodeBuildId :: SharedImageBuildId -> ByteString.ByteString+ encodeBuildId = LazyByteString.toStrict . Binary.encode - rebuild :: Action SharedImageBuildId- rebuild = do- rules <- getUserRules- case userRuleMatch rules imgMatch of- [] -> fail $ "No rules to build B9 shared image " ++ show nameQ ++ " found"- [act] -> act b9inv- _rs -> fail $ "Multiple rules for the B9 shared image " ++ show nameQ ++ " found"- where- imgMatch (SharedImageCustomActionRule name mkImage) =- if name == nameQ then Just mkImage else Nothing+ rebuild :: Action SharedImageBuildId+ rebuild = do+ rules <- getUserRules+ case userRuleMatch rules imgMatch of+ [] ->+ fail $ "No rules to build B9 shared image " ++ show nameQ ++ " found"+ [act] -> act b9inv+ _rs ->+ fail+ $ "Multiple rules for the B9 shared image "+ ++ show nameQ+ ++ " found"+ where+ imgMatch (SharedImageCustomActionRule name mkImage) =+ if name == nameQ then Just mkImage else Nothing -- | Add a dependency to the creation of a 'SharedImage'. The build action -- for the shared image must have been supplied by e.g. 'customSharedImageAction'.@@ -77,15 +88,19 @@ -- image identified by a 'SharedImageName'. -- NOTE: You must call 'enableSharedImageRules' before this action works. customSharedImageAction :: SharedImageName -> Action () -> Rules ()-customSharedImageAction b9img customAction =- addUserRule (SharedImageCustomActionRule b9img customAction')- where- customAction' b9inv = do- customAction- mCurrentBuildId <- execB9ConfigAction (runLookupLocalSharedImage b9img) b9inv- putLoud (printf "Finished custom action, for %s, build-id is: %s"- (show b9img) (show mCurrentBuildId))- maybe (errorSharedImageNotFound b9img) return mCurrentBuildId+customSharedImageAction b9img customAction = addUserRule+ (SharedImageCustomActionRule b9img customAction')+ where+ customAction' b9inv = do+ customAction+ mCurrentBuildId <- execB9ConfigAction (runLookupLocalSharedImage b9img)+ b9inv+ putLoud+ (printf "Finished custom action, for %s, build-id is: %s"+ (show b9img)+ (show mCurrentBuildId)+ )+ maybe (errorSharedImageNotFound b9img) return mCurrentBuildId type instance RuleResult SharedImageName = SharedImageBuildId@@ -95,7 +110,4 @@ deriving Typeable errorSharedImageNotFound :: Monad m => SharedImageName -> m a-errorSharedImageNotFound =- fail- . printf "Error: %s not found."- . show+errorSharedImageNotFound = fail . printf "Error: %s not found." . show
stack.yaml view
@@ -1,8 +1,11 @@ flags: {} packages: - '.'-extra-deps: []-resolver: lts-11.3+extra-deps: +- ConfigFile-1.1.4+- template-0.2.0.10++resolver: lts-12.21 allow-newer: true # pvp-bounds: lower require-stack-version: ">=1.6.5"