{-# LANGUAGE ScopedTypeVariables #-}

-- | Effectful functions that create and convert disk image files.
module B9.DiskImageBuilder
  ( materializeImageSource,
    substImageTarget,
    preferredDestImageTypes,
    preferredSourceImageTypes,
    resolveImageSource,
    createDestinationImage,
    resizeImage,
    importImage,
    exportImage,
    exportAndRemoveImage,
    convertImage,
    shareImage,
    ensureAbsoluteImageDirExists,
    getVirtualSizeForRawImage
  )
where

import B9.Artifact.Content.StringTemplate
import B9.B9Config
import B9.B9Error
import B9.B9Exec
import B9.B9Logging
import B9.B9Monad
import B9.BuildInfo
import B9.DiskImages
import B9.Environment
import qualified B9.PartitionTable as P
import B9.RepositoryIO
import Control.Eff
import qualified Control.Exception as IO
import Control.Lens (view, (^.))
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as Strict
import Data.Char (isDigit)
import Data.Generics.Aliases
import Data.Generics.Schemes
import Data.List
import Data.Maybe
import qualified Foreign.C.Error as IO
import qualified GHC.IO.Exception as IO
import GHC.Stack
import System.Directory
import System.FilePath
import System.IO.B9Extras
  ( ensureDir,
    prettyPrintToFile,
  )
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'.
-- makeImagePathsAbsoluteToBuildDirRoot :: ImageTarget -> B9 ImageTarget
-- makeImagePathsAbsoluteToBuildDirRoot img =
--   getConfig >>= maybe (return img) (return . go) . _projectRoot
--   where
--     go rootDir = everywhere mkAbs img
--       where mkAbs = mkT

-- | Replace $... variables inside an 'ImageTarget'
substImageTarget ::
  forall e.
  (HasCallStack, Member EnvironmentReader e, Member ExcB9 e) =>
  ImageTarget ->
  Eff e ImageTarget
substImageTarget :: ImageTarget -> Eff e ImageTarget
substImageTarget = GenericM (Eff e) -> GenericM (Eff e)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM GenericM (Eff e)
gsubst
  where
    gsubst :: GenericM (Eff e)
    gsubst :: a -> Eff e a
gsubst =
      (MountPoint -> Eff e MountPoint) -> a -> Eff e a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM MountPoint -> Eff e MountPoint
forall (e :: [* -> *]).
(FindElem (Exc SomeException) e,
 FindElem (Reader Environment) e) =>
MountPoint -> Eff e MountPoint
substMountPoint (a -> Eff e a) -> (Image -> Eff e Image) -> a -> Eff e a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Image -> Eff e Image
forall (e :: [* -> *]).
(FindElem (Exc SomeException) e,
 FindElem (Reader Environment) e) =>
Image -> Eff e Image
substImage (a -> Eff e a)
-> (ImageSource -> Eff e ImageSource) -> a -> Eff e a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` ImageSource -> Eff e ImageSource
forall (e :: [* -> *]).
(FindElem (Exc SomeException) e,
 FindElem (Reader Environment) e) =>
ImageSource -> Eff e ImageSource
substImageSource
        (a -> Eff e a)
-> (ImageDestination -> Eff e ImageDestination) -> a -> Eff e a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` ImageDestination -> Eff e ImageDestination
forall (e :: [* -> *]).
(FindElem (Exc SomeException) e,
 FindElem (Reader Environment) e) =>
ImageDestination -> Eff e ImageDestination
substDiskTarget
    substMountPoint :: MountPoint -> Eff e MountPoint
substMountPoint MountPoint
NotMounted = MountPoint -> Eff e MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
NotMounted
    substMountPoint (MountPoint FilePath
x) = FilePath -> MountPoint
MountPoint (FilePath -> MountPoint) -> Eff e FilePath -> Eff e MountPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
x
    substImage :: Image -> Eff e Image
substImage (Image FilePath
fp ImageType
t FileSystem
fs) = FilePath -> ImageType -> FileSystem -> Image
Image (FilePath -> ImageType -> FileSystem -> Image)
-> Eff e FilePath -> Eff e (ImageType -> FileSystem -> Image)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
fp Eff e (ImageType -> FileSystem -> Image)
-> Eff e ImageType -> Eff e (FileSystem -> Image)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageType -> Eff e ImageType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageType
t Eff e (FileSystem -> Image) -> Eff e FileSystem -> Eff e Image
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FileSystem -> Eff e FileSystem
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileSystem
fs
    substImageSource :: ImageSource -> Eff e ImageSource
substImageSource (From FilePath
n ImageResize
s) = FilePath -> ImageResize -> ImageSource
From (FilePath -> ImageResize -> ImageSource)
-> Eff e FilePath -> Eff e (ImageResize -> ImageSource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
n Eff e (ImageResize -> ImageSource)
-> Eff e ImageResize -> Eff e ImageSource
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageResize -> Eff e ImageResize
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageResize
s
    substImageSource (EmptyImage FilePath
l FileSystem
f ImageType
t ImageSize
s) =
      FilePath -> FileSystem -> ImageType -> ImageSize -> ImageSource
EmptyImage (FilePath -> FileSystem -> ImageType -> ImageSize -> ImageSource)
-> Eff e FilePath
-> Eff e (FileSystem -> ImageType -> ImageSize -> ImageSource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
l Eff e (FileSystem -> ImageType -> ImageSize -> ImageSource)
-> Eff e FileSystem
-> Eff e (ImageType -> ImageSize -> ImageSource)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FileSystem -> Eff e FileSystem
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileSystem
f Eff e (ImageType -> ImageSize -> ImageSource)
-> Eff e ImageType -> Eff e (ImageSize -> ImageSource)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageType -> Eff e ImageType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageType
t Eff e (ImageSize -> ImageSource)
-> Eff e ImageSize -> Eff e ImageSource
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageSize -> Eff e ImageSize
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageSize
s
    substImageSource ImageSource
s = ImageSource -> Eff e ImageSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageSource
s
    substDiskTarget :: ImageDestination -> Eff e ImageDestination
substDiskTarget (Share FilePath
n ImageType
t ImageResize
s) = FilePath -> ImageType -> ImageResize -> ImageDestination
Share (FilePath -> ImageType -> ImageResize -> ImageDestination)
-> Eff e FilePath
-> Eff e (ImageType -> ImageResize -> ImageDestination)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
n Eff e (ImageType -> ImageResize -> ImageDestination)
-> Eff e ImageType -> Eff e (ImageResize -> ImageDestination)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageType -> Eff e ImageType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageType
t Eff e (ImageResize -> ImageDestination)
-> Eff e ImageResize -> Eff e ImageDestination
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageResize -> Eff e ImageResize
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageResize
s
    substDiskTarget (LiveInstallerImage FilePath
name FilePath
outDir ImageResize
resize) =
      FilePath -> FilePath -> ImageResize -> ImageDestination
LiveInstallerImage (FilePath -> FilePath -> ImageResize -> ImageDestination)
-> Eff e FilePath
-> Eff e (FilePath -> ImageResize -> ImageDestination)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
name Eff e (FilePath -> ImageResize -> ImageDestination)
-> Eff e FilePath -> Eff e (ImageResize -> ImageDestination)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Eff e FilePath
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Member (Reader Environment) e) =>
FilePath -> Eff e FilePath
substStr FilePath
outDir Eff e (ImageResize -> ImageDestination)
-> Eff e ImageResize -> Eff e ImageDestination
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImageResize -> Eff e ImageResize
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageResize
resize
    substDiskTarget ImageDestination
s = ImageDestination -> Eff e ImageDestination
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageDestination
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 :: ImageSource -> Eff e Image
resolveImageSource ImageSource
src =
  case ImageSource
src of
    (EmptyImage FilePath
fsLabel FileSystem
fsType ImageType
imgType ImageSize
_size) ->
      let img :: Image
img = FilePath -> ImageType -> FileSystem -> Image
Image FilePath
fsLabel ImageType
imgType FileSystem
fsType
       in Image -> Eff e Image
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageType -> Image -> Image
changeImageFormat ImageType
imgType Image
img)
    (SourceImage Image
srcImg Partition
_part ImageResize
_resize) -> Image -> Eff e Image
forall (e :: [* -> *]). IsB9 e => Image -> Eff e Image
ensureAbsoluteImageDirExists Image
srcImg
    (CopyOnWrite Image
backingImg) -> Image -> Eff e Image
forall (e :: [* -> *]). IsB9 e => Image -> Eff e Image
ensureAbsoluteImageDirExists Image
backingImg
    (From FilePath
name ImageResize
_resize) ->
      SharedImageName -> Eff e (Maybe Image)
forall (e :: [* -> *]).
(HasCallStack, Lifted IO e, CommandIO e,
 Member RepoCacheReader e) =>
SharedImageName -> Eff e (Maybe Image)
getLatestImageByName (FilePath -> SharedImageName
SharedImageName FilePath
name)
        Eff e (Maybe Image) -> (Maybe Image -> Eff e Image) -> Eff e Image
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff e Image -> (Image -> Eff e Image) -> Maybe Image -> Eff e Image
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( FilePath -> Eff e Image
forall (e :: [* -> *]) a.
(CommandIO e, Member (Exc SomeException) e) =>
FilePath -> Eff e a
errorExitL
              (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Nothing found for %s." (SharedImageName -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> SharedImageName
SharedImageName FilePath
name)))
          )
          Image -> Eff e Image
