propellor

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

Parted.hs (7771B)


      1 {-# LANGUAGE FlexibleContexts #-}
      2 
      3 module Propellor.Property.Parted (
      4 	-- * Types
      5 	TableType(..),
      6 	PartTable(..),
      7 	partTableSize,
      8 	Partition(..),
      9 	mkPartition,
     10 	Partition.Fs(..),
     11 	PartSize(..),
     12 	ByteSize,
     13 	toPartSize,
     14 	fromPartSize,
     15 	reducePartSize,
     16 	Alignment(..),
     17 	safeAlignment,
     18 	Partition.MkfsOpts,
     19 	PartType(..),
     20 	PartFlag(..),
     21 	-- * Properties
     22 	partitioned,
     23 	parted,
     24 	Eep(..),
     25 	installed,
     26 	-- * Partition table sizing
     27 	calcPartTable,
     28 	DiskSize(..),
     29 	DiskPart,
     30 	DiskSpaceUse(..),
     31 	useDiskSpace,
     32 	defSz,
     33 	fudgeSz,
     34 ) where
     35 
     36 import Propellor.Base
     37 import Propellor.Property.Parted.Types
     38 import qualified Propellor.Property.Apt as Apt
     39 import qualified Propellor.Property.Pacman as Pacman
     40 import qualified Propellor.Property.Partition as Partition
     41 import Propellor.Types.PartSpec (PartSpec)
     42 import Utility.DataUnits
     43 
     44 import System.Posix.Files
     45 import qualified Data.Semigroup as Sem
     46 import Data.List (genericLength)
     47 
     48 data Eep = YesReallyDeleteDiskContents
     49 
     50 -- | Partitions a disk using parted, and formats the partitions.
     51 --
     52 -- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file.
     53 --
     54 -- This deletes any existing partitions in the disk! Use with EXTREME caution!
     55 partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike
     56 partitioned eep disk parttable@(PartTable _ _ parts) = property' desc $ \w -> do
     57 	isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
     58 	ensureProperty w $ combineProperties desc $ props
     59 		& parted eep disk (fst (calcPartedParamsSize parttable))
     60 		& if isdev
     61 			then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
     62 			else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
     63   where
     64 	desc = disk ++ " partitioned"
     65 	formatl devs = combineProperties desc (toProps $ map format (zip parts devs))
     66 	format (p, dev) = case partFs p of
     67 		Just fs -> Partition.formatted' (partMkFsOpts p)
     68 			Partition.YesReallyFormatPartition fs dev
     69 		Nothing -> doNothing
     70 
     71 -- | Gets the total size of the disk specified by the partition table.
     72 partTableSize :: PartTable -> ByteSize
     73 partTableSize = snd . calcPartedParamsSize
     74 
     75 calcPartedParamsSize :: PartTable -> ([String], ByteSize)
     76 calcPartedParamsSize (PartTable tabletype alignment parts) = 
     77 	let (ps, sz) = calcparts (1 :: Integer) firstpos parts []
     78 	in (concat (mklabel : ps), sz)
     79   where
     80 	mklabel = ["mklabel", pval tabletype]
     81 	mkflag partnum (f, b) =
     82 		[ "set"
     83 		, show partnum
     84 		, pval f
     85 		, pval b
     86 		]
     87 	mkpart partnum startpos endpos p = catMaybes
     88 		[ Just "mkpart"
     89 		, Just $ pval (partType p)
     90 		, fmap pval (partFs p)
     91 		, Just $ partposexact startpos
     92 		, Just $ partposfuzzy endpos
     93 		] ++ case partName p of
     94 			Just n -> ["name", show partnum, n]
     95 			Nothing -> []
     96 	calcparts partnum startpos (p:ps) c =
     97 		let endpos = startpos + align (partSize p)
     98 		in calcparts (partnum+1) endpos ps
     99 			(c ++ mkpart partnum startpos (endpos-1) p : map (mkflag partnum) (partFlags p))
    100 	calcparts _ endpos [] c = (c, endpos)
    101 
    102 	-- Exact partition position value for parted.
    103 	-- For alignment to work, the start of a partition must be
    104 	-- specified exactly.
    105 	partposexact n
    106 		| n > 0 = show n ++ "B"
    107 		-- parted can't make partitions smaller than 1MB;
    108 		-- avoid failure in edge cases
    109 		| otherwise = "1MB"
    110 	
    111 	-- Fuzzy partition position valie for parted.
    112 	-- This is used to specify the end of the partition,
    113 	-- parted takes the "MB" as license to slightly reduce the
    114 	-- partition size when something about the partition table
    115 	-- does not allow the partition to end exactly at the position.
    116 	partposfuzzy n
    117 		| n > 0 = show (fromIntegral n / 1000000 :: Double) ++ "MB"
    118 		| otherwise = "1MB"
    119 
    120 	-- Location of the start of the first partition,
    121 	-- leaving space for the partition table, and aligning.
    122 	firstpos = align partitionTableOverhead
    123 	
    124 	align = alignTo alignment
    125 
    126 -- | Runs parted on a disk with the specified parameters.
    127 --
    128 -- Parted is run in script mode, so it will never prompt for input.
    129 parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux)
    130 parted YesReallyDeleteDiskContents disk ps = p `requires` installed
    131   where
    132 	p = cmdProperty "parted" ("--script":"--align":"none":disk:ps)
    133 		`assume` MadeChange
    134 
    135 -- | Gets parted installed.
    136 installed :: Property (DebianLike + ArchLinux)
    137 installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"]
    138 
    139 -- | Some disk is used to store the partition table itself. Assume less
    140 -- than 1 mb.
    141 partitionTableOverhead :: PartSize
    142 partitionTableOverhead = MegaBytes 1
    143 
    144 -- | Calculate a partition table, for a given size of disk.
    145 --
    146 -- For example:
    147 --
    148 -- >	calcPartTable (DiskSize (1024 * 1024 * 1024 * 100)) MSDOS safeAlignment
    149 -- > 		[ partition EXT2 `mountedAt` "/boot"
    150 -- > 			`setSize` MegaBytes 256
    151 -- > 			`setFlag` BootFlag
    152 -- >		, partition EXT4 `mountedAt` "/"
    153 -- >			`useDiskSpace` RemainingSpace
    154 -- >		]
    155 calcPartTable :: DiskSize -> TableType -> Alignment -> [PartSpec DiskPart] -> PartTable
    156 calcPartTable (DiskSize disksize) tt alignment l =
    157 	PartTable tt alignment (map go l)
    158   where
    159 	go (_, _, mkpart, FixedDiskPart) = mkpart defSz
    160 	go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ Bytes $
    161 		diskremainingafterfixed * fromIntegral p `div` 100
    162 	go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ Bytes $
    163 		diskremaining `div` genericLength (filter isremainingspace l)
    164 	diskremainingafterfixed =
    165 		disksize - sumsizes (filter isfixed l)
    166 	diskremaining =
    167 		disksize - sumsizes (filter (not . isremainingspace) l)
    168 	sumsizes = partTableSize . PartTable tt alignment . map go
    169 	isfixed (_, _, _, FixedDiskPart) = True
    170 	isfixed _ = False
    171 	isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True
    172 	isremainingspace _ = False
    173 
    174 -- | Size of a disk, in bytes.
    175 newtype DiskSize = DiskSize ByteSize
    176 	deriving (Show)
    177 
    178 data DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse
    179 
    180 data DiskSpaceUse = Percent Int | RemainingSpace
    181 
    182 instance Sem.Semigroup DiskPart where
    183 	FixedDiskPart <> FixedDiskPart = FixedDiskPart
    184 	DynamicDiskPart (Percent a) <> DynamicDiskPart (Percent b) =
    185 		DynamicDiskPart (Percent (a + b))
    186 	DynamicDiskPart RemainingSpace <> DynamicDiskPart RemainingSpace = 
    187 		DynamicDiskPart RemainingSpace
    188 	DynamicDiskPart (Percent a) <> _ = DynamicDiskPart (Percent a)
    189 	_ <> DynamicDiskPart (Percent b) = DynamicDiskPart (Percent b)
    190 	DynamicDiskPart RemainingSpace <> _ = DynamicDiskPart RemainingSpace
    191 	_ <> DynamicDiskPart RemainingSpace = DynamicDiskPart RemainingSpace
    192 
    193 instance Monoid DiskPart
    194   where
    195 	mempty = FixedDiskPart
    196 	mappend = (Sem.<>)
    197 
    198 -- | Make a partition use some percentage of the size of the disk
    199 -- (less all fixed size partitions), or the remaining space in the disk.
    200 useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart
    201 useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse)
    202 
    203 -- | Default partition size when not otherwize specified is 128 MegaBytes.
    204 defSz :: PartSize
    205 defSz = MegaBytes 128
    206 
    207 -- | When a partition is sized to fit the files that live in it,
    208 -- this fudge factor is added to the size of the files. This is necessary
    209 -- since filesystems have some space overhead.
    210 -- 
    211 -- Add 2% for filesystem overhead. Rationalle for picking 2%:
    212 -- A filesystem with 1% overhead might just sneak by as acceptable.
    213 -- Double that just in case. Add an additional 3 mb to deal with
    214 -- non-scaling overhead of filesystems (eg, superblocks). 
    215 -- Add an additional 200 mb for temp files, journals, etc.
    216 fudgeSz :: PartSize -> PartSize
    217 fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
    218 fudgeSz (Bytes n) = fudgeSz (toPartSize n)
    219 
    220 alignTo :: Alignment -> PartSize -> ByteSize
    221 alignTo _ (Bytes n) = n -- no alignment done for Bytes
    222 alignTo (Alignment alignment) partsize
    223 	| alignment < 1 = n
    224 	| otherwise = case rem n alignment of
    225 		0 -> n
    226 		r -> n - r + alignment
    227   where
    228 	n = fromPartSize partsize