diff --git a/.gitignore b/.gitignore
--- a/.gitignore
+++ b/.gitignore
@@ -12,3 +12,7 @@
/cabal.sandbox.config
/upload_doc.sh
+# Intellij IDEA
+/.idea/
+*.iml
+
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/TODO.org b/TODO.org
--- a/TODO.org
+++ b/TODO.org
@@ -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
diff --git a/b9.cabal b/b9.cabal
--- a/b9.cabal
+++ b/b9.cabal
@@ -1,5 +1,5 @@
name: b9
-version: 0.2.5
+version: 0.3.0
synopsis: A tool and library for building virtual machine images.
diff --git a/src/cli/Main.hs b/src/cli/Main.hs
--- a/src/cli/Main.hs
+++ b/src/cli/Main.hs
@@ -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' }
diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs
--- a/src/lib/B9/B9Config.hs
+++ b/src/lib/B9/B9Config.hs
@@ -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
diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs
--- a/src/lib/B9/B9Monad.hs
+++ b/src/lib/B9/B9Monad.hs
@@ -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
diff --git a/src/lib/B9/Content/StringTemplate.hs b/src/lib/B9/Content/StringTemplate.hs
--- a/src/lib/B9/Content/StringTemplate.hs
+++ b/src/lib/B9/Content/StringTemplate.hs
@@ -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
diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs
--- a/src/lib/B9/DiskImageBuilder.hs
+++ b/src/lib/B9/DiskImageBuilder.hs
@@ -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
diff --git a/src/lib/B9/ExecEnv.hs b/src/lib/B9/ExecEnv.hs
--- a/src/lib/B9/ExecEnv.hs
+++ b/src/lib/B9/ExecEnv.hs
@@ -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'
diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs
--- a/src/lib/B9/LibVirtLXC.hs
+++ b/src/lib/B9/LibVirtLXC.hs
@@ -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 ->
"\n " ++
fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++
- "\n"
+ "\n"
Nothing ->
""
where
fsImgDriver (Image _img fmt _fs) =
printf "" 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) = ""
@@ -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
diff --git a/src/lib/B9/MBR.hs b/src/lib/B9/MBR.hs
--- a/src/lib/B9/MBR.hs
+++ b/src/lib/B9/MBR.hs
@@ -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
diff --git a/src/lib/B9/Vm.hs b/src/lib/B9/Vm.hs
--- a/src/lib/B9/Vm.hs
+++ b/src/lib/B9/Vm.hs
@@ -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