propellor

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

PartSpec.hs (6139B)


      1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
      2 
      3 -- | Disk image partition specification.
      4 
      5 module Propellor.Property.DiskImage.PartSpec (
      6 	PartSpec,
      7 	Fs(..),
      8 	PartSize(..),
      9 	partition,
     10 	-- * PartSpec combinators
     11 	swapPartition,
     12 	rawPartition,
     13 	mountedAt,
     14 	addFreeSpace,
     15 	setSize,
     16 	mountOpt,
     17 	errorReadonly,
     18 	reservedSpacePercentage,
     19 	setFlag,
     20 	extended,
     21 	-- * Partition properties
     22 	--
     23 	-- | These properties do not do any disk partitioning on their own, but
     24 	-- the Info they set can be used when building a disk image for a
     25 	-- host.
     26 	hasPartition,
     27 	adjustPartition,
     28 	PartLocation(..),
     29 	partLocation,
     30 	hasPartitionTableType,
     31 	TableType(..),
     32 	PartInfo,
     33 	toPartTableSpec,
     34 	PartTableSpec(..)
     35 ) where
     36 
     37 import Propellor.Base
     38 import Propellor.Property.Parted
     39 import Propellor.Types.PartSpec
     40 import Propellor.Types.Info
     41 import Propellor.Property.Partition (Fs(..))
     42 import Propellor.Property.Mount
     43 
     44 import Data.List (sortBy)
     45 import Data.Ord
     46 import qualified Data.Semigroup as Sem
     47 
     48 -- | Specifies a partition with a given filesystem.
     49 --
     50 -- The partition is not mounted anywhere by default; use the combinators
     51 -- below to configure it.
     52 partition :: Monoid t => Fs -> PartSpec t
     53 partition fs = (Nothing, mempty, mkPartition (Just fs), mempty)
     54 
     55 -- | Specifies a swap partition of a given size.
     56 swapPartition :: Monoid t => PartSize -> PartSpec t
     57 swapPartition sz = (Nothing, mempty, const (mkPartition (Just LinuxSwap) sz), mempty)
     58 
     59 -- | Specifies a partition without any filesystem, of a given size.
     60 rawPartition :: Monoid t => PartSize -> PartSpec t
     61 rawPartition sz = (Nothing, mempty, const (mkPartition Nothing sz), mempty)
     62 
     63 -- | Specifies where to mount a partition.
     64 mountedAt :: PartSpec t -> MountPoint -> PartSpec t
     65 mountedAt (_, o, p, t) mp = (Just mp, o, p, t)
     66 
     67 -- | Partitions in disk images default to being sized large enough to hold
     68 -- the files that live in that partition.
     69 --
     70 -- This adds additional free space to a partition.
     71 addFreeSpace :: PartSpec t -> PartSize -> PartSpec t
     72 addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)
     73   where
     74 	p' = \sz -> p (sz <> freesz)
     75 
     76 -- | Specify a fixed size for a partition.
     77 setSize :: PartSpec t -> PartSize -> PartSpec t
     78 setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)
     79 
     80 -- | Specifies a mount option, such as "noexec"
     81 mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
     82 mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)
     83 
     84 -- | Mount option to make a partition be remounted readonly when there's an
     85 -- error accessing it.
     86 errorReadonly :: MountOpts
     87 errorReadonly = toMountOpts "errors=remount-ro"
     88 
     89 -- | Sets the percent of the filesystem blocks reserved for the super-user.
     90 --
     91 -- The default is 5% for ext2 and ext4. Some filesystems may not support
     92 -- this.
     93 reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t
     94 reservedSpacePercentage s percent = adjustp s $ \p -> 
     95 	p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
     96 
     97 -- | Sets a flag on the partition.
     98 setFlag :: PartSpec t -> PartFlag -> PartSpec t
     99 setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
    100 
    101 -- | Makes a MSDOS partition be Extended, rather than Primary.
    102 extended :: PartSpec t -> PartSpec t
    103 extended s = adjustp s $ \p -> p { partType = Extended }
    104 
    105 adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
    106 adjustp (mp, o, p, t) f = (mp, o, f . p, t)
    107 
    108 data PartInfoVal
    109 	= TableTypeInfo TableType
    110 	| PartSpecInfo (PartSpec PartLocation)
    111 	| AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation)
    112 
    113 newtype PartInfo = PartInfo [PartInfoVal]
    114 	deriving (Monoid, Sem.Semigroup, Typeable)
    115 
    116 instance IsInfo PartInfo where
    117 	propagateInfo _ = PropagateInfo False
    118 
    119 instance Show PartInfo where
    120 	show = show . toPartTableSpec
    121 
    122 toPartTableSpec :: PartInfo -> PartTableSpec
    123 toPartTableSpec (PartInfo l) = PartTableSpec tt pil
    124   where
    125 	tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l
    126 
    127 	pil = map convert $ sortBy (comparing location) $ adjust collect
    128 	collect = mapMaybe getspartspec l
    129 	adjust ps = adjust' ps (mapMaybe getadjust l)
    130 	adjust' ps [] = ps
    131 	adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest
    132 	adjustone mp f p@(mp', _, _, _)
    133 		| Just mp == mp' = f p
    134 		| otherwise = p
    135 	location (_, _, _, loc) = loc
    136 	convert (mp, o, p, _) = (mp, o, p, ())
    137 	
    138 	gettt (TableTypeInfo t) = Just t
    139 	gettt _ = Nothing
    140 	getspartspec (PartSpecInfo ps) = Just ps
    141 	getspartspec _ = Nothing
    142 	getadjust (AdjustPartSpecInfo mp f) = Just (mp, f)
    143 	getadjust _ = Nothing
    144 
    145 -- | Indicates the partition table type of a host.
    146 --
    147 -- When not specified, the default is MSDOS.
    148 --
    149 -- For example:
    150 --
    151 -- >	& hasPartitionTableType GPT
    152 hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike)
    153 hasPartitionTableType tt = pureInfoProperty
    154 	("partition table type " ++ show tt)
    155 	(PartInfo [TableTypeInfo tt])
    156 
    157 -- | Indicates that a host has a partition.
    158 --
    159 -- For example:
    160 --
    161 -- >	& hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning)
    162 -- >	& hasPartiton (partition EXT4 `mountedAt` "/")
    163 -- >	& hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0)
    164 hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike)
    165 hasPartition p@(mmp, _, _, _) = pureInfoProperty desc
    166 	(PartInfo [PartSpecInfo p])
    167   where
    168 	desc = case mmp of
    169 		Just mp -> mp ++ " partition"
    170 		Nothing -> "unmounted partition"
    171 
    172 -- | Adjusts the PartSpec for the partition mounted at the specified location.
    173 --
    174 -- For example:
    175 --
    176 -- > 	& adjustPartition "/boot" (`addFreeSpace` MegaBytes 150)
    177 adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike)
    178 adjustPartition mp f = pureInfoProperty
    179 	(mp ++ " adjusted")
    180 	(PartInfo [AdjustPartSpecInfo mp f])
    181 
    182 -- | Indicates partition layout in a disk. Default is somewhere in the
    183 -- middle.
    184 data PartLocation = Beginning | Middle | End
    185 	deriving (Eq, Ord)
    186 
    187 instance Sem.Semigroup PartLocation where
    188 	_ <> b = b
    189 
    190 instance Monoid PartLocation where
    191 	mempty = Middle
    192 	mappend = (Sem.<>)
    193 
    194 partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation
    195 partLocation (mp, o, p, _) l = (mp, o, p, l)