propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Target.hs (16089B)


      1 {-# LANGUAGE TypeOperators #-}
      2 
      3 -- | Installation to a target disk.
      4 -- 
      5 -- Note that the RevertableProperties in this module are not really
      6 -- revertable; the target disk can't be put back how it was. 
      7 -- The RevertableProperty type is used only to let them  be used
      8 -- in a Versioned Host as shown below.
      9 --
     10 -- Here's an example of a noninteractive installer image using
     11 -- these properties.
     12 --
     13 -- There are two versions of Hosts, the installer and the target system.
     14 -- 
     15 -- > data Variety = Installer | Target
     16 -- > 	deriving (Eq)
     17 -- 
     18 -- The seed of both the installer and the target. They have some properties
     19 -- in common, and some different properties. The `targetInstalled`
     20 -- property knows how to convert the installer it's running on into a
     21 -- target system.
     22 --
     23 -- > seed :: Versioned Variety Host
     24 -- > seed ver = host "debian.local" $ props
     25 -- > 	& osDebian Unstable X86_64
     26 -- > 	& Hostname.sane
     27 -- >	& Hostname.mailname
     28 -- > 	& Apt.stdSourcesList
     29 -- > 	& Apt.installed ["linux-image-amd64"]
     30 -- > 	& Grub.installed PC
     31 -- > 	& "en_US.UTF-8" `Locale.selectedFor` ["LANG"]
     32 -- > 	& ver ( (== Installer) --> targetInstalled seed Target (userInput ver) parts)
     33 -- > 	& ver ( (== Target)    --> fstabLists (userInput ver) parts)
     34 -- > 	& ver ( (== Installer) --> targetBootable (userInput ver))
     35 -- >   where
     36 -- > 	parts = TargetPartTable MSDOS
     37 -- > 		[ partition EXT4 `mountedAt` "/"
     38 -- > 			`useDiskSpace` RemainingSpace
     39 -- > 		, swapPartition (MegaBytes 1024)
     40 -- > 		]
     41 -- 
     42 -- The installer disk image can then be built from the seed as follows:
     43 -- 
     44 -- > installerBuilt :: RevertableProperty (HasInfo + DebianLike) Linux
     45 -- > installerBuilt = imageBuilt (VirtualBoxPointer "/srv/installer.vmdk")
     46 -- >	(hostChroot (seed `version` installer) (Debootstrapped mempty))
     47 -- >	MSDOS
     48 -- > 	 [ partition EXT4 `mountedAt` "/"
     49 -- >		`setFlag` BootFlag
     50 -- >		`reservedSpacePercentage` 0
     51 -- > 		`addFreeSpace` MegaBytes 256
     52 -- > 	]
     53 --
     54 -- When the installer is booted up, and propellor is run, it installs
     55 -- to the target disk. Since this example is a noninteractive installer,
     56 -- the details of what it installs to are configured before it's built.
     57 -- 
     58 -- > data HardCodedUserInput = HardCodedUserInput (Maybe TargetDiskDevice) (Maybe DiskEraseConfirmed)
     59 -- > 
     60 -- > instance UserInput HardCodedUserInput where 
     61 -- > 	targetDiskDevice (HardCodedUserInput t _) = Just t
     62 -- > 	diskEraseConfirmed (HardCodedUserInput _ c) = Just c
     63 -- > 
     64 -- > userInput :: Version -> HardCodedUserInput
     65 -- > userInput Installer =  HardCodedUserInput Nothing Nothing
     66 -- > userInput Target = HardCodedUserInput (Just (TargetDiskDevice "/dev/sda")) (Just DiskEraseConfirmed)
     67 --
     68 -- For an example of how to use this to make an interactive installer,
     69 -- see <https://git.joeyh.name/index.cgi/secret-project.git/>
     70 
     71 module Propellor.Property.Installer.Target (
     72 	-- * Main interface
     73 	TargetPartTable(..),
     74 	targetInstalled,
     75 	fstabLists,
     76 	-- * Additional properties
     77 	mountTarget,
     78 	targetBootable,
     79 	partitionTargetDisk,
     80 	-- * Utility functions
     81 	targetDir,
     82 	probeDisk,
     83 	findDiskDevices,
     84 	-- * Installation progress tracking
     85 	TargetFilled,
     86 	TargetFilledHandle,
     87 	prepTargetFilled,
     88 	checkTargetFilled,
     89 	TargetFilledPercent(..),
     90 	targetFilledPercent,
     91 ) where
     92 
     93 import Propellor
     94 import Propellor.Property.Installer.Types
     95 import Propellor.Message
     96 import Propellor.Types.Bootloader
     97 import Propellor.Types.PartSpec
     98 import Propellor.Property.Chroot
     99 import Propellor.Property.Versioned
    100 import Propellor.Property.Parted
    101 import Propellor.Property.Mount
    102 import qualified Propellor.Property.Fstab as Fstab
    103 import qualified Propellor.Property.Grub as Grub
    104 import qualified Propellor.Property.Rsync as Rsync
    105 
    106 import Text.Read
    107 import Control.Monad
    108 import Control.Monad.IO.Class (liftIO)
    109 import System.Directory
    110 import System.FilePath
    111 import Data.Maybe
    112 import Data.List
    113 import Data.Char
    114 import Data.Ord
    115 import Data.Ratio
    116 import qualified Data.Semigroup as Sem
    117 import System.Process (readProcess)
    118 
    119 -- | Partition table for the target disk.
    120 data TargetPartTable = TargetPartTable TableType [PartSpec DiskPart]
    121 
    122 -- | Property that installs the target system to the TargetDiskDevice
    123 -- specified in the UserInput. That device will be re-partitioned and
    124 -- formatted and all files erased.
    125 --
    126 -- The installation is done efficiently by rsyncing the installer's files
    127 -- to the target, which forms the basis for a chroot that is provisioned with
    128 -- the specified version of the Host. Thanks to
    129 -- Propellor.Property.Versioned, any unwanted properties of the installer
    130 -- will be automatically reverted in the chroot.
    131 --
    132 -- When there is no TargetDiskDevice or the user has not confirmed the
    133 -- installation, nothing is done except for installing dependencies. 
    134 -- So, this can also be used as a property of the installer
    135 -- image.
    136 targetInstalled
    137 	:: UserInput i 
    138 	=> Versioned v Host
    139 	-> v
    140 	-> i
    141 	-> TargetPartTable
    142 	-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
    143 targetInstalled vtargethost v userinput (TargetPartTable tabletype partspec) = 
    144 	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
    145 		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
    146 			go `describe` ("target system installed to " ++ targetdev)
    147 		_ -> tightenTargets installdeps <!> doNothing
    148   where
    149 	targethost = vtargethost `version` v
    150 	go = RevertableProperty
    151 		(setupRevertableProperty p)
    152 		-- Versioned needs both "sides" of the RevertableProperty
    153 		-- to have the same type, so add empty Info to make the
    154 		-- types line up.
    155 		(undoRevertableProperty p `setInfoProperty` mempty)
    156 	  where
    157 		p = partitionTargetDisk userinput tabletype partspec
    158 			`before` mountTarget userinput partspec
    159 			`before` provisioned chroot
    160 	
    161 	chroot = hostChroot targethost RsyncBootstrapper targetDir
    162 
    163 	-- Install dependencies that will be needed later when installing
    164 	-- the target.
    165 	installdeps = Rsync.installed
    166 
    167 data RsyncBootstrapper = RsyncBootstrapper
    168 
    169 instance ChrootBootstrapper RsyncBootstrapper where
    170 	buildchroot RsyncBootstrapper _ target = Right $
    171 		mountaside
    172 			`before` rsynced
    173 			`before` umountaside
    174 	  where
    175 	  	-- bind mount the root filesystem to /mnt, which exposes
    176 		-- the contents of all directories that have things mounted
    177 		-- on top of them to rsync.
    178 		mountaside = bindMount "/" "/mnt"
    179 		rsynced = Rsync.rsync
    180 			[ "--one-file-system"
    181 			, "-aHAXS"
    182 			, "--delete"
    183 			, "/mnt/"
    184 			, target
    185 			]
    186 		umountaside = cmdProperty "umount" ["-l", "/mnt"]
    187 			`assume` MadeChange
    188 
    189 -- | Gets the target mounted.
    190 mountTarget
    191 	:: UserInput i
    192 	=> i
    193 	-> [PartSpec DiskPart]
    194 	-> RevertableProperty Linux Linux
    195 mountTarget userinput partspec = setup <!> cleanup
    196   where
    197 	setup = property "target mounted" $
    198 		case targetDiskDevice userinput of
    199 			Just (TargetDiskDevice targetdev) -> do
    200 				liftIO unmountTarget
    201 				r <- liftIO $ forM tomount $
    202 					mountone targetdev
    203 				if and r
    204 					then return MadeChange
    205 					else return FailedChange
    206 			Nothing -> return NoChange
    207 	cleanup = property "target unmounted" $ do
    208 		liftIO unmountTarget
    209 		liftIO $ removeDirectoryRecursive targetDir
    210 		return NoChange
    211 
    212 	-- Sort so / comes before /home etc
    213 	tomount = sortOn (fst . fst) $
    214 		map (\((mp, mo, _, _), n) -> ((mp, mo), n)) $
    215 		zip partspec partNums
    216 
    217 	mountone targetdev ((mmountpoint, mountopts), num) =
    218 		case mmountpoint of
    219 			Nothing -> return True
    220 			Just mountpoint -> do
    221 				let targetmount = targetDir ++ mountpoint
    222 				createDirectoryIfMissing True targetmount
    223 				let dev = diskPartition targetdev num
    224 				mount "auto" dev targetmount mountopts
    225 
    226 -- | Property for use in the target Host to set up its fstab.
    227 -- Should be passed the same TargetPartTable as `targetInstalled`.
    228 fstabLists
    229 	:: UserInput i
    230 	=> i
    231 	-> TargetPartTable
    232 	-> RevertableProperty Linux Linux
    233 fstabLists userinput (TargetPartTable _ partspecs) = setup <!> doNothing
    234   where
    235 	setup = case targetDiskDevice userinput of
    236 		Just (TargetDiskDevice targetdev) ->
    237 			Fstab.fstabbed mnts (swaps targetdev)
    238 				`requires` devmounted
    239 				`before` devumounted
    240 		Nothing -> doNothing
    241 
    242 	-- needed for ftabbed UUID probing to work
    243 	devmounted :: Property Linux
    244 	devmounted = tightenTargets $ mounted "devtmpfs" "udev" "/dev" mempty
    245 	devumounted :: Property Linux
    246 	devumounted = tightenTargets $ cmdProperty "umount" ["-l", "/dev"]
    247 		`assume` MadeChange
    248 	
    249 	partitions = map (\(mp, _, mkpart, _) -> (mp, mkpart mempty)) partspecs
    250 	mnts = mapMaybe fst $
    251 		filter (\(_, p) -> partFs p /= Just LinuxSwap && partFs p /= Nothing) partitions
    252 	swaps targetdev = 
    253 		map (Fstab.SwapPartition . diskPartition targetdev . snd) $
    254 			filter (\((_, p), _) -> partFs p == Just LinuxSwap)
    255 				(zip partitions partNums)
    256 
    257 -- | Make the target bootable using whatever bootloader is installed on it.
    258 targetBootable
    259 	:: UserInput i
    260 	=> i
    261 	-> RevertableProperty Linux Linux
    262 targetBootable userinput = 
    263 	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
    264 		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
    265 			go targetdev <!> doNothing
    266 		_ -> doNothing <!> doNothing
    267   where
    268 	desc = "bootloader installed on target disk"
    269 	go :: FilePath -> Property Linux
    270 	go targetdev = property' desc $ \w -> do
    271 		bootloaders <- askInfo
    272 		case bootloaders of
    273 			[GrubInstalled gt] -> ensureProperty w $
    274 				Grub.bootsMounted targetDir targetdev gt
    275 			[] -> do
    276 				warningMessage "no bootloader was installed"
    277 				return NoChange
    278 			l -> do
    279 				warningMessage $ "don't know how to enable bootloader(s) " ++ show l
    280 				return FailedChange
    281 
    282 -- | Partitions the target disk.
    283 partitionTargetDisk
    284 	:: UserInput i
    285 	=> i
    286 	-> TableType
    287 	-> [PartSpec DiskPart]
    288 	-> RevertableProperty DebianLike DebianLike
    289 partitionTargetDisk userinput tabletype partspec = go <!> doNothing
    290   where
    291 	go = check targetNotMounted $ property' "target disk partitioned" $ \w -> do
    292 		case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
    293 			(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> do
    294 				liftIO $ unmountTarget
    295 				disksize <- liftIO $ getDiskSize targetdev
    296 				let parttable = calcPartTable disksize tabletype safeAlignment partspec
    297 				ensureProperty w $ 
    298 					partitioned YesReallyDeleteDiskContents targetdev parttable
    299 			_ -> error "user input does not allow partitioning disk"
    300 
    301 unmountTarget :: IO ()
    302 unmountTarget = mapM_ umountLazy . reverse . sort =<< targetMountPoints
    303 
    304 targetMountPoints :: IO [MountPoint]
    305 targetMountPoints = filter isTargetMountPoint <$> mountPoints
    306 
    307 isTargetMountPoint :: MountPoint -> Bool
    308 isTargetMountPoint mp = 
    309 	mp == targetDir 
    310 		|| addTrailingPathSeparator targetDir `isPrefixOf` mp
    311 
    312 targetNotMounted :: IO Bool
    313 targetNotMounted = not . any (== targetDir) <$> mountPoints
    314 
    315 -- | Where the target disk is mounted while it's being installed.
    316 targetDir :: FilePath
    317 targetDir = "/target"
    318 
    319 partNums :: [Integer]
    320 partNums = [1..]
    321 
    322 -- /dev/sda to /dev/sda1
    323 diskPartition :: FilePath -> Integer -> FilePath
    324 diskPartition dev num = dev ++ show num
    325 
    326 -- | This can be used to find a likely disk device to use as the target
    327 -- for an installation.
    328 --
    329 -- This is a bit of a hack; of course the user could be prompted but to
    330 -- avoid prompting, some heuristics...
    331 --   * It should not already be mounted. 
    332 --   * Prefer disks big enough to comfortably hold a Linux installation,
    333 --     so at least 8 gb.
    334 --     (But, if the system only has a smaller disk, it should be used.)
    335 --   * A medium size internal disk is better than a large removable disk,
    336 --     because removable or added drives are often used for data storage
    337 --     on systems with smaller internal disk for the OS.
    338 --     (But, if the internal disk is too small, prefer removable disk;
    339 --     some systems have an unusably small internal disk.)
    340 --   * Prefer the first disk in BIOS order, all other things being equal,
    341 --     because the main OS disk typically comes first. This can be
    342 --     approximated by preferring /dev/sda to /dev/sdb.
    343 probeDisk :: IO TargetDiskDevice
    344 probeDisk = do
    345 	unmountTarget
    346 	mounteddevs <- getMountedDeviceIDs
    347 	let notmounted d = flip notElem (map Just mounteddevs)
    348 		<$> getMinorNumber d
    349 	candidates <- mapM probeCandidate
    350 		=<< filterM notmounted
    351 		=<< findDiskDevices
    352 	case reverse (sort candidates) of
    353 		(Candidate { candidateDevice = Down dev } : _) -> 
    354 			return $ TargetDiskDevice dev
    355 		[] -> error "Unable to find any disk to install to!"
    356 
    357 -- | Find disk devices, such as /dev/sda (not partitions)
    358 findDiskDevices :: IO [FilePath]
    359 findDiskDevices = map ("/dev" </>) . filter isdisk
    360 	<$> getDirectoryContents "/dev"
    361   where
    362 	isdisk ('s':'d':_:[]) = True
    363 	isdisk _ = False
    364 
    365 -- | When comparing two Candidates, the better of the two will be larger.
    366 data Candidate = Candidate
    367 	{ candidateBigEnoughForOS :: Bool
    368 	, candidateIsFixedDisk :: Bool
    369 	-- use Down so that /dev/sda orders larger than /dev/sdb
    370 	, candidateDevice :: Down FilePath
    371 	} deriving (Eq, Ord)
    372 
    373 probeCandidate :: FilePath -> IO Candidate
    374 probeCandidate dev = do
    375 	DiskSize sz <- getDiskSize dev
    376 	isfixeddisk <- not <$> isRemovableDisk dev
    377 	return $ Candidate
    378 		{ candidateBigEnoughForOS = sz >= 8 * onegb
    379 		, candidateIsFixedDisk = isfixeddisk
    380 		, candidateDevice = Down dev
    381 		}
    382   where
    383 	onegb = 1024*1024*1000
    384 
    385 newtype MinorNumber = MinorNumber Integer
    386 	deriving (Eq, Show)
    387 
    388 getMountedDeviceIDs :: IO [MinorNumber]
    389 getMountedDeviceIDs = mapMaybe parse . lines <$> readProcess "findmnt"
    390 	[ "-rn"
    391 	, "--output"
    392 	, "MAJ:MIN"
    393 	]
    394 	""
    395   where
    396 	parse = fmap MinorNumber . readMaybe 
    397 		. dropWhile (not . isDigit) . dropWhile (/= ':')
    398 
    399 -- There is not currently a native haskell interface for getting the minor
    400 -- number of a device.
    401 getMinorNumber :: FilePath -> IO (Maybe MinorNumber)
    402 getMinorNumber dev = fmap MinorNumber . readMaybe 
    403 	<$> readProcess "stat" [ "--printf", "%T", dev ] ""
    404 
    405 -- A removable disk may show up as removable or as hotplug.
    406 isRemovableDisk :: FilePath -> IO Bool
    407 isRemovableDisk dev = do
    408 	isremovable <- checkblk "RM"
    409 	ishotplug <- checkblk "HOTPLUG"
    410 	return (isremovable || ishotplug)
    411   where
    412 	checkblk field = (== "1\n") <$> readProcess "lsblk"
    413 		[ "-rn"
    414 		, "--nodeps"
    415 		, "--output", field
    416 		, dev
    417 		]
    418 		""
    419 
    420 getDiskSize :: FilePath -> IO DiskSize
    421 getDiskSize dev = do
    422 	sectors <- fromMaybe 0 . readMaybe 
    423 		<$> readProcess "blockdev" ["--getsz", dev] ""
    424 	return (DiskSize (sectors * 512))
    425 
    426 getMountsSizes :: IO [(MountPoint, Integer)]
    427 getMountsSizes = mapMaybe (parse . words) . lines <$> readProcess "findmnt" ps ""
    428   where
    429 	ps = ["-rnb", "-o", "TARGET,USED"]
    430 	parse (mp:szs:[]) = do
    431 		sz <- readMaybe szs
    432 		return (mp, sz)
    433 	parse _ = Nothing
    434 
    435 -- | How much of the target disks are used, compared with the size of the
    436 -- installer's root device. Since the main part of an installation
    437 -- is `targetInstalled` rsyncing the latter to the former, this allows
    438 -- roughly estimating the percent done while an install is running,
    439 -- and can be used in some sort of progress display.
    440 data TargetFilled = TargetFilled (Ratio Integer)
    441 	deriving (Show, Eq)
    442 
    443 instance Sem.Semigroup TargetFilled where
    444 	TargetFilled n <> TargetFilled m = TargetFilled (n+m) 
    445 
    446 instance Monoid TargetFilled where
    447 	mempty = TargetFilled (0 % 1)
    448 	mappend = (Sem.<>)
    449 
    450 newtype TargetFilledHandle = TargetFilledHandle Integer
    451 
    452 -- | Prepare for getting `TargetFilled`.
    453 prepTargetFilled :: IO TargetFilledHandle
    454 prepTargetFilled = go =<< getMountSource "/"
    455   where
    456 	go (Just dev) = do
    457 		-- Assumes that the installer uses a single partition.
    458 		DiskSize sz <- getDiskSize dev
    459 		return (TargetFilledHandle sz)
    460 	go Nothing = return (TargetFilledHandle 0)
    461 
    462 -- | Get the current `TargetFilled` value. This is fast enough to be run
    463 -- multiple times per second without using much CPU.
    464 checkTargetFilled :: TargetFilledHandle -> IO TargetFilled
    465 checkTargetFilled (TargetFilledHandle installsz) = do
    466 	targetsz <- sum . map snd . filter (isTargetMountPoint . fst)
    467 		<$> getMountsSizes
    468 	return (TargetFilled (targetsz % max 1 installsz))
    469 
    470 newtype TargetFilledPercent = TargetFilledPercent Int
    471 	deriving (Show, Eq)
    472 
    473 targetFilledPercent :: TargetFilled -> TargetFilledPercent
    474 targetFilledPercent (TargetFilled r) = TargetFilledPercent $ floor percent
    475   where
    476 	percent :: Double
    477 	percent = min 100 (fromRational r * 100)