summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Installer/Target.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Installer/Target.hs')
-rw-r--r--src/Propellor/Property/Installer/Target.hs460
1 files changed, 460 insertions, 0 deletions
diff --git a/src/Propellor/Property/Installer/Target.hs b/src/Propellor/Property/Installer/Target.hs
new file mode 100644
index 00000000..92b4c681
--- /dev/null
+++ b/src/Propellor/Property/Installer/Target.hs
@@ -0,0 +1,460 @@
+{-# 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 (
+ TargetPartTable(..),
+ targetInstalled,
+ mountTarget,
+ fstabLists,
+ targetBootable,
+ partitionTargetDisk,
+ targetDir,
+ probeDisk,
+ findDiskDevices,
+ 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)
+
+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
+
+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 /= LinuxSwap) partitions
+ swaps targetdev =
+ map (Fstab.SwapPartition . diskPartition targetdev . snd) $
+ filter (\((_, p), _) -> partFs p == 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
+
+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 action is rsyncing the latter
+-- to the former, this allows roughly estimating the percent done.
+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
+
+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)
+
+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)