summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-08-25 18:50:35 -0700
committerJoey Hess2015-08-25 18:56:22 -0700
commitb3c3a7029020126b1ab5e2d5999b7b2707078150 (patch)
tree6820944d88b562fed2c1cb5031d510630be12f97 /src
parent5462723243355c387746b10298db747d95e3e2c9 (diff)
formatting for partitions set up by parted
Including support for formatting partitions of a disk image file.
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/DiskImage.hs1
-rw-r--r--src/Propellor/Property/Parted.hs61
-rw-r--r--src/Propellor/Property/Partition.hs54
3 files changed, 102 insertions, 14 deletions
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