summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/DiskImage.hs16
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs84
-rw-r--r--src/Propellor/Property/Parted.hs198
-rw-r--r--src/Propellor/Property/Parted/Types.hs119
4 files changed, 217 insertions, 200 deletions
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"