b9 0.2.5 → 0.3.0
raw patch · 13 files changed
+419/−380 lines, 13 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- B9.B9Config: B9Config :: Maybe LogLevel -> Maybe FilePath -> Maybe FilePath -> Bool -> ExecEnvType -> Maybe FilePath -> BuildVariables -> Bool -> SystemPath -> Maybe String -> B9Config
+ B9.B9Config: B9Config :: Maybe LogLevel -> Maybe FilePath -> Maybe FilePath -> Bool -> ExecEnvType -> Maybe FilePath -> BuildVariables -> Bool -> Maybe SystemPath -> Maybe String -> B9Config
- B9.B9Config: repositoryCache :: B9Config -> SystemPath
+ B9.B9Config: repositoryCache :: B9Config -> Maybe SystemPath
Files
- .gitignore +4/−0
- README.md +1/−1
- TODO.org +1/−0
- b9.cabal +1/−1
- src/cli/Main.hs +4/−8
- src/lib/B9/B9Config.hs +5/−4
- src/lib/B9/B9Monad.hs +55/−47
- src/lib/B9/Content/StringTemplate.hs +21/−26
- src/lib/B9/DiskImageBuilder.hs +174/−156
- src/lib/B9/ExecEnv.hs +24/−21
- src/lib/B9/LibVirtLXC.hs +101/−88
- src/lib/B9/MBR.hs +8/−10
- src/lib/B9/Vm.hs +20/−18
.gitignore view
@@ -12,3 +12,7 @@ /cabal.sandbox.config /upload_doc.sh +# Intellij IDEA+/.idea/+*.iml+
README.md view
@@ -2,7 +2,7 @@ [](https://travis-ci.org/sheyll/b9-vm-image-builder) -[](http://hackage.haskell.org/package/b9)+[](http://hackage.haskell.org/package/b9) Use B9 to compile your software into a deployable set of Linux-VM- or configuration images, from a set of scripts and input files and templates
TODO.org view
@@ -91,3 +91,4 @@ ** Move 'Repository' from B9.RepositoryIO to B9.Repository * Add building of RPMs and ARCHLINUX packages * Use unique ids for vm image builds+* TODO Fix repo-cache configfile ignoration
b9.cabal view
@@ -1,5 +1,5 @@ name: b9-version: 0.2.5+version: 0.3.0 synopsis: A tool and library for building virtual machine images.
src/cli/Main.hs view
@@ -28,8 +28,7 @@ \\n\ \Repository names passed to the command line are\ \ looked up in the B9 configuration file, which is\- \ on Un*x like system per default located in: \- \ '~/.b9/b9.config'"+ \ per default located in: '~/.b9/b9.conf'" <> headerDoc (Just helpHeader))) where helpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. "@@ -120,7 +119,7 @@ globals :: Parser GlobalOpts globals = toGlobalOpts <$> optional (strOption- (help "Path to users b9-configuration"+ (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <> metavar "FILENAME"))@@ -184,11 +183,8 @@ , uniqueBuildDirs = not notUnique , repository = repo }- in case mRepoCache of- Nothing -> b9cfg- Just repoCache ->- let rc = Path repoCache- in b9cfg { repositoryCache = rc }+ in b9cfg { repositoryCache = Path <$> mRepoCache }+ in GlobalOpts { configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile , cliB9Config = b9cfg' }
src/lib/B9/B9Config.hs view
@@ -42,13 +42,14 @@ , profileFile :: Maybe FilePath , envVars :: BuildVariables , uniqueBuildDirs :: Bool- , repositoryCache :: SystemPath+ , repositoryCache :: Maybe SystemPath , repository :: Maybe String } deriving (Show) + instance Monoid B9Config where mempty = B9Config Nothing Nothing Nothing False LibVirtLXC Nothing [] True- defaultRepositoryCache Nothing+ Nothing Nothing mappend c c' = B9Config { verbosity = getLast $ on mappend (Last . verbosity) c c' , logFile = getLast $ on mappend (Last . logFile) c c'@@ -58,7 +59,7 @@ , profileFile = getLast $ on mappend (Last . profileFile) c c' , envVars = on mappend envVars c c' , uniqueBuildDirs = getAll ((mappend `on` (All . uniqueBuildDirs)) c c')- , repositoryCache = repositoryCache c'+ , repositoryCache = getLast $ on mappend (Last . repositoryCache) c c' , repository = getLast ((mappend `on` (Last . repository)) c c') } @@ -72,7 +73,7 @@ , envVars = [] , uniqueBuildDirs = True , repository = Nothing- , repositoryCache = defaultRepositoryCache+ , repositoryCache = Just defaultRepositoryCache } defaultRepositoryCache :: SystemPath
src/lib/B9/B9Monad.hs view
@@ -31,8 +31,8 @@ import System.Random ( randomIO ) import Text.Printf import Control.Concurrent.Async (Concurrently (..))-import Data.Conduit (($$))-import qualified Data.Conduit.List as CL+import Data.Conduit (($$))+import qualified Data.Conduit.List as CL import Data.Conduit.Process data BuildState = BuildState { bsBuildId :: String@@ -57,54 +57,65 @@ buildId <- generateBuildId now <- getCurrentTime bracket (createBuildDir buildId) removeBuildDir (run' buildId now)+ where run' buildId now buildDir = do -- Check repositories- repoCache <- initRepoCache (repositoryCache cfg)+ repoCache <- initRepoCache (maybe defaultB9ConfigFile id (repositoryCache cfg)) let remoteRepos = getConfiguredRemoteRepos cfgParser remoteRepos' <- mapM (initRemoteRepo repoCache) remoteRepos- let ctx = BuildState buildId buildDate cfgParser cfg buildDir- selectedRemoteRepo remoteRepos' repoCache- [] now True+ let ctx = BuildState+ buildId+ buildDate+ cfgParser+ cfg+ buildDir+ selectedRemoteRepo+ remoteRepos'+ repoCache+ []+ now+ True buildDate = formatTime undefined "%F-%T" now selectedRemoteRepo = do sel <- repository cfg (lookupRemoteRepo remoteRepos sel- <|> error (printf "selected remote repo '%s' not configured,\- \ valid remote repos are: '%s'"- sel- (show remoteRepos)))+ <|> 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))+ writeFile (fromJust (profileFile cfg)) (unlines $ show <$> (reverse $ bsProf ctxOut)) return r createBuildDir buildId = do- 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+ 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 = do case buildDirRoot cfg of- Nothing ->- return f- Just root' -> do- createDirectoryIfMissing True root'- root <- canonicalizePath root'- return $ root </> f+ 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+ when (uniqueBuildDirs cfg && not (keepTempDirs cfg)) $ removeDirectoryRecursive buildDir generateBuildId = printf "%08X" <$> (randomIO :: IO Word32) @@ -164,16 +175,17 @@ (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr) cmdLogger <- getCmdLogger e <- liftIO $ runConcurrently $- Concurrently (cpOut $$ cmdLogger LogTrace) *>- Concurrently (cpErr $$ cmdLogger LogInfo) *>- Concurrently (waitForStreamingProcess cph)+ Concurrently (cpOut $$ cmdLogger LogTrace) *>+ Concurrently (cpErr $$ cmdLogger LogInfo) *>+ Concurrently (waitForStreamingProcess cph) checkExitCode e return cpIn+ where getCmdLogger = do lv <- gets $ verbosity . bsCfg lf <- gets $ logFile . bsCfg- return $ \ level -> (CL.mapM_ (logImpl lv lf level . B.unpack))+ return $ \level -> (CL.mapM_ (logImpl lv lf level . B.unpack)) checkExitCode ExitSuccess = traceL $ "COMMAND SUCCESS"@@ -213,19 +225,16 @@ 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 "+printLevel l =+ case l of+ LogNothing -> "NOTHING"+ LogError -> " ERROR "+ LogInfo -> " INFO "+ LogDebug -> " DEBUG "+ LogTrace -> " TRACE " newtype B9 a = B9 { runB9 :: StateT BuildState IO a }- deriving ( Functor- , Applicative- , Monad- , MonadState BuildState- )+ deriving (Functor, Applicative, Monad, MonadState BuildState) instance MonadIO B9 where liftIO m = do@@ -234,6 +243,5 @@ stop <- B9 $ liftIO getCurrentTime let durMS = IoActionDuration (stop `diffUTCTime` start) modify $- \ ctx ->- ctx { bsProf = durMS : bsProf ctx }+ \ctx -> ctx { bsProf = durMS : bsProf ctx } return res
src/lib/B9/Content/StringTemplate.hs view
@@ -1,36 +1,31 @@ {-# LANGUAGE FlexibleContexts #-} {-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable expansion in string throughout a B9 artifact. -}-module B9.Content.StringTemplate (subst- ,substE- ,substEB- ,substFile- ,substPath- ,readTemplateFile- ,SourceFile(..)- ,SourceFileConversion(..)- ,Environment(..)- ,withEnvironment) where+module B9.Content.StringTemplate+ (subst, substE, substEB, substFile, substPath, readTemplateFile,+ SourceFile(..), SourceFileConversion(..), Environment(..),+ withEnvironment)+ where -import Data.Text.Template (render,templateSafe,renderA)-import Data.Data-import Data.Maybe-import Control.Monad.Reader-import qualified Data.Text as T-import qualified Data.ByteString.Lazy as LB+import Control.Applicative+import Control.Arrow hiding (second)+import Control.Monad.Reader+import Data.Bifunctor import qualified Data.ByteString as B-import Data.Text.Encoding as E-import Data.Text.Lazy.Encoding as LE-import Control.Arrow hiding (second)-import Control.Applicative-import Data.Bifunctor-import Text.Show.Pretty (ppShow)-import Test.QuickCheck-import Text.Printf+import qualified Data.ByteString.Lazy as LB+import Data.Data+import Data.Maybe+import qualified Data.Text as T+import Data.Text.Encoding as E+import Data.Text.Lazy.Encoding as LE+import Data.Text.Template (render,templateSafe,renderA)+import Test.QuickCheck+import Text.Printf+import Text.Show.Pretty (ppShow) -import B9.ConfigUtils-import B9.QCUtil+import B9.ConfigUtils +import B9.QCUtil -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents. data SourceFile = Source SourceFileConversion FilePath
src/lib/B9/DiskImageBuilder.hs view
@@ -47,74 +47,76 @@ -- | Replace $... variables inside an 'ImageTarget' substImageTarget :: [(String,String)] -> ImageTarget -> ImageTarget-substImageTarget env p = everywhere gsubst p- where gsubst :: forall a. Data a => a -> a- gsubst = mkT substMountPoint- `extT` substImage- `extT` substImageSource- `extT` substDiskTarget+substImageTarget env = everywhere gsubst+ 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'. Note however that this source will -- may not exist as is the case for 'EmptyImage'. resolveImageSource :: ImageSource -> B9 Image-resolveImageSource src = do+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) ->- liftIO (ensureAbsoluteImageDirExists srcImg)- (CopyOnWrite backingImg) ->- liftIO (ensureAbsoluteImageDirExists backingImg)- (From name _resize) -> do- latestImage <- getLatestImageByName name- liftIO (ensureAbsoluteImageDirExists latestImage)+ (EmptyImage fsLabel fsType imgType _size) ->+ let img = Image fsLabel imgType fsType+ in return (changeImageFormat imgType img)+ (SourceImage srcImg _part _resize) ->+ liftIO (ensureAbsoluteImageDirExists srcImg)+ (CopyOnWrite backingImg) ->+ liftIO (ensureAbsoluteImageDirExists backingImg)+ (From name _resize) -> do+ latestImage <- getLatestImageByName name+ liftIO (ensureAbsoluteImageDirExists latestImage) -- | 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) -> do- sharedImg <- getLatestImageByName name- preferredDestImageTypes (SourceImage sharedImg NoPT resize)+ (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) -> do+ sharedImg <- getLatestImageByName name+ preferredDestImageTypes (SourceImage sharedImg NoPT resize) preferredSourceImageTypes :: ImageDestination -> [ImageType] preferredSourceImageTypes dest = case dest of (Share _ fmt resize) -> nub [fmt, Raw, QCow2, Vmdk]- `intersect` (allowedImageTypesForResize resize)+ `intersect` allowedImageTypesForResize resize (LocalFile (Image _ fmt _) resize) -> nub [fmt, Raw, QCow2, Vmdk]- `intersect` (allowedImageTypesForResize resize)+ `intersect` allowedImageTypesForResize resize Transient -> [Raw, QCow2, Vmdk]- (LiveInstallerImage _name _repo _imgResize) ->+ (LiveInstallerImage _name _repo _imgResize) -> [Raw] allowedImageTypesForResize :: ImageResize -> [ImageType]@@ -137,22 +139,23 @@ 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- sharedImg <- getLatestImageByName name- materializeImageSource (SourceImage sharedImg NoPT resize) dest+ (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+ sharedImg <- getLatestImageByName name+ 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 ()@@ -160,13 +163,20 @@ (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+ "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))+ error+ (printf "Extract partition %i from \+ \image '%s': Invalid format %s" partIndex outFile+ (imageFileExtension fmt)) createDestinationImage :: Image -> ImageDestination -> B9 () createDestinationImage buildImg dest =@@ -183,15 +193,16 @@ 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"+ 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)+ 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))@@ -205,39 +216,44 @@ -> 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- dbgL (printf "Creating empty raw image '%s' with size %s" imgFile- (toQemuSizeOptVal imgSize))- cmd (printf "qemu-img create -f %s '%s' '%s'"- (imageFileExtension imgFmt)- imgFile- (toQemuSizeOptVal imgSize))- case (imgFmt, imgFs) of- (Raw, Ext4) -> do- let fsCmd = "mkfs.ext4"- dbgL (printf "Creating file system %s" (show imgFs))- cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile)- (it, fs) -> do- error (printf "Cannot create file system %s in image type %s"- (show fs)- (show it))+ let (Image imgFile imgFmt imgFs) = dest+ dbgL (printf "Creating empty raw image '%s' with size %s" imgFile (toQemuSizeOptVal imgSize))+ cmd+ (printf "qemu-img create -f %s '%s' '%s'" (imageFileExtension imgFmt) imgFile+ (toQemuSizeOptVal imgSize))+ case (imgFmt, imgFs) of+ (Raw, Ext4) -> do+ let fsCmd = "mkfs.ext4"+ dbgL (printf "Creating file system %s" (show imgFs))+ cmd (printf "%s -L '%s' -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)+ 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) -- | Resize an image, including the file system inside the image. resizeImage :: ImageResize -> Image -> B9 ()@@ -259,8 +275,7 @@ cmd (printf "resize2fs -f -M '%s'" img) resizeImage _ img =- error (printf "Invalid image type or filesystem, cannot resize image: %s"- (show 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@@ -278,31 +293,37 @@ -- | Convert an image in the build directory to another format and return the new image. convertImage :: Image -> Image -> B9 ()-convertImage imgIn imgOut = convert True imgIn imgOut+convertImage = convert True -- | 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)- | 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'"- (imageFileExtension fmtIn) (imageFileExtension 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'"+ (imageFileExtension fmtIn)+ (imageFileExtension fmtOut)+ imgIn+ imgOut)+ when doMove $ do+ dbgL (printf "Removing '%s'" imgIn)+ liftIO (removeFile imgIn) toQemuSizeOptVal :: ImageSize -> String toQemuSizeOptVal (ImageSize amount u) = show amount ++ case u of@@ -324,13 +345,9 @@ -- name and disk image. getSharedImageFromImageInfo :: SharedImageName -> Image -> B9 SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do- buildId <- getBuildId- date <- getBuildDate- return (SharedImage name- (SharedImageDate date)- (SharedImageBuildId buildId)- imgType- imgFS)+ buildId <- getBuildId+ date <- getBuildDate+ return (SharedImage name (SharedImageDate date) (SharedImageBuildId buildId) imgType imgFS) -- | Convert the disk image and serialize the base image data structure. createSharedImageInCache :: Image -> SharedImageName -> B9 SharedImage@@ -372,9 +389,9 @@ pullRemoteRepos = do repos <- getSelectedRepos mapM_ dl repos+ where- dl = pullGlob sharedImagesRootDirectory- (FileExtension sharedImageFileExtension)+ 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.@@ -386,28 +403,27 @@ repoIds = map remoteRepoRepoId repos hasName sharedImage = name == siName sharedImage candidates <- lookupSharedImages repoPredicate hasName- let (Remote repoId, image) = head (reverse candidates)+ let (Remote repoId, image) = last candidates if null candidates- then do errorL (printf "No shared image named '%s'\- \ on these remote repositories: '%s'"- name- (ppShow repoIds))- return False- 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- pullFromRepo repo repoInfoFile cachedInfoFile- infoL (printf "PULLED '%s' FROM '%s'"- name- repoId)- return True+ then do+ errorL+ (printf "No shared image named '%s' on these remote repositories: '%s'" name+ (ppShow repoIds))+ return False+ 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+ pullFromRepo repo repoInfoFile cachedInfoFile+ infoL (printf "PULLED '%s' FROM '%s'" name repoId)+ return True -- | Return the 'Image' of the latest version of a shared image named 'name'@@ -433,16 +449,17 @@ -- | 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 "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@@ -455,22 +472,23 @@ -> (SharedImage -> Bool) -> B9 [(Repository, SharedImage)] lookupSharedImages repoPred imgPred = do- xs <- getSharedImages- 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- return (mconcat (pure <$> sorted))+ xs <- getSharedImages+ 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+ return (mconcat (pure <$> sorted)) -- | Return either all remote repos or just the single selected repo. getSelectedRepos :: B9 [RemoteRepo] getSelectedRepos = do allRepos <- getRemoteRepos selectedRepo <- getSelectedRemoteRepo- let repos = maybe allRepos -- user has not selected a repo- return -- user has selected a repo, return it as- -- singleton list- 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
src/lib/B9/ExecEnv.hs view
@@ -5,14 +5,14 @@ "B9.LibVirtLXC" should configure and execute build scripts, as defined in "B9.ShellScript" and "B9.Vm". -}-module B9.ExecEnv- ( ExecEnv (..)- , Resources (..)- , noResources- , SharedDirectory (..)- , CPUArch (..)- , RamSize (..)- ) where+module B9.ExecEnv (+ ExecEnv(..),+ Resources(..),+ noResources,+ SharedDirectory(..),+ CPUArch(..),+ RamSize(..),+ ) where import Data.Data import Data.Monoid@@ -28,33 +28,36 @@ data SharedDirectory = SharedDirectory FilePath MountPoint | SharedDirectoryRO FilePath MountPoint | SharedSources MountPoint- deriving (Read, Show, Typeable, Data,Eq)+ deriving (Read, Show, Typeable, Data, Eq) data Resources = Resources { maxMemory :: RamSize , cpuCount :: Int , cpuArch :: CPUArch- } deriving (Read, Show, Typeable, Data)+ }+ deriving (Read, Show, Typeable, Data) instance Monoid Resources where mempty = Resources mempty 1 mempty- mappend (Resources m c a) (Resources m' c' a') =- Resources (m <> m') (max c c') (a <> a')+ mappend (Resources m c a) (Resources m' c' a') = Resources (m <> m') (max c c') (a <> a') noResources :: Resources noResources = mempty -data CPUArch = X86_64 | I386 deriving (Read, Show, Typeable, Data,Eq)+data CPUArch = X86_64+ | I386+ deriving (Read, Show, Typeable, Data, Eq) instance Monoid CPUArch where- mempty = I386- I386 `mappend` x = x- X86_64 `mappend` _ = X86_64+ mempty = I386+ I386 `mappend` x = x+ X86_64 `mappend` _ = X86_64 data RamSize = RamSize Int SizeUnit- | AutomaticRamSize deriving (Eq, Read, Show, Ord, Typeable, Data)+ | AutomaticRamSize+ deriving (Eq, Read, Show, Ord, Typeable, Data) instance Monoid RamSize where- mempty = AutomaticRamSize- AutomaticRamSize `mappend` x = x- x `mappend` AutomaticRamSize = x- r `mappend` r' = max r r'+ mempty = AutomaticRamSize+ AutomaticRamSize `mappend` x = x+ x `mappend` AutomaticRamSize = x+ r `mappend` r' = max r r'
src/lib/B9/LibVirtLXC.hs view
@@ -26,8 +26,8 @@ runInEnvironment :: ExecEnv -> Script -> B9 Bool runInEnvironment env scriptIn = if emptyScript scriptIn- then return True- else setUp >>= execute+ then return True+ else setUp >>= execute where setUp = do cfg <- configureLibVirtLXC@@ -37,14 +37,14 @@ let scriptDirHost = buildDir </> "init-script" scriptDirGuest = "/" ++ buildId domainFile = buildBaseDir </> uuid' <.> domainConfig- domain = createDomain cfg env buildId uuid' scriptDirHost- scriptDirGuest+ domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest uuid' = printf "%U" uuid script = Begin [scriptIn, successMarkerCmd scriptDirGuest] buildDir = buildBaseDir </> uuid'- liftIO $ do createDirectoryIfMissing True scriptDirHost- writeSh (scriptDirHost </> initScript) script- writeFile domainFile domain+ liftIO $ do+ createDirectoryIfMissing True scriptDirHost+ writeSh (scriptDirHost </> initScript) script+ writeFile domainFile domain return $ Context scriptDirHost uuid domainFile cfg successMarkerCmd scriptDirGuest =@@ -63,9 +63,12 @@ virshCommand :: LibVirtLXCConfig -> String virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'- where useSudo' = if useSudo cfg then "sudo " else ""- virshPath' = virshPath cfg- virshURI' = virshURI cfg+ where+ useSudo' = if useSudo cfg+ then "sudo "+ else ""+ virshPath' = virshPath cfg+ virshURI' = virshURI cfg data Context = Context FilePath UUID FilePath LibVirtLXCConfig @@ -79,63 +82,63 @@ -- | Available linux capabilities for lxc containers. This maps directly to the -- capabilities defined in 'man 7 capabilities'.-data LXCGuestCapability =- CAP_MKNOD- | CAP_AUDIT_CONTROL- | CAP_AUDIT_READ- | CAP_AUDIT_WRITE- | CAP_BLOCK_SUSPEND- | CAP_CHOWN- | CAP_DAC_OVERRIDE- | CAP_DAC_READ_SEARCH- | CAP_FOWNER- | CAP_FSETID- | CAP_IPC_LOCK- | CAP_IPC_OWNER- | CAP_KILL- | CAP_LEASE- | CAP_LINUX_IMMUTABLE- | CAP_MAC_ADMIN- | CAP_MAC_OVERRIDE- | CAP_NET_ADMIN- | CAP_NET_BIND_SERVICE- | CAP_NET_BROADCAST- | CAP_NET_RAW- | CAP_SETGID- | CAP_SETFCAP- | CAP_SETPCAP- | CAP_SETUID- | CAP_SYS_ADMIN- | CAP_SYS_BOOT- | CAP_SYS_CHROOT- | CAP_SYS_MODULE- | CAP_SYS_NICE- | CAP_SYS_PACCT- | CAP_SYS_PTRACE- | CAP_SYS_RAWIO- | CAP_SYS_RESOURCE- | CAP_SYS_TIME- | CAP_SYS_TTY_CONFIG- | CAP_SYSLOG- | CAP_WAKE_ALARM+data LXCGuestCapability = CAP_MKNOD+ | CAP_AUDIT_CONTROL+ | CAP_AUDIT_READ+ | CAP_AUDIT_WRITE+ | CAP_BLOCK_SUSPEND+ | CAP_CHOWN+ | CAP_DAC_OVERRIDE+ | CAP_DAC_READ_SEARCH+ | CAP_FOWNER+ | CAP_FSETID+ | CAP_IPC_LOCK+ | CAP_IPC_OWNER+ | CAP_KILL+ | CAP_LEASE+ | CAP_LINUX_IMMUTABLE+ | CAP_MAC_ADMIN+ | CAP_MAC_OVERRIDE+ | CAP_NET_ADMIN+ | CAP_NET_BIND_SERVICE+ | CAP_NET_BROADCAST+ | CAP_NET_RAW+ | CAP_SETGID+ | CAP_SETFCAP+ | CAP_SETPCAP+ | CAP_SETUID+ | CAP_SYS_ADMIN+ | CAP_SYS_BOOT+ | CAP_SYS_CHROOT+ | CAP_SYS_MODULE+ | CAP_SYS_NICE+ | CAP_SYS_PACCT+ | CAP_SYS_PTRACE+ | CAP_SYS_RAWIO+ | CAP_SYS_RESOURCE+ | CAP_SYS_TIME+ | CAP_SYS_TTY_CONFIG+ | CAP_SYSLOG+ | CAP_WAKE_ALARM deriving (Read, Show) defaultLibVirtLXCConfig :: LibVirtLXCConfig defaultLibVirtLXCConfig = LibVirtLXCConfig- True- "/usr/bin/virsh"- "/usr/lib/libvirt/libvirt_lxc"- "lxc:///"- Nothing- [CAP_MKNOD- ,CAP_SYS_ADMIN- ,CAP_SYS_CHROOT- ,CAP_SETGID- ,CAP_SETUID- ,CAP_NET_BIND_SERVICE- ,CAP_SETPCAP- ,CAP_SYS_PTRACE- ,CAP_SYS_MODULE]+ True+ "/usr/bin/virsh"+ "/usr/lib/libvirt/libvirt_lxc"+ "lxc:///"+ Nothing+ [ CAP_MKNOD+ , CAP_SYS_ADMIN+ , CAP_SYS_CHROOT+ , CAP_SETGID+ , CAP_SETUID+ , CAP_NET_BIND_SERVICE+ , CAP_SETPCAP+ , CAP_SYS_PTRACE+ , CAP_SYS_MODULE+ ] cfgFileSection :: String cfgFileSection = "libvirt-lxc"@@ -173,19 +176,26 @@ setshow cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c readLibVirtConfig :: B9 LibVirtLXCConfig-readLibVirtConfig = do- cp <- getConfigParser- let geto :: (Get_C a, Read a) => OptionSpec -> a -> a- geto = getOptionOr cp cfgFileSection- return $ LibVirtLXCConfig {- useSudo = geto useSudoK $ useSudo defaultLibVirtLXCConfig- , virshPath = geto virshPathK $ virshPath defaultLibVirtLXCConfig- , emulator = geto emulatorK $ emulator defaultLibVirtLXCConfig- , virshURI = geto virshURIK $ virshURI defaultLibVirtLXCConfig- , networkId = geto networkIdK $ networkId defaultLibVirtLXCConfig- , guestCapabilities = geto guestCapabilitiesK $- guestCapabilities defaultLibVirtLXCConfig- }+readLibVirtConfig =+ do+ cp <- getConfigParser+ let geto :: (Get_C a, Read a)+ => OptionSpec -> a -> a+ geto = getOptionOr cp cfgFileSection+ return $+ LibVirtLXCConfig { useSudo = geto useSudoK $+ useSudo defaultLibVirtLXCConfig+ , virshPath = geto virshPathK $+ virshPath defaultLibVirtLXCConfig+ , emulator = geto emulatorK $+ emulator defaultLibVirtLXCConfig+ , virshURI = geto virshURIK $+ virshURI defaultLibVirtLXCConfig+ , networkId = geto networkIdK $+ networkId defaultLibVirtLXCConfig+ , guestCapabilities = geto guestCapabilitiesK $+ guestCapabilities defaultLibVirtLXCConfig+ } initScript :: String initScript = "init.sh"@@ -239,8 +249,9 @@ renderGuestCapabilityEntries = unlines . map render . guestCapabilities where render :: LXCGuestCapability -> String- render cap = let capStr = toLower <$> drop (length "CAP_") (show cap)- in printf "<%s state='on'/>" capStr+ render cap =+ let capStr = toLower <$> drop (length "CAP_") (show cap)+ in printf "<%s state='on'/>" capStr osArch :: ExecEnv -> String osArch e = case cpuArch (envResources e) of@@ -260,17 +271,18 @@ Just mntXml -> "<filesystem type='file' accessmode='passthrough'>\n " ++ fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++- "\n</filesystem>"+ "\n</filesystem>" Nothing -> "" where fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" driver fmt' where- (driver, fmt') = case fmt of- Raw -> ("type='loop'", "format='raw'")- QCow2 -> ("type='nbd'", "format='qcow2'")- Vmdk -> ("type='nbd'", "format='vmdk'")+ (driver, fmt') =+ case fmt of+ Raw -> ("type='loop'", "format='raw'")+ QCow2 -> ("type='nbd'", "format='qcow2'")+ Vmdk -> ("type='nbd'", "format='vmdk'") fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>" @@ -302,11 +314,12 @@ memoryUnit = toUnit . maxMemory . envResources where toUnit AutomaticRamSize = toUnit lxcDefaultRamSize- toUnit (RamSize _ u) = case u of- GB -> "GiB"- MB -> "MiB"- KB -> "KiB"- B -> "B"+ toUnit (RamSize _ u) =+ case u of+ GB -> "GiB"+ MB -> "MiB"+ KB -> "KiB"+ B -> "B" memoryAmount :: ExecEnv -> String memoryAmount = show . toAmount . maxMemory . envResources where
src/lib/B9/MBR.hs view
@@ -41,7 +41,8 @@ , mbrPart2 :: !PrimaryPartition , mbrPart3 :: !PrimaryPartition , mbrPart4 :: !PrimaryPartition- } deriving Show+ }+ deriving Show data PrimaryPartition = PrimaryPartition { primPartStatus :: !Word8 , primPartChsStart :: !CHS@@ -49,19 +50,18 @@ , primPartChsEnd :: !CHS , primPartLbaStart :: !Word32 , primPartSectors :: !Word32- } deriving Show+ }+ deriving Show data CHS = CHS { chsH :: !Word8 , chs_CUpper2_S :: !Word8 , chs_CLower8 :: !Word8- } deriving Show+ }+ deriving Show getMBR :: Get MBR getMBR = skip bootCodeSize >>- MBR <$> getPart- <*> getPart- <*> getPart- <*> getPart+ MBR <$> getPart <*> getPart <*> getPart <*> getPart getPart :: Get PrimaryPartition getPart = PrimaryPartition <$> getWord8@@ -72,6 +72,4 @@ <*> getWord32le getCHS :: Get CHS-getCHS = CHS <$> getWord8- <*> getWord8- <*> getWord8+getCHS = CHS <$> getWord8 <*> getWord8 <*> getWord8
src/lib/B9/Vm.hs view
@@ -16,28 +16,30 @@ -- | Describe a virtual machine, i.e. a set up disk images to create and a shell -- script to put things together.-data VmScript = VmScript CPUArch [SharedDirectory] Script | NoVmScript+data VmScript = VmScript CPUArch [SharedDirectory] Script+ | NoVmScript deriving (Read, Show, Typeable, Data, Eq) substVmScript :: [(String,String)] -> VmScript -> VmScript-substVmScript env p = everywhere gsubst p- where gsubst :: forall a. Data a => a -> a- gsubst = mkT substMountPoint- `extT` substSharedDir- `extT` substScript+substVmScript env = everywhere gsubst+ where+ gsubst :: Data a => a -> a+ gsubst = mkT substMountPoint+ `extT` substSharedDir+ `extT` substScript - substMountPoint NotMounted = NotMounted- substMountPoint (MountPoint x) = MountPoint (sub x)+ substMountPoint NotMounted = NotMounted+ substMountPoint (MountPoint x) = MountPoint (sub x) - substSharedDir (SharedDirectory fp mp) =- SharedDirectory (sub fp) mp- substSharedDir (SharedDirectoryRO fp mp) =- SharedDirectoryRO (sub fp) mp- substSharedDir s = s+ substSharedDir (SharedDirectory fp mp) =+ SharedDirectory (sub fp) mp+ substSharedDir (SharedDirectoryRO fp mp) =+ SharedDirectoryRO (sub fp) mp+ substSharedDir s = s - substScript (In fp s) = In (sub fp) s- substScript (Run fp args) = Run (sub fp) (map sub args)- substScript (As fp s) = As (sub fp) s- substScript s = s+ substScript (In fp s) = In (sub fp) s+ substScript (Run fp args) = Run (sub fp) (map sub args)+ substScript (As fp s) = As (sub fp) s+ substScript s = s - sub = subst env+ sub = subst env