summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/DiskImage/PartSpec.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/DiskImage/PartSpec.hs')
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs129
1 files changed, 122 insertions, 7 deletions
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 405c61b0..6a03c857 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -1,19 +1,48 @@
--- | Disk image partition specification and combinators.
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+-- | Disk image partition specification.
module Propellor.Property.DiskImage.PartSpec (
- module Propellor.Types.PartSpec,
- module Propellor.Property.DiskImage.PartSpec,
- module Propellor.Property.Parted.Types,
- module Propellor.Property.Partition,
+ PartSpec,
+ Fs(..),
+ PartSize(..),
+ partition,
+ -- * PartSpec combinators
+ swapPartition,
+ 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.Property.Parted.Types
+import Propellor.Types.Info
import Propellor.Property.Partition (Fs(..))
import Propellor.Property.Mount
+import Data.List (sortBy)
+import Data.Ord
+
-- | Specifies a partition with a given filesystem.
--
-- The partition is not mounted anywhere by default; use the combinators
@@ -26,7 +55,7 @@ swapPartition :: Monoid t => PartSize -> PartSpec t
swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)
-- | Specifies where to mount a partition.
-mountedAt :: PartSpec t -> FilePath -> PartSpec t
+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
@@ -69,3 +98,89 @@ 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, 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 -> "has " ++ mp ++ " partition"
+ Nothing -> "has 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
+ ("has " ++ 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 Monoid PartLocation where
+ mempty = Middle
+ mappend _ b = b
+
+partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation
+partLocation (mp, o, p, _) l = (mp, o, p, l)