summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Installer/Target.hs
blob: 80e660ad76a24a34b6b7dd226b8535a2955da3fb (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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
{-# LANGUAGE TypeOperators #-}

-- | Installation to a target disk.
-- 
-- Note that the RevertableProperties in this module are not really
-- revertable; the target disk can't be put back how it was. 
-- The RevertableProperty type is used only to let them  be used
-- in a Versioned Host as shown below.
--
-- Here's an example of a noninteractive installer image using
-- these properties.
--
-- There are two versions of Hosts, the installer and the target system.
-- 
-- > data Variety = Installer | Target
-- > 	deriving (Eq)
-- 
-- The seed of both the installer and the target. They have some properties
-- in common, and some different properties. The `targetInstalled`
-- property knows how to convert the installer it's running on into a
-- target system.
--
-- > seed :: Versioned Variety Host
-- > seed ver = host "debian.local" $ props
-- > 	& osDebian Unstable X86_64
-- > 	& Hostname.sane
-- > 	& Apt.stdSourcesList
-- > 	& Apt.installed ["linux-image-amd64"]
-- > 	& Grub.installed PC
-- > 	& "en_US.UTF-8" `Locale.selectedFor` ["LANG"]
-- > 	& ver ( (== Installer) --> targetInstalled seed Target (userInput ver) parts)
-- > 	& ver ( (== Target)    --> fstabLists (userInput ver) parts)
-- > 	& ver ( (== Installer) --> targetBootable (userInput ver))
-- >   where
-- > 	parts = TargetPartTable MSDOS
-- > 		[ partition EXT4 `mountedAt` "/"
-- > 			`useDiskSpace` RemainingSpace
-- > 		, swapPartition (MegaBytes 1024)
-- > 		]
-- 
-- The installer disk image can then be built from the seed as follows:
-- 
-- > installerBuilt :: RevertableProperty (HasInfo + DebianLike) Linux
-- > installerBuilt = imageBuilt (VirtualBoxPointer "/srv/installer.vmdk")
-- >	(hostChroot (seed `version` installer) (Debootstrapped mempty))
-- >	MSDOS
-- > 	 [ partition EXT4 `mountedAt` "/"
-- >		`setFlag` BootFlag
-- >		`reservedSpacePercentage` 0
-- > 		`addFreeSpace` MegaBytes 256
-- > 	]
--
-- When the installer is booted up, and propellor is run, it installs
-- to the target disk. Since this example is a noninteractive installer,
-- the details of what it installs to are configured before it's built.
-- 
-- > data HardCodedUserInput = HardCodedUserInput (Maybe TargetDiskDevice) (Maybe DiskEraseConfirmed)
-- > 
-- > instance UserInput HardCodedUserInput where 
-- > 	targetDiskDevice (HardCodedUserInput t _) = Just t
-- > 	diskEraseConfirmed (HardCodedUserInput _ c) = Just c
-- > 
-- > userInput :: Version -> HardCodedUserInput
-- > userInput Installer =  HardCodedUserInput Nothing Nothing
-- > userInput Target = HardCodedUserInput (Just (TargetDiskDevice "/dev/sda")) (Just DiskEraseConfirmed)
--
-- For an example of how to use this to make an interactive installer,
-- see <https://git.joeyh.name/index.cgi/secret-project.git/>

module Propellor.Property.Installer.Target (
	-- * Main interface
	TargetPartTable(..),
	targetInstalled,
	fstabLists,
	-- * Additional properties
	mountTarget,
	targetBootable,
	partitionTargetDisk,
	-- * Utility functions
	targetDir,
	probeDisk,
	findDiskDevices,
	-- * Installation progress tracking
	TargetFilled,
	TargetFilledHandle,
	prepTargetFilled,
	checkTargetFilled,
	TargetFilledPercent(..),
	targetFilledPercent,
) where

import Propellor
import Propellor.Property.Installer.Types
import Propellor.Message
import Propellor.Types.Bootloader
import Propellor.Types.PartSpec
import Propellor.Property.Chroot
import Propellor.Property.Versioned
import Propellor.Property.Parted
import Propellor.Property.Mount
import qualified Propellor.Property.Fstab as Fstab
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Rsync as Rsync

import Text.Read
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import System.Directory
import System.FilePath
import Data.Maybe
import Data.List
import Data.Char
import Data.Ord
import Data.Ratio
import System.Process (readProcess)

-- | Partition table for the target disk.
data TargetPartTable = TargetPartTable TableType [PartSpec DiskPart]

-- | Property that installs the target system to the TargetDiskDevice
-- specified in the UserInput. That device will be re-partitioned and
-- formatted and all files erased.
--
-- The installation is done efficiently by rsyncing the installer's files
-- to the target, which forms the basis for a chroot that is provisioned with
-- the specified version of the Host. Thanks to
-- Propellor.Property.Versioned, any unwanted properties of the installer
-- will be automatically reverted in the chroot.
--
-- When there is no TargetDiskDevice or the user has not confirmed the
-- installation, nothing is done except for installing dependencies. 
-- So, this can also be used as a property of the installer
-- image.
targetInstalled
	:: UserInput i 
	=> Versioned v Host
	-> v
	-> i
	-> TargetPartTable
	-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
targetInstalled vtargethost v userinput (TargetPartTable tabletype partspec) = 
	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
			go `describe` ("target system installed to " ++ targetdev)
		_ -> tightenTargets installdeps <!> doNothing
  where
	targethost = vtargethost `version` v
	go = RevertableProperty
		(setupRevertableProperty p)
		-- Versioned needs both "sides" of the RevertableProperty
		-- to have the same type, so add empty Info to make the
		-- types line up.
		(undoRevertableProperty p `setInfoProperty` mempty)
	  where
		p = partitionTargetDisk userinput tabletype partspec
			`before` mountTarget userinput partspec
			`before` provisioned chroot
	
	chroot = hostChroot targethost RsyncBootstrapper targetDir

	-- Install dependencies that will be needed later when installing
	-- the target.
	installdeps = Rsync.installed

data RsyncBootstrapper = RsyncBootstrapper

instance ChrootBootstrapper RsyncBootstrapper where
	buildchroot RsyncBootstrapper _ target = Right $
		mountaside
			`before` rsynced
			`before` umountaside
	  where
	  	-- bind mount the root filesystem to /mnt, which exposes
		-- the contents of all directories that have things mounted
		-- on top of them to rsync.
		mountaside = bindMount "/" "/mnt"
		rsynced = Rsync.rsync
			[ "--one-file-system"
			, "-aHAXS"
			, "--delete"
			, "/mnt/"
			, target
			]
		umountaside = cmdProperty "umount" ["-l", "/mnt"]
			`assume` MadeChange

-- | Gets the target mounted.
mountTarget
	:: UserInput i
	=> i
	-> [PartSpec DiskPart]
	-> RevertableProperty Linux Linux
mountTarget userinput partspec = setup <!> cleanup
  where
	setup = property "target mounted" $
		case targetDiskDevice userinput of
			Just (TargetDiskDevice targetdev) -> do
				liftIO unmountTarget
				r <- liftIO $ forM tomount $
					mountone targetdev
				if and r
					then return MadeChange
					else return FailedChange
			Nothing -> return NoChange
	cleanup = property "target unmounted" $ do
		liftIO unmountTarget
		liftIO $ removeDirectoryRecursive targetDir
		return NoChange

	-- Sort so / comes before /home etc
	tomount = sortOn (fst . fst) $
		map (\((mp, mo, _, _), n) -> ((mp, mo), n)) $
		zip partspec partNums

	mountone targetdev ((mmountpoint, mountopts), num) =
		case mmountpoint of
			Nothing -> return True
			Just mountpoint -> do
				let targetmount = targetDir ++ mountpoint
				createDirectoryIfMissing True targetmount
				let dev = diskPartition targetdev num
				mount "auto" dev targetmount mountopts

-- | Property for use in the target Host to set up its fstab.
-- Should be passed the same TargetPartTable as `targetInstalled`.
fstabLists
	:: UserInput i
	=> i
	-> TargetPartTable
	-> RevertableProperty Linux Linux
fstabLists userinput (TargetPartTable _ partspecs) = setup <!> doNothing
  where
	setup = case targetDiskDevice userinput of
		Just (TargetDiskDevice targetdev) ->
			Fstab.fstabbed mnts (swaps targetdev)
				`requires` devmounted
				`before` devumounted
		Nothing -> doNothing

	-- needed for ftabbed UUID probing to work
	devmounted :: Property Linux
	devmounted = tightenTargets $ mounted "devtmpfs" "udev" "/dev" mempty
	devumounted :: Property Linux
	devumounted = tightenTargets $ cmdProperty "umount" ["-l", "/dev"]
		`assume` MadeChange
	
	partitions = map (\(mp, _, mkpart, _) -> (mp, mkpart mempty)) partspecs
	mnts = mapMaybe fst $
		filter (\(_, p) -> partFs p /= Just LinuxSwap && partFs p /= Nothing) partitions
	swaps targetdev = 
		map (Fstab.SwapPartition . diskPartition targetdev . snd) $
			filter (\((_, p), _) -> partFs p == Just LinuxSwap)
				(zip partitions partNums)

-- | Make the target bootable using whatever bootloader is installed on it.
targetBootable
	:: UserInput i
	=> i
	-> RevertableProperty Linux Linux
targetBootable userinput = 
	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
			go targetdev <!> doNothing
		_ -> doNothing <!> doNothing
  where
	desc = "bootloader installed on target disk"
	go :: FilePath -> Property Linux
	go targetdev = property' desc $ \w -> do
		bootloaders <- askInfo
		case bootloaders of
			[GrubInstalled gt] -> ensureProperty w $
				Grub.bootsMounted targetDir targetdev gt
			[] -> do
				warningMessage "no bootloader was installed"
				return NoChange
			l -> do
				warningMessage $ "don't know how to enable bootloader(s) " ++ show l
				return FailedChange

-- | Partitions the target disk.
partitionTargetDisk
	:: UserInput i
	=> i
	-> TableType
	-> [PartSpec DiskPart]
	-> RevertableProperty DebianLike DebianLike
partitionTargetDisk userinput tabletype partspec = go <!> doNothing
  where
	go = check targetNotMounted $ property' "target disk partitioned" $ \w -> do
		case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
			(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> do
				liftIO $ unmountTarget
				disksize <- liftIO $ getDiskSize targetdev
				let parttable = calcPartTable disksize tabletype safeAlignment partspec
				ensureProperty w $ 
					partitioned YesReallyDeleteDiskContents targetdev parttable
			_ -> error "user input does not allow partitioning disk"

unmountTarget :: IO ()
unmountTarget = mapM_ umountLazy . reverse . sort =<< targetMountPoints

targetMountPoints :: IO [MountPoint]
targetMountPoints = filter isTargetMountPoint <$> mountPoints

isTargetMountPoint :: MountPoint -> Bool
isTargetMountPoint mp = 
	mp == targetDir 
		|| addTrailingPathSeparator targetDir `isPrefixOf` mp

targetNotMounted :: IO Bool
targetNotMounted = not . any (== targetDir) <$> mountPoints

-- | Where the target disk is mounted while it's being installed.
targetDir :: FilePath
targetDir = "/target"

partNums :: [Integer]
partNums = [1..]

-- /dev/sda to /dev/sda1
diskPartition :: FilePath -> Integer -> FilePath
diskPartition dev num = dev ++ show num

-- | This can be used to find a likely disk device to use as the target
-- for an installation.
--
-- This is a bit of a hack; of course the user could be prompted but to
-- avoid prompting, some heuristics...
--   * It should not already be mounted. 
--   * Prefer disks big enough to comfortably hold a Linux installation,
--     so at least 8 gb.
--     (But, if the system only has a smaller disk, it should be used.)
--   * A medium size internal disk is better than a large removable disk,
--     because removable or added drives are often used for data storage
--     on systems with smaller internal disk for the OS.
--     (But, if the internal disk is too small, prefer removable disk;
--     some systems have an unusably small internal disk.)
--   * Prefer the first disk in BIOS order, all other things being equal,
--     because the main OS disk typically comes first. This can be
--     approximated by preferring /dev/sda to /dev/sdb.
probeDisk :: IO TargetDiskDevice
probeDisk = do
	unmountTarget
	mounteddevs <- getMountedDeviceIDs
	let notmounted d = flip notElem (map Just mounteddevs)
		<$> getMinorNumber d
	candidates <- mapM probeCandidate
		=<< filterM notmounted
		=<< findDiskDevices
	case reverse (sort candidates) of
		(Candidate { candidateDevice = Down dev } : _) -> 
			return $ TargetDiskDevice dev
		[] -> error "Unable to find any disk to install to!"

-- | Find disk devices, such as /dev/sda (not partitions)
findDiskDevices :: IO [FilePath]
findDiskDevices = map ("/dev" </>) . filter isdisk
	<$> getDirectoryContents "/dev"
  where
	isdisk ('s':'d':_:[]) = True
	isdisk _ = False

-- | When comparing two Candidates, the better of the two will be larger.
data Candidate = Candidate
	{ candidateBigEnoughForOS :: Bool
	, candidateIsFixedDisk :: Bool
	-- use Down so that /dev/sda orders larger than /dev/sdb
	, candidateDevice :: Down FilePath
	} deriving (Eq, Ord)

probeCandidate :: FilePath -> IO Candidate
probeCandidate dev = do
	DiskSize sz <- getDiskSize dev
	isfixeddisk <- not <$> isRemovableDisk dev
	return $ Candidate
		{ candidateBigEnoughForOS = sz >= 8 * onegb
		, candidateIsFixedDisk = isfixeddisk
		, candidateDevice = Down dev
		}
  where
	onegb = 1024*1024*1000

newtype MinorNumber = MinorNumber Integer
	deriving (Eq, Show)

getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = mapMaybe parse . lines <$> readProcess "findmnt"
	[ "-rn"
	, "--output"
	, "MAJ:MIN"
	]
	""
  where
	parse = fmap MinorNumber . readMaybe 
		. dropWhile (not . isDigit) . dropWhile (/= ':')

-- There is not currently a native haskell interface for getting the minor
-- number of a device.
getMinorNumber :: FilePath -> IO (Maybe MinorNumber)
getMinorNumber dev = fmap MinorNumber . readMaybe 
	<$> readProcess "stat" [ "--printf", "%T", dev ] ""

-- A removable disk may show up as removable or as hotplug.
isRemovableDisk :: FilePath -> IO Bool
isRemovableDisk dev = do
	isremovable <- checkblk "RM"
	ishotplug <- checkblk "HOTPLUG"
	return (isremovable || ishotplug)
  where
	checkblk field = (== "1\n") <$> readProcess "lsblk"
		[ "-rn"
		, "--nodeps"
		, "--output", field
		, dev
		]
		""

getDiskSize :: FilePath -> IO DiskSize
getDiskSize dev = do
	sectors <- fromMaybe 0 . readMaybe 
		<$> readProcess "blockdev" ["--getsz", dev] ""
	return (DiskSize (sectors * 512))

getMountsSizes :: IO [(MountPoint, Integer)]
getMountsSizes = mapMaybe (parse . words) . lines <$> readProcess "findmnt" ps ""
  where
	ps = ["-rnb", "-o", "TARGET,USED"]
	parse (mp:szs:[]) = do
		sz <- readMaybe szs
		return (mp, sz)
	parse _ = Nothing

-- | How much of the target disks are used, compared with the size of the
-- installer's root device. Since the main part of an installation
-- is `targetInstalled` rsyncing the latter to the former, this allows
-- roughly estimating the percent done while an install is running,
-- and can be used in some sort of progress display.
data TargetFilled = TargetFilled (Ratio Integer)
	deriving (Show, Eq)

instance Monoid TargetFilled where
	mempty = TargetFilled (0 % 1)
	mappend (TargetFilled n) (TargetFilled m) = TargetFilled (n+m)

newtype TargetFilledHandle = TargetFilledHandle Integer

-- | Prepare for getting `TargetFilled`.
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled = go =<< getMountSource "/"
  where
	go (Just dev) = do
		-- Assumes that the installer uses a single partition.
		DiskSize sz <- getDiskSize dev
		return (TargetFilledHandle sz)
	go Nothing = return (TargetFilledHandle 0)

-- | Get the current `TargetFilled` value. This is fast enough to be run
-- multiple times per second without using much CPU.
checkTargetFilled :: TargetFilledHandle -> IO TargetFilled
checkTargetFilled (TargetFilledHandle installsz) = do
	targetsz <- sum . map snd . filter (isTargetMountPoint . fst)
		<$> getMountsSizes
	return (TargetFilled (targetsz % max 1 installsz))

newtype TargetFilledPercent = TargetFilledPercent Int
	deriving (Show, Eq)

targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent (TargetFilled r) = TargetFilledPercent $ floor percent
  where
	percent :: Double
	percent = min 100 (fromRational r * 100)