diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog for B9 +## 0.5.69.0 + +* Add new `ImageResize` option `ShrinkToMinimumAndIncrease` +* Remove the byte unit from `SizeUnit` +* Add new utility functions to `B9.DiskImages` for image size calculations + ## 0.5.68.3 * Fix issue #10: The CLI parameter `--network host` is ignored diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 2.2 name: b9 -version: 0.5.68.4 +version: 0.5.69.0 synopsis: A tool and library for building virtual machine images. @@ -67,6 +67,8 @@ , bytestring >= 0.10.8 , directory >= 1.3 , extensible-effects >= 5 && < 6 + , hspec + , hspec-expectations , lens >= 4 , text >= 1.2 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 @@ -22,24 +22,23 @@ , getSelectedRepos , pullRemoteRepos , pullLatestImage - ) -where + ) where +import B9.Artifact.Content.StringTemplate import B9.B9Config -import B9.BuildInfo +import B9.B9Error import B9.B9Exec import B9.B9Logging -import B9.B9Error import B9.B9Monad -import B9.Artifact.Content.StringTemplate +import B9.BuildInfo import B9.DiskImages import B9.Environment -import qualified B9.PartitionTable as P +import qualified B9.PartitionTable as P import B9.Repository import B9.RepositoryIO import Control.Eff import Control.Exception -import Control.Lens ( (^.) ) +import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class import Data.Function @@ -47,16 +46,14 @@ import Data.Generics.Schemes import Data.List import Data.Maybe +import GHC.Stack import System.Directory import System.FilePath -import System.IO.B9Extras ( consult - , ensureDir - , prettyPrintToFile - ) -import System.IO.Error ( isDoesNotExistError ) -import Text.Printf ( printf ) -import Text.Show.Pretty ( ppShow ) -import GHC.Stack +import System.IO.B9Extras (consult, ensureDir, + prettyPrintToFile) +import System.IO.Error (isDoesNotExistError) +import Text.Printf (printf) +import Text.Show.Pretty (ppShow) -- -- | Convert relative file paths of images, sources and mounted host directories -- -- to absolute paths relative to '_projectRoot'. @@ -67,78 +64,86 @@ -- go rootDir = everywhere mkAbs img -- where mkAbs = mkT -- | Replace $... variables inside an 'ImageTarget' -substImageTarget - :: forall e - . (HasCallStack, Member EnvironmentReader e, Member ExcB9 e) +substImageTarget :: + forall e. (HasCallStack, Member EnvironmentReader e, Member ExcB9 e) => ImageTarget -> Eff e ImageTarget substImageTarget = everywhereM gsubst - where - gsubst :: GenericM (Eff e) - gsubst = - mkM substMountPoint - `extM` substImage - `extM` substImageSource - `extM` substDiskTarget - substMountPoint NotMounted = pure NotMounted - substMountPoint (MountPoint x) = MountPoint <$> substStr x - substImage (Image fp t fs) = Image <$> substStr fp <*> pure t <*> pure fs - substImageSource (From n s) = From <$> substStr n <*> pure s - substImageSource (EmptyImage l f t s) = - EmptyImage <$> substStr l <*> pure f <*> pure t <*> pure s - substImageSource s = pure s - substDiskTarget (Share n t s) = Share <$> substStr n <*> pure t <*> pure s - substDiskTarget (LiveInstallerImage name outDir resize) = - LiveInstallerImage <$> substStr name <*> substStr outDir <*> pure resize - substDiskTarget s = pure s + where + gsubst :: GenericM (Eff e) + gsubst = + mkM substMountPoint `extM` substImage `extM` substImageSource `extM` + substDiskTarget + substMountPoint NotMounted = pure NotMounted + substMountPoint (MountPoint x) = MountPoint <$> substStr x + substImage (Image fp t fs) = Image <$> substStr fp <*> pure t <*> pure fs + substImageSource (From n s) = From <$> substStr n <*> pure s + substImageSource (EmptyImage l f t s) = + EmptyImage <$> substStr l <*> pure f <*> pure t <*> pure s + substImageSource s = pure s + substDiskTarget (Share n t s) = Share <$> substStr n <*> pure t <*> pure s + substDiskTarget (LiveInstallerImage name outDir resize) = + LiveInstallerImage <$> substStr name <*> substStr outDir <*> pure resize + substDiskTarget s = pure s -- | Resolve an ImageSource to an 'Image'. The ImageSource might -- not exist, as is the case for 'EmptyImage'. resolveImageSource :: IsB9 e => ImageSource -> Eff e 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 :: IsB9 e => ImageSource -> Eff e [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 :: HasCallStack => 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 :: HasCallStack => ImageResize -> [ImageType] -allowedImageTypesForResize r = case r of - Resize _ -> [Raw] - ShrinkToMinimum -> [Raw] - _ -> [Raw, QCow2, Vmdk] +allowedImageTypesForResize r = + case r of + Resize _ -> [Raw] + ShrinkToMinimumAndIncrease _ -> [Raw] + ShrinkToMinimum -> [Raw] + ResizeImage _ -> [Raw, QCow2, Vmdk] + KeepSize -> [Raw, QCow2, Vmdk] -- | Create the parent directories for the file that contains the 'Image'. -- If the path to the image file is relative, prepend '_projectRoot' from @@ -148,10 +153,9 @@ b9cfg <- getConfig let dir = let dirRel = takeDirectory path - in if isRelative dirRel - then - let prefix = fromMaybe "." (b9cfg ^. projectRoot) - in prefix dirRel + in if isRelative dirRel + then let prefix = fromMaybe "." (b9cfg ^. projectRoot) + in prefix dirRel else dirRel liftIO $ do createDirectoryIfMissing True dir @@ -162,84 +166,88 @@ -- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist. materializeImageSource :: IsB9 e => ImageSource -> Image -> Eff e () -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 - ) +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 - :: IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e () +createImageFromImage :: + IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e () createImageFromImage src part size out = do importImage src out extractPartition part out resizeImage size out - where - extractPartition :: IsB9 e => Partition -> Image -> Eff e () - 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) - ) + where + extractPartition :: IsB9 e => Partition -> Image -> Eff e () + 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 :: IsB9 e => Image -> ImageDestination -> Eff e () -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 - :: IsB9 e +createEmptyImage :: + IsB9 e => String -> FileSystem -> ImageType @@ -247,34 +255,34 @@ -> Image -> Eff e () 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 + qemuImgOpts = conversionOptions imgFmt dbgL - (printf "Creating empty raw image '%s' with size %s and options %s" - imgFile - (toQemuSizeOptVal imgSize) - qemuImgOpts - ) + (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) - ) + (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" @@ -284,43 +292,61 @@ 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) - ) + (imageType, fs) -> + error + (printf + "Cannot create file system %s in image type %s" + (show fs) + (show imageType)) createCOWImage :: IsB9 e => Image -> Image -> Eff e () 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) +resizeExtFS :: (IsB9 e) => ImageSize -> FilePath -> Eff e () +resizeExtFS newSize img = 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) + +shrinkToMinimumExtFS :: (IsB9 e) => FilePath -> Eff e () +shrinkToMinimumExtFS img = do + dbgL "Shrinking image to minimum size" + cmd (printf "e2fsck -p '%s'" img) + cmd (printf "resize2fs -f -M '%s'" img) + -- | Resize an image, including the file system inside the image. resizeImage :: IsB9 e => ImageResize -> Image -> Eff e () 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 = resizeExtFS newSize img +resizeImage (ShrinkToMinimumAndIncrease sizeIncrease) (Image img Raw fs) + | fs == Ext4 || fs == Ext4_64 = do + shrinkToMinimumExtFS img + fileSize <- liftIO (getFileSize img) + let newSize = + addImageSize + (bytesToKiloBytes (fromInteger fileSize)) + sizeIncrease + resizeExtFS newSize img 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 _ img = error - (printf "Invalid image type or filesystem, cannot resize image: %s" (show img) - ) +resizeImage ShrinkToMinimum (Image img Raw fs) + | fs == Ext4 || fs == Ext4_64 = shrinkToMinimumExtFS 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. @@ -356,20 +382,20 @@ | otherwise = do ensureDir imgOut dbgL - (printf "Converting %s to %s: '%s' to '%s'" - (imageFileExtension fmtIn) - (imageFileExtension fmtOut) - imgIn - imgOut - ) + (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 - ) + (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) @@ -380,11 +406,12 @@ conversionOptions _ = " " toQemuSizeOptVal :: ImageSize -> String -toQemuSizeOptVal (ImageSize amount u) = show amount ++ case u of - GB -> "G" - MB -> "M" - KB -> "K" - B -> "" +toQemuSizeOptVal (ImageSize amount u) = + show amount ++ + case u of + GB -> "G" + MB -> "M" + KB -> "K" -- | Publish an sharedImage made from an image and image meta data to the -- configured repository @@ -397,28 +424,28 @@ -- | Return a 'SharedImage' with the current build data and build id from the -- name and disk image. -getSharedImageFromImageInfo - :: IsB9 e => SharedImageName -> Image -> Eff e SharedImage +getSharedImageFromImageInfo :: + IsB9 e => SharedImageName -> Image -> Eff e SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do buildId <- getBuildId - date <- getBuildDate + date <- getBuildDate return - (SharedImage name - (SharedImageDate date) - (SharedImageBuildId buildId) - imgType - imgFS - ) + (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@ -- also delete all but the @n - 1@ newest images from the local cache. -createSharedImageInCache - :: IsB9 e => Image -> SharedImageName -> Eff e SharedImage +createSharedImageInCache :: + IsB9 e => Image -> SharedImageName -> Eff e SharedImage 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)) @@ -429,18 +456,18 @@ -- selected repository from the cache. pushSharedImageLatestVersion :: IsB9 e => SharedImageName -> Eff e () pushSharedImageLatestVersion name@(SharedImageName imgName) = - getLatestSharedImageByNameFromCache name >>= maybe + 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) - ) + 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 :: IsB9 e => SharedImage -> Eff e () pushToSelectedRepo i = do - c <- getSharedImagesCacheDir + c <- getSharedImagesCacheDir MkSelectedRemoteRepo r <- getSelectedRemoteRepo when (isJust r) $ do let (Image imgFile' _imgType _imgFS) = sharedImageImage i @@ -448,7 +475,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. @@ -456,9 +483,11 @@ pullRemoteRepos = do 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. @@ -475,22 +504,20 @@ then do errorL (printf - "No shared image named '%s' on these remote repositories: '%s'" - dbgName - (ppShow repoIds) - ) + "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,7 +528,7 @@ getLatestImageByName :: IsB9 e => SharedImageName -> Eff e (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)) @@ -509,57 +536,60 @@ return image -- | Return the latest version of a shared image named 'name' from the local cache. -getLatestSharedImageByNameFromCache - :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImage) +getLatestSharedImageByNameFromCache :: + IsB9 e => SharedImageName -> Eff e (Maybe SharedImage) 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 :: IsB9 e => Eff e [(Repository, [SharedImage])] getSharedImages = do - 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) + 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) -- | Find shared images and the associated repos from two predicates. The result -- is the concatenated result of the sorted shared images satisfying 'imgPred'. -lookupSharedImages - :: IsB9 e +lookupSharedImages :: + IsB9 e => (Repository -> Bool) -> (SharedImage -> Bool) -> Eff e [(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 :: IsB9 e => Eff e [RemoteRepo] getSelectedRepos = do - allRepos <- getRemoteRepos + allRepos <- getRemoteRepos MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo return repos @@ -579,24 +609,26 @@ b9Cfg <- getConfig forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do toDelete <- take maxRevisions <$> newestSharedImages - imgDir <- getSharedImagesCacheDir + imgDir <- getSharedImagesCacheDir let filesToDelete = (imgDir ) <$> (infoFiles ++ imgFiles) - infoFiles = sharedImageFileName <$> toDelete - imgFiles = imageFileName . sharedImageImage <$> toDelete + 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 + (printf + "DELETING %d OBSOLETE REVISIONS OF: %s" + (length filesToDelete) + (show sn)) + mapM_ traceL filesToDelete mapM_ removeIfExists filesToDelete - where - newestSharedImages :: IsB9 e => Eff e [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 + where + newestSharedImages :: IsB9 e => Eff e [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 + diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs --- a/src/lib/B9/DiskImages.hs +++ b/src/lib/B9/DiskImages.hs @@ -14,6 +14,7 @@ import Test.QuickCheck import qualified Text.PrettyPrint.Boxes as Boxes import Text.Printf +import Test.Hspec (Spec, describe, it) -- * Data types for disk image description, e.g. 'ImageTarget', -- 'ImageDestination', 'Image', 'MountPoint', 'SharedImage' @@ -124,11 +125,45 @@ instance Binary ImageSize instance NFData ImageSize +-- | Convert a size in bytes to an 'ImageSize' +bytesToKiloBytes :: Int -> ImageSize +bytesToKiloBytes x = let kbRoundedDown = x `div` 1024 + rest = x `mod` 1024 + kbRoundedUp = if rest > 0 then kbRoundedDown + 1 else kbRoundedDown + in ImageSize kbRoundedUp KB + +-- | Convert an 'ImageSize' to kibi bytes. +imageSizeToKiB :: ImageSize -> Int +imageSizeToKiB (ImageSize size unit) = + size * sizeUnitKiB unit + +-- | Convert a 'SizeUnit' to the number of kibi bytes one element represents. +sizeUnitKiB :: SizeUnit -> Int +sizeUnitKiB GB = 1024 * sizeUnitKiB MB +sizeUnitKiB MB = 1024 * sizeUnitKiB KB +sizeUnitKiB KB = 1 + +-- | Choose the greatest unit possible to exactly represent an 'ImageSize'. +normalizeSize :: ImageSize -> ImageSize +normalizeSize i@(ImageSize _ GB) = i +normalizeSize i@(ImageSize size unit) + | size `mod` 1024 == 0 = + normalizeSize (ImageSize (size `div` 1024) (succ unit)) + | otherwise = i + +-- | Return the sum of two @'ImageSize's@. +addImageSize :: ImageSize -> ImageSize -> ImageSize +-- of course we could get more fancy, but is it really needed? The file size will always be bytes ... +addImageSize (ImageSize value unit) (ImageSize value' unit') = + normalizeSize + (ImageSize (value * sizeUnitKiB unit + value' * sizeUnitKiB unit') KB) + + -- | Enumeration of size multipliers. The exact semantics may vary depending on -- what external tools look at these. E.g. the size unit is convert to a size -- parameter of the @qemu-img@ command line tool. -data SizeUnit = B | KB | MB | GB - deriving (Eq, Show, Read, Ord, Typeable, Data, Generic) +data SizeUnit = KB | MB | GB + deriving (Eq, Show, Read, Ord, Enum, Bounded, Typeable, Data, Generic) instance Hashable SizeUnit instance Binary SizeUnit @@ -143,6 +178,8 @@ -- 'Resize'. | Resize ImageSize -- ^ Resize an image and the contained file system. + | ShrinkToMinimumAndIncrease ImageSize + -- ^ Shrink to minimum size needed and increase by the amount given. | ShrinkToMinimum -- ^ Resize an image and the contained file system to the -- smallest size to fit the contents of the file system. @@ -202,12 +239,12 @@ fromSharedImageBuildId :: SharedImageBuildId -> String fromSharedImageBuildId (SharedImageBuildId b) = b --- | Shared images are orderd by name, build date and build id +-- | Shared images are ordered by name, build date and build id instance Ord SharedImage where compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) = compare n n' Sem.<> compare d d' Sem.<> compare b b' --- * Constroctor and accessors for 'Image' 'ImageTarget' 'ImageSource' +-- * Constructor and accessors for 'Image' 'ImageTarget' 'ImageSource' -- 'ImageDestination' and 'SharedImage' -- | Return the name of the file corresponding to an 'Image' @@ -219,7 +256,7 @@ imageImageType (Image _ t _) = t -- | Return the files generated for a 'LocalFile' or a 'LiveInstallerImage'; 'SharedImage' and 'Transient' --- are treated like they have no ouput files because the output files are manged +-- are treated like they have no output files because the output files are manged -- by B9. getImageDestinationOutputFiles :: ImageTarget -> [FilePath] getImageDestinationOutputFiles (ImageTarget d _ _) = case d of @@ -254,13 +291,13 @@ itImageMountPoint (ImageTarget _ _ m) = m --- | Return true if a 'Partition' parameter is actually refering to a partition, +-- | Return true if a 'Partition' parameter is actually referring to a partition, -- false if it is 'NoPT' isPartitioned :: Partition -> Bool isPartitioned p | p == NoPT = False | otherwise = True --- | Return the 'Partition' index or throw a runtime error if aplied to 'NoPT' +-- | Return the 'Partition' index or throw a runtime error if applied to 'NoPT' getPartition :: Partition -> Int getPartition (Partition p) = p getPartition NoPT = error "No partitions!" @@ -475,6 +512,7 @@ arbitrary = oneof [ ResizeImage <$> smaller arbitrary , Resize <$> smaller arbitrary + , ShrinkToMinimumAndIncrease <$> smaller arbitrary , pure ShrinkToMinimum , pure KeepSize ] @@ -496,7 +534,7 @@ arbitrary = ImageSize <$> smaller arbitrary <*> smaller arbitrary instance Arbitrary SizeUnit where - arbitrary = elements [B, KB, MB, GB] + arbitrary = elements [KB, MB, GB] instance Arbitrary SharedImageName where arbitrary = SharedImageName <$> arbitrarySharedImageName @@ -504,3 +542,14 @@ arbitrarySharedImageName :: Gen String arbitrarySharedImageName = elements [ printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3] ] + +unitTests :: Spec +unitTests = + describe "ImageSize" $ + describe "bytesToKiloBytes" $ do + it "accepts maxBound" $ + toInteger (imageSizeToKiB (bytesToKiloBytes maxBound)) * 1024 === toInteger (maxBound :: Int) + 1 + it "doesn't decrease in size" $ + property + (\(x :: Int) -> + x <= maxBound - 1024 ==> label "bytesToKiloBytes x >= x" (imageSizeToKiB (bytesToKiloBytes x) >= (x `div` 1024))) 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 @@ -225,7 +225,6 @@ GB -> "GiB" MB -> "MiB" KB -> "KiB" - B -> "B" memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String memoryAmount cfg = show . toAmount . maxMemory . envResources diff --git a/src/tests/B9/DiskImagesSpec.hs b/src/tests/B9/DiskImagesSpec.hs --- a/src/tests/B9/DiskImagesSpec.hs +++ b/src/tests/B9/DiskImagesSpec.hs @@ -6,25 +6,28 @@ spec :: Spec spec = + describe "DiskImages" $ do describe "splitToIntermediateSharedImage" $ - do it "puts the original source into the intermediate target" $ - property - (\target name -> - itImageSource target == - itImageSource - (fst (splitToIntermediateSharedImage target name))) - it "puts the original destination into the export target" $ - property - (\target name -> - itImageDestination target == - itImageDestination - (snd (splitToIntermediateSharedImage target name))) - it - "puts the intermediate shared image name into both the intermediate and the export target" $ - property - (\target name -> - let (intermediateTarget,exportTarget) = - splitToIntermediateSharedImage target name - in imageDestinationSharedImageName - (itImageDestination intermediateTarget) == - imageSourceSharedImageName (itImageSource exportTarget)) + do it "puts the original source into the intermediate target" $ + property + (\target name -> + itImageSource target == + itImageSource + (fst (splitToIntermediateSharedImage target name))) + it "puts the original destination into the export target" $ + property + (\target name -> + itImageDestination target == + itImageDestination + (snd (splitToIntermediateSharedImage target name))) + it + "puts the intermediate shared image name into both the intermediate and the export target" $ + property + (\target name -> + let (intermediateTarget,exportTarget) = + splitToIntermediateSharedImage target name + in imageDestinationSharedImageName + (itImageDestination intermediateTarget) == + imageSourceSharedImageName (itImageSource exportTarget)) + context "inline unit tests" + unitTests