forall (e :: [* -> *]). IsB9 e => Image -> Eff e Image
ensureAbsoluteImageDirExists

-- | Return all valid image types sorted by preference.
preferredDestImageTypes :: IsB9 e => ImageSource -> Eff e [ImageType]
preferredDestImageTypes :: ImageSource -> Eff e [ImageType]
preferredDestImageTypes ImageSource
src =
  case ImageSource
src of
    (CopyOnWrite (Image FilePath
_file ImageType
fmt FileSystem
_fs)) -> [ImageType] -> Eff e [ImageType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ImageType
fmt]
    (EmptyImage FilePath
_label FileSystem
NoFileSystem ImageType
fmt ImageSize
_size) ->
      [ImageType] -> Eff e [ImageType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a]
nub [ImageType
fmt, ImageType
Raw, ImageType
QCow2, ImageType
Vmdk])
    (EmptyImage FilePath
_label FileSystem
_fs ImageType
_fmt ImageSize
_size) -> [ImageType] -> Eff e [ImageType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ImageType
Raw]
    (SourceImage Image
_img (Partition Int
_) ImageResize
_resize) -> [ImageType] -> Eff e [ImageType]
forall (m :: * -> *) a. Monad m => a -> m a
return [ImageType
Raw]
    (SourceImage (Image FilePath
_file ImageType
fmt FileSystem
_fs) Partition
_pt ImageResize
resize) ->
      [ImageType] -> Eff e [ImageType]
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a]
nub [ImageType
fmt, ImageType
Raw, ImageType
QCow2, ImageType
Vmdk]
            [ImageType] -> [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` HasCallStack => ImageResize -> [ImageType]
ImageResize -> [ImageType]
allowedImageTypesForResize ImageResize
resize
        )
    (From FilePath
name ImageResize
resize) ->
      SharedImageName -> Eff e (Maybe Image)
forall (e :: [* -> *]).
(HasCallStack, Lifted IO e, CommandIO e,
 Member RepoCacheReader e) =>
SharedImageName -> Eff e (Maybe Image)
getLatestImageByName (FilePath -> SharedImageName
SharedImageName FilePath
name)
        Eff e (Maybe Image)
-> (Maybe Image -> Eff e [ImageType]) -> Eff e [ImageType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff e [ImageType]
-> (Image -> Eff e [ImageType]) -> Maybe Image -> Eff e [ImageType]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( FilePath -> Eff e [ImageType]
forall (e :: [* -> *]) a.
(CommandIO e, Member (Exc SomeException) e) =>
FilePath -> Eff e a
errorExitL
              (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Nothing found for %s." (SharedImageName -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> SharedImageName
SharedImageName FilePath
name)))
          )
          ( \Image
sharedImg ->
              ImageSource -> Eff e [ImageType]
forall (e :: [* -> *]). IsB9 e => ImageSource -> Eff e [ImageType]
preferredDestImageTypes (Image -> Partition -> ImageResize -> ImageSource
SourceImage Image
sharedImg Partition
NoPT ImageResize
resize)
          )

-- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion'
-- in the preferred order.
preferredSourceImageTypes :: HasCallStack => ImageDestination -> [ImageType]
preferredSourceImageTypes :: ImageDestination -> [ImageType]
preferredSourceImageTypes ImageDestination
dest =
  case ImageDestination
dest of
    (Share FilePath
_ ImageType
fmt ImageResize
resize) ->
      [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a]
nub [ImageType
fmt, ImageType
Raw, ImageType
QCow2, ImageType
Vmdk] [ImageType] -> [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` HasCallStack => ImageResize -> [ImageType]
ImageResize -> [ImageType]
allowedImageTypesForResize ImageResize
resize
    (LocalFile (Image FilePath
_ ImageType
fmt FileSystem
_) ImageResize
resize) ->
      [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a]
nub [ImageType
fmt, ImageType
Raw, ImageType
QCow2, ImageType
Vmdk] [ImageType] -> [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` HasCallStack => ImageResize -> [ImageType]
ImageResize -> [ImageType]
allowedImageTypesForResize ImageResize
resize
    ImageDestination
Transient -> [ImageType
Raw, ImageType
QCow2, ImageType
Vmdk]
    (LiveInstallerImage FilePath
_name FilePath
_repo ImageResize
_imgResize) -> [ImageType
Raw]

allowedImageTypesForResize :: HasCallStack => ImageResize -> [ImageType]
allowedImageTypesForResize :: ImageResize -> [ImageType]
allowedImageTypesForResize ImageResize
r =
  case ImageResize
r of
    Resize ImageSize
_ -> [ImageType
Raw]
    ShrinkToMinimumAndIncrease ImageSize
_ -> [ImageType
Raw]
    ImageResize
ShrinkToMinimum -> [ImageType
Raw]
    ResizeImage ImageSize
_ -> [ImageType
Raw, ImageType
QCow2, ImageType
Vmdk]
    ImageResize
KeepSize -> [ImageType
Raw, ImageType
QCow2, ImageType
Vmdk]

-- | Create the parent directories for the file that contains the 'Image'.
-- If the path to the image file is relative, prepend '_projectRoot' from
-- the 'B9Config'.
ensureAbsoluteImageDirExists :: IsB9 e => Image -> Eff e Image
ensureAbsoluteImageDirExists :: Image -> Eff e Image
ensureAbsoluteImageDirExists img :: Image
img@(Image FilePath
path ImageType
_ FileSystem
_) = do
  B9Config
b9cfg <- Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getConfig
  let dir :: FilePath
dir =
        let dirRel :: FilePath
dirRel = FilePath -> FilePath
takeDirectory FilePath
path
         in if FilePath -> Bool
isRelative FilePath
dirRel
              then
                let prefix :: FilePath
prefix = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"." (B9Config
b9cfg B9Config
-> Getting (Maybe FilePath) B9Config (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^. Getting (Maybe FilePath) B9Config (Maybe FilePath)
Lens' B9Config (Maybe FilePath)
projectRoot)
                 in FilePath
prefix FilePath -> FilePath -> FilePath
</> FilePath
dirRel
              else FilePath
dirRel
  IO Image -> Eff e Image
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Image -> Eff e Image) -> IO Image -> Eff e Image
forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
    FilePath
dirAbs <- FilePath -> IO FilePath
canonicalizePath FilePath
dir
    Image -> IO Image
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> IO Image) -> Image -> IO Image
forall a b. (a -> b) -> a -> b
$ FilePath -> Image -> Image
changeImageDirectory FilePath
dirAbs Image
img

-- | Create an image from an image source. The destination image must have a
-- 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 :: ImageSource -> Image -> Eff e ()
materializeImageSource ImageSource
src Image
dest =
  case ImageSource
src of
    (EmptyImage FilePath
fsLabel FileSystem
fsType ImageType
_imgType ImageSize
size) ->
      let (Image FilePath
_ ImageType
imgType FileSystem
_) = Image
dest
       in FilePath
-> FileSystem -> ImageType -> ImageSize -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
FilePath
-> FileSystem -> ImageType -> ImageSize -> Image -> Eff e ()
createEmptyImage FilePath
fsLabel FileSystem
fsType ImageType
imgType ImageSize
size Image
dest
    (SourceImage Image
srcImg Partition
part ImageResize
resize) ->
      Image -> Partition -> ImageResize -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Image -> Partition -> ImageResize -> Image -> Eff e ()
createImageFromImage Image
srcImg Partition
part ImageResize
resize Image
dest
    (CopyOnWrite Image
backingImg) -> Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
createCOWImage Image
backingImg Image
dest
    (From FilePath
name ImageResize
resize) ->
      SharedImageName -> Eff e (Maybe Image)
forall (e :: [* -> *]).
(HasCallStack, Lifted IO e, CommandIO e,
 Member RepoCacheReader e) =>
SharedImageName -> Eff e (Maybe Image)
getLatestImageByName (FilePath -> SharedImageName
SharedImageName FilePath
name)
        Eff e (Maybe Image) -> (Maybe Image -> Eff e ()) -> Eff e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff e () -> (Image -> Eff e ()) -> Maybe Image -> Eff e ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( FilePath -> Eff e ()
forall (e :: [* -> *]) a.
(CommandIO e, Member (Exc SomeException) e) =>
FilePath -> Eff e a
errorExitL
              (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Nothing found for %s." (SharedImageName -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> SharedImageName
SharedImageName FilePath
name)))
          )
          ( \Image
sharedImg ->
              ImageSource -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageSource -> Image -> Eff e ()
materializeImageSource (Image -> Partition -> ImageResize -> ImageSource
SourceImage Image
sharedImg Partition
NoPT ImageResize
resize) Image
dest
          )

createImageFromImage ::
  IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e ()
createImageFromImage :: Image -> Partition -> ImageResize -> Image -> Eff e ()
createImageFromImage Image
src Partition
part ImageResize
size Image
out = do
  Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
importImage Image
src Image
out
  Partition -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Partition -> Image -> Eff e ()
extractPartition Partition
part Image
out
  ImageResize -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageResize -> Image -> Eff e ()
resizeImage ImageResize
size Image
out
  where
    extractPartition :: IsB9 e => Partition -> Image -> Eff e ()
    extractPartition :: Partition -> Image -> Eff e ()
extractPartition Partition
NoPT Image
_ = () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    extractPartition (Partition Int
partIndex) (Image FilePath
outFile ImageType
Raw FileSystem
_) = do
      (Word64
start, Word64
len, Word64
blockSize) <- IO (Word64, Word64, Word64) -> Eff e (Word64, Word64, Word64)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> FilePath -> IO (Word64, Word64, Word64)
P.getPartition Int
partIndex FilePath
outFile)
      let tmpFile :: FilePath
tmpFile = FilePath
outFile FilePath -> FilePath -> FilePath
<.> FilePath
"extracted"
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> Int -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Extracting partition %i from '%s'" Int
partIndex FilePath
outFile)
      FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd
        ( FilePath
-> FilePath -> FilePath -> Word64 -> Word64 -> Word64 -> FilePath
forall r. PrintfType r => FilePath -> r
printf
            FilePath
"dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"
            FilePath
outFile
            FilePath
tmpFile
            Word64
blockSize
            Word64
start
            Word64
len
        )
      FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"mv '%s' '%s'" FilePath
tmpFile FilePath
outFile)
    extractPartition (Partition Int
partIndex) (Image FilePath
outFile ImageType
fmt FileSystem
_) =
      FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error
        ( FilePath -> Int -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
            FilePath
"Extract partition %i from image '%s': Invalid format %s"
            Int
partIndex
            FilePath
outFile
            (ImageType -> FilePath
imageFileExtension ImageType
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 :: Image -> ImageDestination -> Eff e ()
createDestinationImage Image
buildImg ImageDestination
dest =
  case ImageDestination
dest of
    (Share FilePath
name ImageType
imgType ImageResize
imgResize) -> do
      ImageResize -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageResize -> Image -> Eff e ()
resizeImage ImageResize
imgResize Image
buildImg
      let shareableImg :: Image
shareableImg = ImageType -> Image -> Image
changeImageFormat ImageType
imgType Image
buildImg
      Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
exportAndRemoveImage Image
buildImg Image
shareableImg
      Eff e SharedImage -> Eff e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Image -> SharedImageName -> Eff e SharedImage
forall (e :: [* -> *]).
IsB9 e =>
Image -> SharedImageName -> Eff e SharedImage
shareImage Image
shareableImg (FilePath -> SharedImageName
SharedImageName FilePath
name))
    (LocalFile Image
destImg ImageResize
imgResize) -> do
      ImageResize -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageResize -> Image -> Eff e ()
resizeImage ImageResize
imgResize Image
buildImg
      Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
exportAndRemoveImage Image
buildImg Image
destImg
    (LiveInstallerImage FilePath
name FilePath
repo ImageResize
imgResize) -> do
      ImageResize -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageResize -> Image -> Eff e ()
resizeImage ImageResize
imgResize Image
buildImg
      let destImg :: Image
destImg = FilePath -> ImageType -> FileSystem -> Image
Image FilePath
destFile ImageType
Raw FileSystem
buildImgFs
          (Image FilePath
_ ImageType
_ FileSystem
buildImgFs) = Image
buildImg
          destFile :: FilePath
destFile =
            FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
"machines" FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
</> FilePath
"disks" FilePath -> FilePath -> FilePath
</> FilePath
"raw" FilePath -> FilePath -> FilePath
</> FilePath
"0.raw"
          sizeFile :: FilePath
sizeFile =
            FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
"machines" FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
</> FilePath
"disks" FilePath -> FilePath -> FilePath
</> FilePath
"raw" FilePath -> FilePath -> FilePath
</> FilePath
"0.size"
          versFile :: FilePath
versFile =
            FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
"machines" FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
</> FilePath
"disks" FilePath -> FilePath -> FilePath
</> FilePath
"raw" FilePath -> FilePath -> FilePath
</> FilePath
"VERSION"
      Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
exportAndRemoveImage Image
buildImg Image
destImg
      Either FilePath Integer
eitherSize <- FilePath -> Eff e (Either FilePath Integer)
forall (e :: [* -> *]).
IsB9 e =>
FilePath -> Eff e (Either FilePath Integer)
getVirtualSizeForRawImage FilePath
destFile
      case Either FilePath Integer
eitherSize of
        Left FilePath
err -> FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error FilePath
err
        Right Integer
value -> IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
writeFile FilePath
sizeFile (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
value))
      FilePath
buildDate <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildDate
      FilePath
buildId <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildId
      IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
writeFile FilePath
versFile (FilePath
buildId FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
buildDate))
    ImageDestination
Transient -> () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Determine the virtual size of a raw image
getVirtualSizeForRawImage :: (IsB9 e) => FilePath -> Eff e (Either String Integer)
getVirtualSizeForRawImage :: FilePath -> Eff e (Either FilePath Integer)
getVirtualSizeForRawImage FilePath
file = do
      ByteString
outPut <- FilePath -> Eff e ByteString
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ByteString
cmdStdout (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"qemu-img info -f raw '%s'" FilePath
file)
      Either FilePath Integer -> Eff e (Either FilePath Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either FilePath Integer
getVirtualSizeFromQemuImgInfoOutput ByteString
outPut)

getVirtualSizeFromQemuImgInfoOutput :: Strict.ByteString -> Either String Integer
getVirtualSizeFromQemuImgInfoOutput :: ByteString -> Either FilePath Integer
getVirtualSizeFromQemuImgInfoOutput ByteString
qemuOutput = case (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> ByteString -> Bool
Strict.isPrefixOf (FilePath -> ByteString
Strict.pack FilePath
"virtual size"))  (ByteString -> [ByteString]
Strict.lines ByteString
qemuOutput) of
  [] -> FilePath -> Either FilePath Integer
forall a b. a -> Either a b
Left (FilePath
"no line starting with 'virtual size' in output while parsing " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ByteString -> FilePath
Strict.unpack ByteString
qemuOutput)
  (ByteString
_ : ByteString
_ : [ByteString]
_) -> FilePath -> Either FilePath Integer
forall a b. a -> Either a b
Left (FilePath
"multiple lines starting with 'virtual size' in output" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ByteString -> FilePath
Strict.unpack ByteString
qemuOutput)
  [ByteString
x] -> let (ByteString
digits, ByteString
rest) = ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
Strict.span Char -> Bool
isDigit (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
Strict.drop Int
1 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
Strict.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(')) ByteString
x
         in
          if ByteString -> ByteString -> Bool
Strict.isPrefixOf (FilePath -> ByteString
Strict.pack FilePath
" bytes)") ByteString
rest
          then Integer -> Either FilePath Integer
forall a b. b -> Either a b
Right (FilePath -> Integer
forall a. Read a => FilePath -> a
read (ByteString -> FilePath
Strict.unpack ByteString
digits))
          else FilePath -> Either FilePath Integer
forall a b. a -> Either a b
Left (FilePath
"rest after digits didn't continue in ' bytes)'" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ByteString -> FilePath
Strict.unpack ByteString
qemuOutput)

createEmptyImage ::
  IsB9 e =>
  String ->
  FileSystem ->
  ImageType ->
  ImageSize ->
  Image ->
  Eff e ()
createEmptyImage :: FilePath
-> FileSystem -> ImageType -> ImageSize -> Image -> Eff e ()
createEmptyImage FilePath
fsLabel FileSystem
fsType ImageType
imgType ImageSize
imgSize dest :: Image
dest@(Image FilePath
_ ImageType
imgType' FileSystem
fsType')
  | FileSystem
fsType FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSystem
fsType' =
    FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error
      ( FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."
          (FileSystem -> FilePath
forall a. Show a => a -> FilePath
show FileSystem
fsType)
          (FileSystem -> FilePath
forall a. Show a => a -> FilePath
show FileSystem
fsType')
      )
  | ImageType
imgType ImageType -> ImageType -> Bool
forall a. Eq a => a -> a -> Bool
/= ImageType
imgType' =
    FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error
      ( FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."
          (ImageType -> FilePath
forall a. Show a => a -> FilePath
show ImageType
imgType)
          (ImageType -> FilePath
forall a. Show a => a -> FilePath
show ImageType
imgType')
      )
  | Bool
otherwise = do
    let (Image FilePath
imgFile ImageType
imgFmt FileSystem
imgFs) = Image
dest
        qemuImgOpts :: FilePath
qemuImgOpts = ImageType -> FilePath
conversionOptions ImageType
imgFmt
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL
      ( FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"Creating empty raw image '%s' with size %s and options %s"
          FilePath
imgFile
          (ImageSize -> FilePath
toQemuSizeOptVal ImageSize
imgSize)
          FilePath
qemuImgOpts
      )
    FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd
      ( FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"qemu-img create -f %s %s '%s' '%s'"
          (ImageType -> FilePath
imageFileExtension ImageType
imgFmt)
          FilePath
qemuImgOpts
          FilePath
imgFile
          (ImageSize -> FilePath
toQemuSizeOptVal ImageSize
imgSize)
      )
    case (ImageType
imgFmt, FileSystem
imgFs) of
      (ImageType
Raw, FileSystem
Ext4_64) -> do
        let fsCmd :: FilePath
fsCmd = FilePath
"mkfs.ext4"
        FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Creating file system %s" (FileSystem -> FilePath
forall a. Show a => a -> FilePath
show FileSystem
imgFs))
        FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s -F -L '%s' -O 64bit -q '%s'" FilePath
fsCmd FilePath
fsLabel FilePath
imgFile)
      (ImageType
Raw, FileSystem
Ext4) -> do
        [FilePath]
ext4Options <- Getting [FilePath] B9Config [FilePath] -> B9Config -> [FilePath]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [FilePath] B9Config [FilePath]
Lens' B9Config [FilePath]
ext4Attributes (B9Config -> [FilePath]) -> Eff e B9Config -> Eff e [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
        let fsOptions :: FilePath
fsOptions = FilePath
"-O " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," [FilePath]
ext4Options
        let fsCmd :: FilePath
fsCmd = FilePath
"mkfs.ext4"
        FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Creating file system %s" (FileSystem -> FilePath
forall a. Show a => a -> FilePath
show FileSystem
imgFs))
        FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s -F -L '%s' %s -q '%s'" FilePath
fsCmd FilePath
fsLabel FilePath
fsOptions FilePath
imgFile)
      (ImageType
imageType, FileSystem
fs) ->
        FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error
          ( FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
              FilePath
"Cannot create file system %s in image type %s"
              (FileSystem -> FilePath
forall a. Show a => a -> FilePath
show FileSystem
fs)
              (ImageType -> FilePath
forall a. Show a => a -> FilePath
show ImageType
imageType)
          )

createCOWImage :: IsB9 e => Image -> Image -> Eff e ()
createCOWImage :: Image -> Image -> Eff e ()
createCOWImage (Image FilePath
backingFile ImageType
_ FileSystem
_) (Image FilePath
imgOut ImageType
imgFmt FileSystem
_) = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Creating COW image '%s' backed by '%s'" FilePath
imgOut FilePath
backingFile)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd
    ( FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
        FilePath
"qemu-img create -f %s -o backing_file='%s' '%s'"
        (ImageType -> FilePath
imageFileExtension ImageType
imgFmt)
        FilePath
backingFile
        FilePath
imgOut
    )

resizeExtFS :: (IsB9 e) => ImageSize -> FilePath -> Eff e ()
resizeExtFS :: ImageSize -> FilePath -> Eff e ()
resizeExtFS ImageSize
newSize FilePath
img = do
  let sizeOpt :: FilePath
sizeOpt = ImageSize -> FilePath
toQemuSizeOptVal ImageSize
newSize
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Resizing ext4 filesystem on raw image to %s" FilePath
sizeOpt)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"e2fsck -p '%s'" FilePath
img)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"resize2fs -f '%s' %s" FilePath
img FilePath
sizeOpt)

shrinkToMinimumExtFS :: (IsB9 e) => FilePath -> Eff e ()
shrinkToMinimumExtFS :: FilePath -> Eff e ()
shrinkToMinimumExtFS FilePath
img = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL FilePath
"Shrinking image to minimum size"
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"e2fsck -p '%s'" FilePath
img)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"resize2fs -f -M '%s'" FilePath
img)

-- | Resize an image, including the file system inside the image.
resizeImage :: IsB9 e => ImageResize -> Image -> Eff e ()
resizeImage :: ImageResize -> Image -> Eff e ()
resizeImage ImageResize
KeepSize Image
_ = () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
resizeImage (Resize ImageSize
newSize) (Image FilePath
img ImageType
Raw FileSystem
fs)
  | FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4 Bool -> Bool -> Bool
|| FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4_64 = ImageSize -> FilePath -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageSize -> FilePath -> Eff e ()
resizeExtFS ImageSize
newSize FilePath
img
resizeImage (ShrinkToMinimumAndIncrease ImageSize
sizeIncrease) (Image FilePath
img ImageType
Raw FileSystem
fs)
  | FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4 Bool -> Bool -> Bool
|| FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4_64 = do
    FilePath -> Eff e ()
forall (e :: [* -> *]). IsB9 e => FilePath -> Eff e ()
shrinkToMinimumExtFS FilePath
img
    Integer
fileSize <- IO Integer -> Eff e Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Integer
getFileSize FilePath
img)
    let newSize :: ImageSize
newSize =
          ImageSize -> ImageSize -> ImageSize
addImageSize
            (Int -> ImageSize
bytesToKiloBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
fileSize))
            ImageSize
sizeIncrease
    ImageSize -> FilePath -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageSize -> FilePath -> Eff e ()
resizeExtFS ImageSize
newSize FilePath
img
resizeImage (ResizeImage ImageSize
newSize) (Image FilePath
img ImageType
_ FileSystem
_) = do
  let sizeOpt :: FilePath
sizeOpt = ImageSize -> FilePath
toQemuSizeOptVal ImageSize
newSize
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Resizing image to %s" FilePath
sizeOpt)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"qemu-img resize -q '%s' %s" FilePath
img FilePath
sizeOpt)
resizeImage ImageResize
ShrinkToMinimum (Image FilePath
img ImageType
Raw FileSystem
fs)
  | FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4 Bool -> Bool -> Bool
|| FileSystem
fs FileSystem -> FileSystem -> Bool
forall a. Eq a => a -> a -> Bool
== FileSystem
Ext4_64 = FilePath -> Eff e ()
forall (e :: [* -> *]). IsB9 e => FilePath -> Eff e ()
shrinkToMinimumExtFS FilePath
img
resizeImage ImageResize
_ Image
img =
  FilePath -> Eff e ()
forall a. HasCallStack => FilePath -> a
error
    ( FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
        FilePath
"Invalid image type or filesystem, cannot resize image: %s"
        (Image -> FilePath
forall a. Show a => a -> FilePath
show Image
img)
    )

-- | Import a disk image from some external source into the build directory
-- if necessary convert the image.
importImage :: IsB9 e => Image -> Image -> Eff e ()
importImage :: Image -> Image -> Eff e ()
importImage Image
imgIn imgOut :: Image
imgOut@(Image FilePath
imgOutPath ImageType
_ FileSystem
_) = do
  Bool
alreadyThere <- IO Bool -> Eff e Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
imgOutPath)
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyThere (Bool -> Image -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Bool -> Image -> Image -> Eff e ()
convert Bool
False Image
imgIn Image
imgOut)

-- | Export a disk image from the build directory; if necessary convert the image.
exportImage :: IsB9 e => Image -> Image -> Eff e ()
exportImage :: Image -> Image -> Eff e ()
exportImage = Bool -> Image -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Bool -> Image -> Image -> Eff e ()
convert Bool
False

-- | Export a disk image from the build directory; if necessary convert the image.
exportAndRemoveImage :: IsB9 e => Image -> Image -> Eff e ()
exportAndRemoveImage :: Image -> Image -> Eff e ()
exportAndRemoveImage = Bool -> Image -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Bool -> Image -> Image -> Eff e ()
convert Bool
True

-- | Convert an image in the build directory to another format and return the new image.
convertImage :: IsB9 e => Image -> Image -> Eff e ()
convertImage :: Image -> Image -> Eff e ()
convertImage Image
imgIn imgOut :: Image
imgOut@(Image FilePath
imgOutPath ImageType
_ FileSystem
_) = do
  Bool
alreadyThere <- IO Bool -> Eff e Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
imgOutPath)
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyThere (Bool -> Image -> Image -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Bool -> Image -> Image -> Eff e ()
convert Bool
True Image
imgIn Image
imgOut)

-- | Convert/Copy/Move images
convert :: IsB9 e => Bool -> Image -> Image -> Eff e ()
convert :: Bool -> Image -> Image -> Eff e ()
convert Bool
doMove (Image FilePath
imgIn ImageType
fmtIn FileSystem
_) (Image FilePath
imgOut ImageType
fmtOut FileSystem
_)
  | FilePath
imgIn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
imgOut = do
    FilePath -> Eff e ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
imgOut
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"No need to convert: '%s'" FilePath
imgIn)
  | Bool
doMove Bool -> Bool -> Bool
&& ImageType
fmtIn ImageType -> ImageType -> Bool
forall a. Eq a => a -> a -> Bool
== ImageType
fmtOut = do
    FilePath -> Eff e ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
imgOut
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Moving '%s' to '%s'" FilePath
imgIn FilePath
imgOut)
    IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff e ()) -> IO () -> Eff e ()
forall a b. (a -> b) -> a -> b
$ do
      let exdev :: IOException -> IO ()
exdev IOException
e =
            if IOException -> Maybe CInt
IO.ioe_errno IOException
e Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just ((\(IO.Errno CInt
a) -> CInt
a) Errno
IO.eXDEV)
              then FilePath -> FilePath -> IO ()
copyFile FilePath
imgIn FilePath
imgOut IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ()
removeFile FilePath
imgIn
              else IOException -> IO ()
forall a e. Exception e => e -> a
IO.throw IOException
e
      FilePath -> FilePath -> IO ()
renameFile FilePath
imgIn FilePath
imgOut IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`IO.catch` IOException -> IO ()
exdev
  | Bool
otherwise = do
    FilePath -> Eff e ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
imgOut
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL
      ( FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"Converting %s to %s: '%s' to '%s'"
          (ImageType -> FilePath
imageFileExtension ImageType
fmtIn)
          (ImageType -> FilePath
imageFileExtension ImageType
fmtOut)
          FilePath
imgIn
          FilePath
imgOut
      )
    FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member (Exc SomeException) e, CommandIO e) =>
FilePath -> Eff e ()
cmd
      ( FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"qemu-img convert -q -f %s -O %s %s '%s' '%s'"
          (ImageType -> FilePath
imageFileExtension ImageType
fmtIn)
          (ImageType -> FilePath
imageFileExtension ImageType
fmtOut)
          (ImageType -> FilePath
conversionOptions ImageType
fmtOut)
          FilePath
imgIn
          FilePath
imgOut
      )
    Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doMove (Eff e () -> Eff e ()) -> Eff e () -> Eff e ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Removing '%s'" FilePath
imgIn)
      IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ()
removeFile FilePath
imgIn)

conversionOptions :: ImageType -> String
conversionOptions :: ImageType -> FilePath
conversionOptions ImageType
Vmdk = FilePath
" -o adapter_type=lsilogic "
conversionOptions ImageType
QCow2 = FilePath
" -o compat=1.1,lazy_refcounts=on "
conversionOptions ImageType
_ = FilePath
" "

toQemuSizeOptVal :: ImageSize -> String
toQemuSizeOptVal :: ImageSize -> FilePath
toQemuSizeOptVal (ImageSize Int
amount SizeUnit
u) =
  Int -> FilePath
forall a. Show a => a -> FilePath
show Int
amount
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ case SizeUnit
u of
      SizeUnit
GB -> FilePath
"G"
      SizeUnit
MB -> FilePath
"M"
      SizeUnit
KB -> FilePath
"K"

-- | Publish an sharedImage made from an image and image meta data to the
-- configured repository
shareImage :: IsB9 e => Image -> SharedImageName -> Eff e SharedImage
shareImage :: Image -> SharedImageName -> Eff e SharedImage
shareImage Image
buildImg sname :: SharedImageName
sname@(SharedImageName FilePath
name) = do
  SharedImage
sharedImage <- Image -> SharedImageName -> Eff e SharedImage
forall (e :: [* -> *]).
IsB9 e =>
Image -> SharedImageName -> Eff e SharedImage
createSharedImageInCache Image
buildImg SharedImageName
sname
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"SHARED '%s'" FilePath
name)
  SharedImage -> Eff e ()
forall (e :: [* -> *]).
(Member (Exc SomeException) e, Lifted IO e, CommandIO e,
 '[RepoCacheReader, SelectedRemoteRepoReader] <:: e) =>
SharedImage -> Eff e ()
pushToSelectedRepo SharedImage
sharedImage
  SharedImage -> Eff e SharedImage
forall (m :: * -> *) a. Monad m => a -> m a
return SharedImage
sharedImage

-- TODO Move the functions below to RepositoryIO???

-- | 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 :: SharedImageName -> Image -> Eff e SharedImage
getSharedImageFromImageInfo SharedImageName
name (Image FilePath
_ ImageType
imgType FileSystem
imgFS) = do
  FilePath
buildId <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildId
  FilePath
date <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildDate
  SharedImage -> Eff e SharedImage
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( SharedImageName
-> SharedImageDate
-> SharedImageBuildId
-> ImageType
-> FileSystem
-> SharedImage
SharedImage
        SharedImageName
name
        (FilePath -> SharedImageDate
SharedImageDate FilePath
date)
        (FilePath -> SharedImageBuildId
SharedImageBuildId FilePath
buildId)
        ImageType
imgType
        FileSystem
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 :: Image -> SharedImageName -> Eff e SharedImage
createSharedImageInCache Image
img sname :: SharedImageName
sname@(SharedImageName FilePath
name) = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"CREATING SHARED IMAGE: '%s' '%s'" (Image -> FilePath
forall a. Show a => a -> FilePath
ppShow Image
img) FilePath
name)
  SharedImage
sharedImg <- SharedImageName -> Image -> Eff e SharedImage
forall (e :: [* -> *]).
IsB9 e =>
SharedImageName -> Image -> Eff e SharedImage
getSharedImageFromImageInfo SharedImageName
sname Image
img
  FilePath
dir <- Eff e FilePath
forall (e :: [* -> *]).
('[RepoCacheReader] <:: e) =>
Eff e FilePath
getSharedImagesCacheDir
  Image -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => Image -> Image -> Eff e ()
convertImage Image
img (FilePath -> Image -> Image
changeImageDirectory FilePath
dir (SharedImage -> Image
sharedImageImage SharedImage
sharedImg))
  FilePath -> SharedImage -> Eff e ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
FilePath -> a -> m ()
prettyPrintToFile (FilePath
dir FilePath -> FilePath -> FilePath
</> SharedImage -> FilePath
sharedImageFileName SharedImage
sharedImg) SharedImage
sharedImg
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"CREATED SHARED IMAGE IN CACHE '%s'" (SharedImage -> FilePath
forall a. Show a => a -> FilePath
ppShow SharedImage
sharedImg))
  SharedImageName -> Eff e ()
forall (e :: [* -> *]).
('[RepoCacheReader, Exc SomeException] <:: e, Lifted IO e,
 CommandIO e) =>
SharedImageName -> Eff e ()
cleanOldSharedImageRevisionsFromCache SharedImageName
sname
  SharedImage -> Eff e SharedImage
forall (m :: * -> *) a. Monad m => a -> m a
return SharedImage
sharedImg
--
--
--
--
--
--
--    imgDir <- getSharedImagesCacheDir
--    let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)
--        infoFiles = sharedImageFileName <$> toDelete
--        imgFiles = imageFileName . sharedImageImage <$> toDelete
--    unless (null filesToDelete) $ do
--      traceL
--        ( printf
--            "DELETING %d OBSOLETE REVISIONS OF: %s"
--            (length filesToDelete)
--            (show sn)
--        )
--      mapM_ traceL filesToDelete
--      mapM_ removeIfExists filesToDelete
--  where
--    newestSharedImages :: 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
--