From 5bd4c6e679ed605f1b37c201affb27096662c29f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 21 Jul 2017 16:05:50 -0400 Subject: calcPartTable using PartSpec DSL * Generalized the PartSpec DSL, so it can be used for both disk image partitioning, and disk device partitioning, with different partition sizing methods as appropriate for the different uses. (minor API change) * Propellor.Property.Parted: Added calcPartTable function which uses PartSpec DiskPart, and a useDiskSpace combinator. This commit was sponsored by Thomas Hochstein on Patreon. --- src/Propellor/Property/Parted.hs | 198 +++++++++++++++------------------------ 1 file changed, 78 insertions(+), 120 deletions(-) (limited to 'src/Propellor/Property/Parted.hs') diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index f7ac379f..970f5b9a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} module Propellor.Property.Parted ( + -- * Types TableType(..), PartTable(..), partTableSize, @@ -15,137 +16,30 @@ module Propellor.Property.Parted ( Partition.MkfsOpts, PartType(..), PartFlag(..), - Eep(..), + -- * Properties partitioned, parted, + Eep(..), installed, + -- * PartSpec combinators + calcPartTable, + DiskSize(..), + DiskPart, + module Propellor.Types.PartSpec, + DiskSpaceUse(..), + useDiskSpace, ) where import Propellor.Base +import Propellor.Property.Parted.Types import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Property.Partition as Partition +import Propellor.Types.PartSpec import Utility.DataUnits -import Data.Char -import System.Posix.Files - -class PartedVal a where - pval :: a -> String - --- | Types of partition tables supported by parted. -data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN - deriving (Show) - -instance PartedVal TableType where - pval = map toLower . show - --- | A disk's partition table. -data PartTable = PartTable TableType [Partition] - deriving (Show) - -instance Monoid PartTable where - -- | default TableType is MSDOS - mempty = PartTable MSDOS [] - -- | uses the TableType of the second parameter - mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) - --- | Gets the total size of the disk specified by the partition table. -partTableSize :: PartTable -> ByteSize -partTableSize (PartTable _ ps) = fromPartSize $ - -- add 1 megabyte to hold the partition table itself - mconcat (MegaBytes 1 : map partSize ps) - --- | A partition on the disk. -data Partition = Partition - { partType :: PartType - , partSize :: PartSize - , partFs :: Partition.Fs - , partMkFsOpts :: Partition.MkfsOpts - , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) - , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) - } - deriving (Show) - --- | Makes a Partition with defaults for non-important values. -mkPartition :: Partition.Fs -> PartSize -> Partition -mkPartition fs sz = Partition - { partType = Primary - , partSize = sz - , partFs = fs - , partMkFsOpts = [] - , partFlags = [] - , partName = Nothing - } - --- | Type of a partition. -data PartType = Primary | Logical | Extended - deriving (Show) - -instance PartedVal PartType where - pval Primary = "primary" - pval Logical = "logical" - pval Extended = "extended" - --- | All partition sizing is done in megabytes, so that parted can --- automatically lay out the partitions. --- --- Note that these are SI megabytes, not mebibytes. -newtype PartSize = MegaBytes Integer - deriving (Show) - -instance PartedVal PartSize where - pval (MegaBytes n) - | n > 0 = val n ++ "MB" - -- parted can't make partitions smaller than 1MB; - -- avoid failure in edge cases - | otherwise = "1MB" --- | Rounds up to the nearest MegaByte. -toPartSize :: ByteSize -> PartSize -toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) - -fromPartSize :: PartSize -> ByteSize -fromPartSize (MegaBytes b) = b * 1000000 - -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) - -instance PartedVal PartFlag where - pval BootFlag = "boot" - pval RootFlag = "root" - pval SwapFlag = "swap" - pval HiddenFlag = "hidden" - pval RaidFlag = "raid" - pval LvmFlag = "lvm" - pval LbaFlag = "lba" - pval LegacyBootFlag = "legacy_boot" - pval IrstFlag = "irst" - pval EspFlag = "esp" - pval PaloFlag = "palo" - -instance PartedVal Bool where - pval True = "on" - pval False = "off" - -instance PartedVal Partition.Fs where - pval Partition.EXT2 = "ext2" - pval Partition.EXT3 = "ext3" - pval Partition.EXT4 = "ext4" - pval Partition.BTRFS = "btrfs" - pval Partition.REISERFS = "reiserfs" - pval Partition.XFS = "xfs" - pval Partition.FAT = "fat" - pval Partition.VFAT = "vfat" - pval Partition.NTFS = "ntfs" - pval Partition.LinuxSwap = "linux-swap" +import System.Posix.Files +import Data.List (genericLength) data Eep = YesReallyDeleteDiskContents @@ -202,3 +96,67 @@ parted YesReallyDeleteDiskContents disk ps = p `requires` installed -- | Gets parted installed. installed :: Property (DebianLike + ArchLinux) installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"] + +-- | Gets the total size of the disk specified by the partition table. +partTableSize :: PartTable -> ByteSize +partTableSize (PartTable _ ps) = fromPartSize $ + mconcat (partitionTableOverhead : map partSize ps) + +-- | Some disk is used to store the partition table itself. Assume less +-- than 1 mb. +partitionTableOverhead :: PartSize +partitionTableOverhead = MegaBytes 1 + +-- | Calculate a partition table, for a given size of disk. +-- +-- For example: +-- +-- > calcPartTable (1024 * 1024 * 1024 * 100) MSDOS +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setSize` MegaBytes 256 +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `useDisk` RemainingSpace +-- > ] +calcPartTable :: DiskSize -> TableType -> [PartSpec DiskPart] -> PartTable +calcPartTable (DiskSize disksize) tt l = PartTable tt (map go l) + where + go (_, _, mkpart, FixedDiskPart) = mkpart defSz + go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ toPartSize $ + diskremainingafterfixed * fromIntegral p `div` 100 + go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ toPartSize $ + diskremaining `div` genericLength (filter isremainingspace l) + diskremainingafterfixed = + disksize - sumsizes (filter isfixed l) + diskremaining = + disksize - sumsizes (filter (not . isremainingspace) l) + sumsizes = sum . map fromPartSize . (partitionTableOverhead :) . + map (partSize . go) + isfixed (_, _, _, FixedDiskPart) = True + isfixed _ = False + isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True + isremainingspace _ = False + +-- | Size of a disk, in bytes. +newtype DiskSize = DiskSize ByteSize + deriving (Show) + +data DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse + +data DiskSpaceUse = Percent Int | RemainingSpace + +instance Monoid DiskPart + where + mempty = FixedDiskPart + mappend FixedDiskPart FixedDiskPart = FixedDiskPart + mappend (DynamicDiskPart (Percent a)) (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent (a + b)) + mappend (DynamicDiskPart RemainingSpace) (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace + mappend (DynamicDiskPart (Percent a)) _ = DynamicDiskPart (Percent a) + mappend _ (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent b) + mappend (DynamicDiskPart RemainingSpace) _ = DynamicDiskPart RemainingSpace + mappend _ (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace + +-- | Make a partition use some percentage of the size of the disk +-- (less all fixed size partitions), or the remaining space in the disk. +useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart +useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse) -- cgit v1.2.3