{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -- | Disk image partition specification. module Propellor.Property.DiskImage.PartSpec ( PartSpec, Fs(..), PartSize(..), partition, -- * PartSpec combinators swapPartition, rawPartition, mountedAt, addFreeSpace, setSize, mountOpt, errorReadonly, reservedSpacePercentage, setFlag, extended, -- * Partition properties -- -- | These properties do not do any disk partitioning on their own, but -- the Info they set can be used when building a disk image for a -- host. hasPartition, adjustPartition, PartLocation(..), partLocation, hasPartitionTableType, TableType(..), PartInfo, toPartTableSpec, PartTableSpec(..) ) where import Propellor.Base import Propellor.Property.Parted import Propellor.Types.PartSpec import Propellor.Types.Info import Propellor.Property.Mount import Data.List (sortBy) import Data.Ord import qualified Data.Semigroup as Sem -- | Specifies a partition with a given filesystem. -- -- The partition is not mounted anywhere by default; use the combinators -- below to configure it. partition :: Monoid t => Fs -> PartSpec t partition fs = (Nothing, mempty, mkPartition (Just fs), mempty) -- | Specifies a swap partition of a given size. swapPartition :: Monoid t => PartSize -> PartSpec t swapPartition sz = (Nothing, mempty, const (mkPartition (Just LinuxSwap) sz), mempty) -- | Specifies a partition without any filesystem, of a given size. rawPartition :: Monoid t => PartSize -> PartSpec t rawPartition sz = (Nothing, mempty, const (mkPartition Nothing sz), mempty) -- | Specifies where to mount a partition. mountedAt :: PartSpec t -> MountPoint -> PartSpec t mountedAt (_, o, p, t) mp = (Just mp, o, p, t) -- | Partitions in disk images default to being sized large enough to hold -- the files that live in that partition. -- -- This adds additional free space to a partition. addFreeSpace :: PartSpec t -> PartSize -> PartSpec t addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t) where p' = \sz -> p (sz <> freesz) -- | Specify a fixed size for a partition. setSize :: PartSpec t -> PartSize -> PartSpec t setSize (mp, o, p, t) sz = (mp, o, const (p sz), t) -- | Specifies a mount option, such as "noexec" mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t) -- | Mount option to make a partition be remounted readonly when there's an -- error accessing it. errorReadonly :: MountOpts errorReadonly = toMountOpts "errors=remount-ro" -- | Sets the percent of the filesystem blocks reserved for the super-user. -- -- The default is 5% for ext2 and ext4. Some filesystems may not support -- this. reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t reservedSpacePercentage s percent = adjustp s $ \p -> p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p } -- | Sets a flag on the partition. setFlag :: PartSpec t -> PartFlag -> PartSpec t setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } -- | Makes a MSDOS partition be Extended, rather than Primary. extended :: PartSpec t -> PartSpec t extended s = adjustp s $ \p -> p { partType = Extended } adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t adjustp (mp, o, p, t) f = (mp, o, f . p, t) data PartInfoVal = TableTypeInfo TableType | PartSpecInfo (PartSpec PartLocation) | AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation) newtype PartInfo = PartInfo [PartInfoVal] deriving (Monoid, Sem.Semigroup, Typeable) instance IsInfo PartInfo where propagateInfo _ = PropagateInfo False instance Show PartInfo where show = show . toPartTableSpec toPartTableSpec :: PartInfo -> PartTableSpec toPartTableSpec (PartInfo l) = PartTableSpec tt pil where tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l pil = map convert $ sortBy (comparing location) $ adjust collect collect = mapMaybe getspartspec l adjust ps = adjust' ps (mapMaybe getadjust l) adjust' ps [] = ps adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest adjustone mp f p@(mp', _, _, _) | Just mp == mp' = f p | otherwise = p location (_, _, _, loc) = loc convert (mp, o, p, _) = (mp, o, p, ()) gettt (TableTypeInfo t) = Just t gettt _ = Nothing getspartspec (PartSpecInfo ps) = Just ps getspartspec _ = Nothing getadjust (AdjustPartSpecInfo mp f) = Just (mp, f) getadjust _ = Nothing -- | Indicates the partition table type of a host. -- -- When not specified, the default is MSDOS. -- -- For example: -- -- > & hasPartitionTableType GPT hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike) hasPartitionTableType tt = pureInfoProperty ("partition table type " ++ show tt) (PartInfo [TableTypeInfo tt]) -- | Indicates that a host has a partition. -- -- For example: -- -- > & hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning) -- > & hasPartiton (partition EXT4 `mountedAt` "/") -- > & hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0) hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike) hasPartition p@(mmp, _, _, _) = pureInfoProperty desc (PartInfo [PartSpecInfo p]) where desc = case mmp of Just mp -> mp ++ " partition" Nothing -> "unmounted partition" -- | Adjusts the PartSpec for the partition mounted at the specified location. -- -- For example: -- -- > & adjustPartition "/boot" (`addFreeSpace` MegaBytes 150) adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike) adjustPartition mp f = pureInfoProperty (mp ++ " adjusted") (PartInfo [AdjustPartSpecInfo mp f]) -- | Indicates partition layout in a disk. Default is somewhere in the -- middle. data PartLocation = Beginning | Middle | End deriving (Eq, Ord) instance Sem.Semigroup PartLocation where _ <> b = b instance Monoid PartLocation where mempty = Middle mappend = (Sem.<>) partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation partLocation (mp, o, p, _) l = (mp, o, p, l)