summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/DiskImage/PartSpec.hs
blob: b78e4280db4c98e9de580124863e952fa81c1b66 (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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

-- | Disk image partition specification.

module Propellor.Property.DiskImage.PartSpec (
	PartSpec,
	Fs(..),
	PartSize(..),
	partition,
	-- * PartSpec combinators
	swapPartition,
	rawPartition,
	mountedAt,
	addFreeSpace,
	setSize,
	mountOpt,
	errorReadonly,
	reservedSpacePercentage,
	setFlag,
	extended,
	-- * Partition properties
	--
	-- | These properties do not do any disk partitioning on their own, but
	-- the Info they set can be used when building a disk image for a
	-- host.
	hasPartition,
	adjustPartition,
	PartLocation(..),
	partLocation,
	hasPartitionTableType,
	TableType(..),
	PartInfo,
	toPartTableSpec,
	PartTableSpec(..)
) where

import Propellor.Base
import Propellor.Property.Parted
import Propellor.Types.PartSpec
import Propellor.Types.Info
import Propellor.Property.Partition (Fs(..))
import Propellor.Property.Mount

import Data.List (sortBy)
import Data.Ord

-- | Specifies a partition with a given filesystem.
--
-- The partition is not mounted anywhere by default; use the combinators
-- below to configure it.
partition :: Monoid t => Fs -> PartSpec t
partition fs = (Nothing, mempty, mkPartition (Just fs), mempty)

-- | Specifies a swap partition of a given size.
swapPartition :: Monoid t => PartSize -> PartSpec t
swapPartition sz = (Nothing, mempty, const (mkPartition (Just LinuxSwap) sz), mempty)

-- | Specifies a partition without any filesystem, of a given size.
rawPartition :: Monoid t => PartSize -> PartSpec t
rawPartition sz = (Nothing, mempty, const (mkPartition Nothing sz), mempty)

-- | Specifies where to mount a partition.
mountedAt :: PartSpec t -> MountPoint -> PartSpec t
mountedAt (_, o, p, t) mp = (Just mp, o, p, t)

-- | Partitions in disk images default to being sized large enough to hold
-- the files that live in that partition.
--
-- This adds additional free space to a partition.
addFreeSpace :: PartSpec t -> PartSize -> PartSpec t
addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)
  where
	p' = \sz -> p (sz <> freesz)

-- | Specify a fixed size for a partition.
setSize :: PartSpec t -> PartSize -> PartSpec t
setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)

-- | Specifies a mount option, such as "noexec"
mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)

-- | Mount option to make a partition be remounted readonly when there's an
-- error accessing it.
errorReadonly :: MountOpts
errorReadonly = toMountOpts "errors=remount-ro"

-- | 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 t -> Int -> PartSpec t
reservedSpacePercentage s percent = adjustp s $ \p -> 
	p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }

-- | Sets a flag on the partition.
setFlag :: PartSpec t -> PartFlag -> PartSpec t
setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }

-- | Makes a MSDOS partition be Extended, rather than Primary.
extended :: PartSpec t -> PartSpec t
extended s = adjustp s $ \p -> p { partType = Extended }

adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp (mp, o, p, t) f = (mp, o, f . p, t)

data PartInfoVal
	= TableTypeInfo TableType
	| PartSpecInfo (PartSpec PartLocation)
	| AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation)

newtype PartInfo = PartInfo [PartInfoVal]
	deriving (Monoid, Typeable)

instance IsInfo PartInfo where
	propagateInfo _ = PropagateInfo False

instance Show PartInfo where
	show = show . toPartTableSpec

toPartTableSpec :: PartInfo -> PartTableSpec
toPartTableSpec (PartInfo l) = PartTableSpec tt pil
  where
	tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l

	pil = map convert $ sortBy (comparing location) $ adjust collect
	collect = mapMaybe getspartspec l
	adjust ps = adjust' ps (mapMaybe getadjust l)
	adjust' ps [] = ps
	adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest
	adjustone mp f p@(mp', _, _, _)
		| Just mp == mp' = f p
		| otherwise = p
	location (_, _, _, loc) = loc
	convert (mp, o, p, _) = (mp, o, p, ())
	
	gettt (TableTypeInfo t) = Just t
	gettt _ = Nothing
	getspartspec (PartSpecInfo ps) = Just ps
	getspartspec _ = Nothing
	getadjust (AdjustPartSpecInfo mp f) = Just (mp, f)
	getadjust _ = Nothing

-- | Indicates the partition table type of a host.
--
-- When not specified, the default is MSDOS.
--
-- For example:
--
-- >	& hasPartitionTableType GPT
hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike)
hasPartitionTableType tt = pureInfoProperty
	("partition table type " ++ show tt)
	(PartInfo [TableTypeInfo tt])

-- | Indicates that a host has a partition.
--
-- For example:
--
-- >	& hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning)
-- >	& hasPartiton (partition EXT4 `mountedAt` "/")
-- >	& hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0)
hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike)
hasPartition p@(mmp, _, _, _) = pureInfoProperty desc
	(PartInfo [PartSpecInfo p])
  where
	desc = case mmp of
		Just mp -> mp ++ " partition"
		Nothing -> "unmounted partition"

-- | Adjusts the PartSpec for the partition mounted at the specified location.
--
-- For example:
--
-- > 	& adjustPartition "/boot" (`addFreeSpace` MegaBytes 150)
adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike)
adjustPartition mp f = pureInfoProperty
	(mp ++ " adjusted")
	(PartInfo [AdjustPartSpecInfo mp f])

-- | Indicates partition layout in a disk. Default is somewhere in the
-- middle.
data PartLocation = Beginning | Middle | End
	deriving (Eq, Ord)

instance Monoid PartLocation where
	mempty = Middle
	mappend _ b = b

partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation
partLocation (mp, o, p, _) l = (mp, o, p, l)