From b3c3a7029020126b1ab5e2d5999b7b2707078150 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 18:50:35 -0700 Subject: formatting for partitions set up by parted Including support for formatting partitions of a disk image file. --- src/Propellor/Property/DiskImage.hs | 1 - src/Propellor/Property/Parted.hs | 61 +++++++++++++++++++++++++++++-------- src/Propellor/Property/Partition.hs | 54 ++++++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 14 deletions(-) create mode 100644 src/Propellor/Property/Partition.hs (limited to 'src/Propellor') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 15108249..de8bdd56 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -10,7 +10,6 @@ module Propellor.Property.DiskImage ( import Propellor import Propellor.Property.Chroot import Utility.DataUnits -import Data.Monoid -- | Creates a bootable disk image. -- diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 3a927354..2b741234 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -3,8 +3,11 @@ module Propellor.Property.Parted ( TableType(..), PartTable(..), + Partition(..), + mkPartition, + Partition.Fs(..), + Partition.MkfsOpts, PartType(..), - FsType, PartFlag(..), Eep(..), partitioned, @@ -14,8 +17,10 @@ module Propellor.Property.Parted ( import Propellor import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Partition as Partition import Utility.DataUnits import Data.Char +import System.Posix.Files class PartedVal a where val :: a -> String @@ -40,13 +45,25 @@ instance Monoid PartTable where -- | A partition on the disk. data Partition = Partition { partType :: PartType - , partFs :: FsType - , partSize :: ByteSize + , partSize :: ByteSize -- ^ size of the partition in bytes + , 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 -> ByteSize -> 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) @@ -56,9 +73,6 @@ instance PartedVal PartType where val Logical = "logical" val Extended = "extended" --- | Eg, "ext4" or "fat16" or "ntfs" or "hfs+" or "linux-swap" -type FsType = String - -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag deriving (Show) @@ -80,18 +94,39 @@ 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" + data Eep = YesReallyDeleteDiskContents --- | Partitions a disk using parted. Does not mkfs filesystems. +-- | Partitions a disk using parted, and formats the partitions. -- --- The FilePath can be a disk device (eg, /dev/sda), or a disk image file. +-- The FilePath can be a block device (eg, /dev/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo -partitioned eep disk (PartTable tabletype parts) = - parted eep disk (concat (setunits : mklabel : mkparts (1 :: Integer) 0 parts [])) - `describe` (disk ++ " partitioned") +partitioned eep disk (PartTable tabletype parts) = property desc $ do + isdev <- liftIO $ isBlockDevice <$> getFileStatus disk + ensureProperty $ if isdev + then go (map (\n -> disk ++ show n) [1 :: Int ..]) + else Partition.kpartx disk go where + desc = disk ++ " partitioned" + go devs = combineProperties desc $ + parted eep disk partedparams : map format (zip parts devs) + partedparams = concat $ + setunits : mklabel : mkparts (1 :: Integer) 0 parts [] + format (p, dev) = Partition.formatted' (partMkFsOpts p) + Partition.YesReallyFormatPartition (partFs p) dev mklabel = ["mklabel", val tabletype] mkflag partnum (f, b) = [ "set" @@ -99,12 +134,12 @@ partitioned eep disk (PartTable tabletype parts) = , val f , val b ] - setunits = ["unit", "B"] + setunits = ["unit", "B"] -- tell parted we use bytes mkpart partnum offset p = [ "mkpart" , show partnum , val (partType p) - , partFs p + , val (partFs p) , show offset , show (offset + partSize p) ] ++ case partName p of diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs new file mode 100644 index 00000000..53d8a946 --- /dev/null +++ b/src/Propellor/Property/Partition.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Partition where + +import Propellor +import qualified Propellor.Property.Apt as Apt + +-- | Filesystems etc that can be used for a partition. +data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap + deriving (Show) + +data Eep = YesReallyFormatPartition + +-- | Formats a partition. +formatted :: Eep -> Fs -> FilePath -> Property NoInfo +formatted = formatted' [] + +-- | Options passed to a mkfs.* command when making a filesystem. +-- +-- Eg, ["-m0"] +type MkfsOpts = [String] + +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo +formatted' opts YesReallyFormatPartition fs dev = + cmdProperty cmd opts' `requires` Apt.installed [pkg] + where + (cmd, opts', pkg) = case fs of + EXT2 -> ("mkfs.ext2", optsdev, "e2fsprogs") + EXT3 -> ("mkfs.ext3", optsdev, "e2fsprogs") + EXT4 -> ("mkfs.ext4", optsdev, "e2fsprogs") + BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools") + REISERFS -> ("mkfs.reiserfs", optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", optsdev, "xfsprogs") + FAT -> ("mkfs.fat", optsdev, "dosfstools") + VFAT -> ("mkfs.vfat", optsdev, "dosfstools") + NTFS -> ("mkfs.ntfs", optsdev, "ntfs-3g") + LinuxSwap -> ("mkswap", optsdev, "util-linux") + optsdev = opts++[dev] + +-- | Uses the kpartx utility to create device maps for partitions contained +-- within a disk image file. The resulting devices are passed to the +-- property, which can operate on them. Always cleans up after itself, +-- by removing the device maps after the property is run. +kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo +kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] + where + go = property (propertyDesc (mkprop [])) $ do + s <- liftIO $ readProcess "kpartx" ["-avs", diskimage] + r <- ensureProperty (mkprop (devlist s)) + void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] + return r + devlist = mapMaybe (finddev . words) . lines + finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s) + finddev _ = Nothing -- cgit v1.2.3