b9 0.5.68.4 → 0.5.69.0

raw patch · 6 files changed

+412/−321 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• b9.cabal +4/−2
• src/lib/B9/DiskImageBuilder.hs +321/−289
• src/lib/B9/DiskImages.hs +57/−8
• src/lib/B9/LibVirtLXC.hs +0/−1
• src/tests/B9/DiskImagesSpec.hs +24/−21

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

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

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

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

@@ -225,7 +225,6 @@     GB -> "GiB"     MB -> "MiB"     KB -> "KiB"-    B  -> "B"  memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String memoryAmount cfg = show . toAmount . maxMemory . envResources

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