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. --- debian/changelog | 10 +- propellor.cabal | 4 +- src/Propellor/Property/DiskImage.hs | 16 +-- src/Propellor/Property/DiskImage/PartSpec.hs | 84 ++---------- src/Propellor/Property/Parted.hs | 198 +++++++++++---------------- src/Propellor/Property/Parted/Types.hs | 119 ++++++++++++++++ src/Propellor/Types/PartSpec.hs | 66 +++++++++ 7 files changed, 294 insertions(+), 203 deletions(-) create mode 100644 src/Propellor/Property/Parted/Types.hs create mode 100644 src/Propellor/Types/PartSpec.hs diff --git a/debian/changelog b/debian/changelog index 7ad30b40..4a9775db 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,11 @@ -propellor (4.4.1) UNRELEASED; urgency=medium - +propellor (4.5.0) UNRELEASED; urgency=medium + + * 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. * Generate a better description for versioned properties. -- Joey Hess Mon, 17 Jul 2017 16:51:11 -0400 diff --git a/propellor.cabal b/propellor.cabal index d4417578..f175a3fa 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.4.0 +Version: 4.5.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess @@ -135,6 +135,7 @@ Library Propellor.Property.OS Propellor.Property.Pacman Propellor.Property.Parted + Propellor.Property.Parted.Types Propellor.Property.Partition Propellor.Property.Postfix Propellor.Property.PropellorRepo @@ -193,6 +194,7 @@ Library Propellor.Types.Info Propellor.Types.MetaTypes Propellor.Types.OS + Propellor.Types.PartSpec Propellor.Types.PrivData Propellor.Types.Result Propellor.Types.ResultCheck diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index f8754f85..4d10f300 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -20,12 +20,12 @@ import Propellor.Base import Propellor.Property.DiskImage.PartSpec import Propellor.Property.Chroot (Chroot) import Propellor.Property.Chroot.Util (removeChroot) +import Propellor.Property.Mount 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 Propellor.Property.Fstab (SwapPartition(..), genFstab) import Propellor.Property.Partition import Propellor.Property.Rsync @@ -34,7 +34,7 @@ import Propellor.Types.Bootloader import Propellor.Container import Utility.Path -import Data.List (isPrefixOf, isInfixOf, sortBy) +import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4) import Data.Function (on) import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L @@ -109,16 +109,16 @@ type DiskImage = FilePath -- > & Apt.installed ["linux-image-amd64"] -- > & Grub.installed PC -- > & hasPassword (User "root") -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt' rebuild img mkchroot tabletype partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot @@ -159,7 +159,7 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) skipit = doNothing :: Property UnixLike -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) UnixLike +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir @@ -214,10 +214,10 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> -- The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) +fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) fitChrootSize tt l basesizes = (mounts, mountopts, parttable) where - (mounts, mountopts, sizers) = unzip3 l + (mounts, mountopts, sizers, _) = unzip4 l parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs index 2b14baa0..6a29af4e 100644 --- a/src/Propellor/Property/DiskImage/PartSpec.hs +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -1,32 +1,24 @@ -- | Disk image partition specification and combinators. +-- Partitions in disk images default to being sized large enough to hold +-- the files that appear in the directory where the partition is to be +-- mounted. Plus a fudge factor, since filesystems have some space +-- overhead. + module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Types.PartSpec, module Propellor.Property.DiskImage.PartSpec, - Partition, - PartSize(..), - PartFlag(..), - TableType(..), - Fs(..), - MountPoint, ) where import Propellor.Base import Propellor.Property.Parted -import Propellor.Property.Mount - --- | Specifies a mount point, mount options, and a constructor for a Partition. --- --- The size that is eventually provided is the amount of space needed to --- hold the files that appear in the directory where the partition is to be --- mounted. Plus a fudge factor, since filesystems have some space --- overhead. -type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition) +import Propellor.Types.PartSpec --- | Partitions that are not to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size. -defSz :: PartSize -defSz = MegaBytes 128 +-- | Adds additional free space to the partition. +addFreeSpace :: PartSpec t -> PartSize -> PartSpec t +addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t) + where + p' = \sz -> p (sz <> freesz) -- | Add 2% for filesystem overhead. Rationalle for picking 2%: -- A filesystem with 1% overhead might just sneak by as acceptable. @@ -35,55 +27,3 @@ defSz = MegaBytes 128 -- Add an additional 200 mb for temp files, journals, etc. fudge :: PartSize -> PartSize fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) - --- | Specifies a swap partition of a given size. -swapPartition :: PartSize -> PartSpec -swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz)) - --- | Specifies a partition with a given filesystem. --- --- The partition is not mounted anywhere by default; use the combinators --- below to configure it. -partition :: Fs -> PartSpec -partition fs = (Nothing, mempty, mkPartition fs) - --- | Specifies where to mount a partition. -mountedAt :: PartSpec -> FilePath -> PartSpec -mountedAt (_, o, p) mp = (Just mp, o, p) - --- | Specifies a mount option, such as "noexec" -mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec -mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p) - --- | Mount option to make a partition be remounted readonly when there's an --- error accessing it. -errorReadonly :: MountOpts -errorReadonly = toMountOpts "errors=remount-ro" - --- | Adds additional free space to the partition. -addFreeSpace :: PartSpec -> PartSize -> PartSpec -addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz)) - --- | Forced a partition to be a specific size, instead of scaling to the --- size needed for the files in the chroot. -setSize :: PartSpec -> PartSize -> PartSpec -setSize (mp, o, p) sz = (mp, o, const (p sz)) - --- | Sets the percent of the filesystem blocks reserved for the super-user. --- --- The default is 5% for ext2 and ext4. Some filesystems may not support --- this. -reservedSpacePercentage :: PartSpec -> Int -> PartSpec -reservedSpacePercentage s percent = adjustp s $ \p -> - p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p } - --- | Sets a flag on the partition. -setFlag :: PartSpec -> PartFlag -> PartSpec -setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } - --- | Makes a MSDOS partition be Extended, rather than Primary. -extended :: PartSpec -> PartSpec -extended s = adjustp s $ \p -> p { partType = Extended } - -adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, o, p) f = (mp, o, f . p) 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) diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs new file mode 100644 index 00000000..3350e008 --- /dev/null +++ b/src/Propellor/Property/Parted/Types.hs @@ -0,0 +1,119 @@ +module Propellor.Property.Parted.Types where + +import Propellor.Base +import qualified Propellor.Property.Partition as Partition +import Utility.DataUnits + +import Data.Char + +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) + +-- | 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" diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs new file mode 100644 index 00000000..2b0a8787 --- /dev/null +++ b/src/Propellor/Types/PartSpec.hs @@ -0,0 +1,66 @@ +-- | Partition specification combinators. + +module Propellor.Types.PartSpec where + +import Propellor.Base +import Propellor.Property.Parted.Types +import Propellor.Property.Mount +import Propellor.Property.Partition + +-- | Specifies a mount point, mount options, and a constructor for a +-- Partition that determines its size. +type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t) + +-- | Specifies a partition with a given filesystem. +-- +-- The partition is not mounted anywhere by default; use the combinators +-- below to configure it. +partition :: Monoid t => Fs -> PartSpec t +partition fs = (Nothing, mempty, mkPartition fs, mempty) + +-- | Specifies a swap partition of a given size. +swapPartition :: Monoid t => PartSize -> PartSpec t +swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty) + +-- | Specifies where to mount a partition. +mountedAt :: PartSpec t -> FilePath -> PartSpec t +mountedAt (_, o, p, t) mp = (Just mp, o, p, t) + +-- | Specify a fixed size for a partition. +setSize :: PartSpec t -> PartSize -> PartSpec t +setSize (mp, o, p, t) sz = (mp, o, const (p sz), t) + +-- | Specifies a mount option, such as "noexec" +mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t +mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t) + +-- | Mount option to make a partition be remounted readonly when there's an +-- error accessing it. +errorReadonly :: MountOpts +errorReadonly = toMountOpts "errors=remount-ro" + +-- | Sets the percent of the filesystem blocks reserved for the super-user. +-- +-- The default is 5% for ext2 and ext4. Some filesystems may not support +-- this. +reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t +reservedSpacePercentage s percent = adjustp s $ \p -> + p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p } + +-- | Sets a flag on the partition. +setFlag :: PartSpec t -> PartFlag -> PartSpec t +setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: PartSpec t -> PartSpec t +extended s = adjustp s $ \p -> p { partType = Extended } + +adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t +adjustp (mp, o, p, t) f = (mp, o, f . p, t) + +adjustt :: PartSpec t -> (t -> t) -> PartSpec t +adjustt (mp, o, p, t) f = (mp, o, p, f t) + +-- | Default partition size when not otherwize specified is 128 MegaBytes. +defSz :: PartSize +defSz = MegaBytes 128 -- cgit v1.2.3