summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Parted.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Parted.hs')
-rw-r--r--src/Propellor/Property/Parted.hs219
1 files changed, 89 insertions, 130 deletions
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index bc8a256d..43744142 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,136 +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
- val :: 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
- val = 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
- val Primary = "primary"
- val Logical = "logical"
- val 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
- val (MegaBytes n)
- | n > 0 = show n ++ "MB"
- -- parted can't make partitions smaller than 1MB;
- -- avoid failure in edge cases
- | otherwise = show "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
- val BootFlag = "boot"
- val RootFlag = "root"
- val SwapFlag = "swap"
- val HiddenFlag = "hidden"
- val RaidFlag = "raid"
- val LvmFlag = "lvm"
- val LbaFlag = "lba"
- val LegacyBootFlag = "legacy_boot"
- val IrstFlag = "irst"
- val EspFlag = "esp"
- val PaloFlag = "palo"
-
-instance PartedVal Bool where
- val True = "on"
- val False = "off"
-
-instance PartedVal Partition.Fs where
- val Partition.EXT2 = "ext2"
- val Partition.EXT3 = "ext3"
- val Partition.EXT4 = "ext4"
- val Partition.BTRFS = "btrfs"
- val Partition.REISERFS = "reiserfs"
- val Partition.XFS = "xfs"
- val Partition.FAT = "fat"
- val Partition.VFAT = "vfat"
- val Partition.NTFS = "ntfs"
- val Partition.LinuxSwap = "linux-swap"
+import System.Posix.Files
+import Data.List (genericLength)
data Eep = YesReallyDeleteDiskContents
@@ -167,19 +62,19 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
format (p, dev) = Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition (partFs p) dev
- mklabel = ["mklabel", val tabletype]
+ mklabel = ["mklabel", pval tabletype]
mkflag partnum (f, b) =
[ "set"
, show partnum
- , val f
- , val b
+ , pval f
+ , pval b
]
mkpart partnum offset p =
[ "mkpart"
- , val (partType p)
- , val (partFs p)
- , val offset
- , val (offset <> partSize p)
+ , pval (partType p)
+ , pval (partFs p)
+ , pval offset
+ , pval (offset <> partSize p)
] ++ case partName p of
Just n -> ["name", show partnum, n]
Nothing -> []
@@ -192,12 +87,76 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
--
-- Parted is run in script mode, so it will never prompt for input.
-- It is asked to use cylinder alignment for the disk.
-parted :: Eep -> FilePath -> [String] -> Property DebianLike
+parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux)
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
`assume` MadeChange
-- | Gets parted installed.
-installed :: Property DebianLike
-installed = Apt.installed ["parted"]
+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 (DiskSize (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)