module Propellor.Property.DiskImage (
DiskImage,
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
Partition,
PartSize(..),
Fs(..),
PartSpec,
MountPoint,
swapPartition,
partition,
mountedAt,
addFreeSpace,
setSize,
PartFlag(..),
setFlag,
TableType(..),
extended,
adjustp,
Finalization,
grubBooted,
Grub.BIOS(..),
noFinalization,
) where
import Propellor
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Parted
import Propellor.Property.Mount
import Utility.Path
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
type DiskImage = FilePath
imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuilt = imageBuilt' False
imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuilt' rebuild img mkchroot tabletype partspec final =
imageBuiltFrom img chrootdir tabletype partspec (snd final)
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> doNothing)
`describe` desc
where
desc = "built disk image " ++ img
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
chroot = mkchroot chrootdir
& fst final
& Apt.cacheCleaned
imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
where
mkimg = property (img ++ " built from " ++ chrootdir) $ do
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts
let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
ensureProperty $
imageExists img (partTableSize t)
`before`
partitioned YesReallyDeleteDiskContents img t
rmimg = File.notPresent img
imageExists :: FilePath -> ByteSize -> Property NoInfo
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
| toInteger (fileSize s) == toInteger sz -> return NoChange
| toInteger (fileSize s) > toInteger sz -> do
setFileSize img (fromInteger sz)
return MadeChange
_ -> do
L.writeFile img (L.replicate (fromIntegral sz) 0)
return MadeChange
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes top = go M.empty top [top]
where
go m _ [] = return m
go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do
s <- getSymbolicLinkStatus i
let sz = fromIntegral (fileSize s)
if isDirectory s
then do
subm <- go M.empty i =<< dirContents i
let sz' = M.foldr' (+) sz
(M.filterWithKey (const . subdirof i) subm)
go (M.insertWith (+) i sz' (M.union m subm)) dir is
else go (M.insertWith (+) dir sz m) dir is
subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ catMaybes $
map (getMountSz szm l) (filter childmntpt l)
childmntpt Nothing = False
childmntpt (Just d)
| d `equalFilePath` mntpt = False
| otherwise = mntpt `dirContains` d
toSysDir :: FilePath -> FilePath -> FilePath
toSysDir chrootdir d = case makeRelative chrootdir d of
"." -> "/"
sysdir -> "/" ++ sysdir
type MountPoint = Maybe FilePath
defSz :: PartSize
defSz = MegaBytes 128
type PartSpec = (MountPoint, PartSize -> Partition)
swapPartition :: PartSize -> PartSpec
swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz))
partition :: Fs -> PartSpec
partition fs = (Nothing, mkPartition fs)
mountedAt :: PartSpec -> FilePath -> PartSpec
mountedAt (_, p) mp = (Just mp, p)
addFreeSpace :: PartSpec -> PartSize -> PartSpec
addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz))
setSize :: PartSpec -> PartSize -> PartSpec
setSize (mp, p) sz = (mp, const (p sz))
setFlag :: PartSpec -> PartFlag -> PartSpec
setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
extended :: PartSpec -> PartSpec
extended s = adjustp s $ \p -> p { partType = Extended }
adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec
adjustp (mp, p) f = (mp, \sz -> f (p sz))
fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable)
fitChrootSize tt l basesizes = (mounts, parttable)
where
(mounts, sizers) = unzip l
parttable = PartTable tt (map (uncurry id) (zip sizers basesizes))
type Finalization = (Property NoInfo, Property NoInfo)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed bios, undefined)
noFinalization :: Finalization
noFinalization = (doNothing, doNothing)