summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Parted.hs
blob: 2b741234b8ab67f035c5e69d67bc71a44eef27f8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
{-# LANGUAGE FlexibleContexts #-}

module Propellor.Property.Parted (
	TableType(..),
	PartTable(..),
	Partition(..),
	mkPartition,
	Partition.Fs(..),
	Partition.MkfsOpts,
	PartType(..),
	PartFlag(..),
	Eep(..),
	partitioned,
	parted,
	installed,
) where

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

-- | 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)

-- | A partition on the disk.
data Partition = Partition
	{ partType :: PartType
	, 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)

instance PartedVal PartType where
	val Primary = "primary"
	val Logical = "logical"
	val Extended = "extended"

-- | 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"

data Eep = YesReallyDeleteDiskContents

-- | Partitions a disk using parted, and formats the partitions.
--
-- 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) = 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"
		, show partnum
		, val f
		, val b
		]
	setunits = ["unit", "B"] -- tell parted we use bytes
	mkpart partnum offset p =
		[ "mkpart"
		, show partnum
		, val (partType p)
		, val (partFs p)
		, show offset
		, show (offset + partSize p)
		] ++ case partName p of
			Just n -> ["name", show partnum, n]
			Nothing -> []
	mkparts partnum offset (p:ps) c = 
		mkparts (partnum+1) (offset + partSize p) ps
			(c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p))
	mkparts _ _ [] c = c

-- | Runs parted on a disk with the specified parameters.
--
-- Parted is run in script mode, so it will never prompt for input.
-- It is asked to use optimal alignment for the disk, for best performance.
parted :: Eep -> FilePath -> [String] -> Property NoInfo
parted YesReallyDeleteDiskContents disk ps = 
	cmdProperty "parted" ("--script":"--align":"optimal":disk:ps)
		`requires` installed

-- | Gets parted installed.
installed :: Property NoInfo
installed = Apt.installed ["parted"]