{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Propellor.Property.DiskImage.PartSpec (
PartSpec,
Fs(..),
PartSize(..),
partition,
swapPartition,
rawPartition,
mountedAt,
addFreeSpace,
setSize,
mountOpt,
errorReadonly,
reservedSpacePercentage,
setFlag,
extended,
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.Partition (Fs(..))
import Propellor.Property.Mount
import Data.List (sortBy)
import Data.Ord
import qualified Data.Semigroup as Sem
partition :: Monoid t => Fs -> PartSpec t
partition fs = (Nothing, mempty, mkPartition (Just fs), mempty)
swapPartition :: Monoid t => PartSize -> PartSpec t
swapPartition sz = (Nothing, mempty, const (mkPartition (Just LinuxSwap) sz), mempty)
rawPartition :: Monoid t => PartSize -> PartSpec t
rawPartition sz = (Nothing, mempty, const (mkPartition Nothing sz), mempty)
mountedAt :: PartSpec t -> MountPoint -> PartSpec t
mountedAt (_, o, p, t) mp = (Just mp, o, p, t)
addFreeSpace :: PartSpec t -> PartSize -> PartSpec t
addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)
where
p' = \sz -> p (sz <> freesz)
setSize :: PartSpec t -> PartSize -> PartSpec t
setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)
mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)
errorReadonly :: MountOpts
errorReadonly = toMountOpts "errors=remount-ro"
reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t
reservedSpacePercentage s percent = adjustp s $ \p ->
p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
setFlag :: PartSpec t -> PartFlag -> PartSpec t
setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
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
hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike)
hasPartitionTableType tt = pureInfoProperty
("partition table type " ++ show tt)
(PartInfo [TableTypeInfo tt])
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"
adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike)
adjustPartition mp f = pureInfoProperty
(mp ++ " adjusted")
(PartInfo [AdjustPartSpecInfo mp f])
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)