From 418e6a5b4ee36360911cdff14f70357c5c2bfc80 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:09:47 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 36 +++++++++++++++++++++++++++--------- src/Propellor/Property/Parted.hs | 4 ++++ 2 files changed, 31 insertions(+), 9 deletions(-) (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 59baa8d1..86be3a9b 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -33,6 +33,7 @@ import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File 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 @@ -85,13 +86,12 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir - szm <- liftIO $ M.mapKeys (toSysDir chrootdir) . M.map toPartSize - <$> dirSizes chrootdir + szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize + <$> liftIO (dirSizes chrootdir) -- tie the knot! - -- TODO when /boot is in part table, size of / - -- should be reduced by sie of /boot -- TODO if any size is < 1 MB, use 1 MB for sanity - let (mnts, t) = mkparttable (map (getMountSz szm) mnts) + let (mnts, t) = mkparttable (map (saneSz . fromMaybe defSz . getMountSz szm mnts) mnts) + liftIO $ print (mnts, t) ensureProperty $ imageExists img (partTableSize t) `before` @@ -140,6 +140,23 @@ dirSizes top = go M.empty top [top] else go (M.insertWith (+) dir sz m) dir is subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent +-- | Gets the size to allocate for a particular mount point, given the +-- map of sizes. +-- +-- A list of all mount points is provided, so that when eg calculating +-- the size for /, if /boot is a mount point, its size can be subtracted. +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 + -- | From a location in a chroot (eg, /tmp/chroot/usr) to -- the corresponding location inside (eg, /usr). toSysDir :: FilePath -> FilePath -> FilePath @@ -162,10 +179,11 @@ mountedAt mkp mntpoint = (Just mntpoint, mkp) swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) -getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize -getMountSz _ Nothing = defSz -getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm - +-- | Avoid partitions smaller than 1 mb; parted gets confused. +saneSz :: PartSize -> PartSize +saneSz (MegaBytes n) | n < 1 = MegaBytes 1 +saneSz sz = sz + defSz :: PartSize defSz = MegaBytes 128 diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index fcff089a..1ff8677a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -11,6 +11,7 @@ module Propellor.Property.Parted ( ByteSize, toPartSize, fromPartSize, + reducePartSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -104,6 +105,9 @@ instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) +reducePartSize :: PartSize -> PartSize -> PartSize +reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) + -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag deriving (Show) -- cgit v1.2.3