{-# 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 -- > & Hostname.mailname -- > & 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 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 qualified Data.Semigroup as Sem 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 Sem.Semigroup TargetFilled where TargetFilled n <> TargetFilled m = TargetFilled (n+m) instance Monoid TargetFilled where mempty = TargetFilled (0 % 1) mappend = (Sem.<>) 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)