{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Parted (
TableType(..),
PartTable(..),
partTableSize,
Partition(..),
mkPartition,
Partition.Fs(..),
PartSize(..),
ByteSize,
toPartSize,
fromPartSize,
reducePartSize,
Alignment(..),
safeAlignment,
Partition.MkfsOpts,
PartType(..),
PartFlag(..),
partitioned,
parted,
Eep(..),
installed,
calcPartTable,
DiskSize(..),
DiskPart,
DiskSpaceUse(..),
useDiskSpace,
defSz,
fudgeSz,
) where
import Propellor.Base
import Propellor.Property.Parted.Types
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Property.Partition as Partition
import Propellor.Types.PartSpec (PartSpec)
import Utility.DataUnits
import System.Posix.Files
import qualified Data.Semigroup as Sem
import Data.List (genericLength)
data Eep = YesReallyDeleteDiskContents
partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike
partitioned eep disk parttable@(PartTable _ _ parts) = property' desc $ \w -> do
isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
ensureProperty w $ combineProperties desc $ props
& parted eep disk (fst (calcPartedParamsSize parttable))
& if isdev
then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
where
desc = disk ++ " partitioned"
formatl devs = combineProperties desc (toProps $ map format (zip parts devs))
format (p, dev) = case partFs p of
Just fs -> Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition fs dev
Nothing -> doNothing
partTableSize :: PartTable -> ByteSize
partTableSize = snd . calcPartedParamsSize
calcPartedParamsSize :: PartTable -> ([String], ByteSize)
calcPartedParamsSize (PartTable tabletype alignment parts) =
let (ps, sz) = calcparts (1 :: Integer) firstpos parts []
in (concat (mklabel : ps), sz)
where
mklabel = ["mklabel", pval tabletype]
mkflag partnum (f, b) =
[ "set"
, show partnum
, pval f
, pval b
]
mkpart partnum startpos endpos p = catMaybes
[ Just "mkpart"
, Just $ pval (partType p)
, fmap pval (partFs p)
, Just $ partposexact startpos
, Just $ partposfuzzy endpos
] ++ case partName p of
Just n -> ["name", show partnum, n]
Nothing -> []
calcparts partnum startpos (p:ps) c =
let endpos = startpos + align (partSize p)
in calcparts (partnum+1) endpos ps
(c ++ mkpart partnum startpos (endpos-1) p : map (mkflag partnum) (partFlags p))
calcparts _ endpos [] c = (c, endpos)
partposexact n
| n > 0 = show n ++ "B"
| otherwise = "1MB"
partposfuzzy n
| n > 0 = show (fromIntegral n / 1000000 :: Double) ++ "MB"
| otherwise = "1MB"
firstpos = align partitionTableOverhead
align = alignTo alignment
parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux)
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"none":disk:ps)
`assume` MadeChange
installed :: Property (DebianLike + ArchLinux)
installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"]
partitionTableOverhead :: PartSize
partitionTableOverhead = MegaBytes 1
calcPartTable :: DiskSize -> TableType -> Alignment -> [PartSpec DiskPart] -> PartTable
calcPartTable (DiskSize disksize) tt alignment l =
PartTable tt alignment (map go l)
where
go (_, _, mkpart, FixedDiskPart) = mkpart defSz
go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ Bytes $
diskremainingafterfixed * fromIntegral p `div` 100
go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ Bytes $
diskremaining `div` genericLength (filter isremainingspace l)
diskremainingafterfixed =
disksize - sumsizes (filter isfixed l)
diskremaining =
disksize - sumsizes (filter (not . isremainingspace) l)
sumsizes = partTableSize . PartTable tt alignment . map go
isfixed (_, _, _, FixedDiskPart) = True
isfixed _ = False
isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True
isremainingspace _ = False
newtype DiskSize = DiskSize ByteSize
deriving (Show)
data DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse
data DiskSpaceUse = Percent Int | RemainingSpace
instance Sem.Semigroup DiskPart where
FixedDiskPart <> FixedDiskPart = FixedDiskPart
DynamicDiskPart (Percent a) <> DynamicDiskPart (Percent b) =
DynamicDiskPart (Percent (a + b))
DynamicDiskPart RemainingSpace <> DynamicDiskPart RemainingSpace =
DynamicDiskPart RemainingSpace
DynamicDiskPart (Percent a) <> _ = DynamicDiskPart (Percent a)
_ <> DynamicDiskPart (Percent b) = DynamicDiskPart (Percent b)
DynamicDiskPart RemainingSpace <> _ = DynamicDiskPart RemainingSpace
_ <> DynamicDiskPart RemainingSpace = DynamicDiskPart RemainingSpace
instance Monoid DiskPart
where
mempty = FixedDiskPart
mappend = (Sem.<>)
useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart
useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse)
defSz :: PartSize
defSz = MegaBytes 128
fudgeSz :: PartSize -> PartSize
fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
fudgeSz (Bytes n) = fudgeSz (toPartSize n)
alignTo :: Alignment -> PartSize -> ByteSize
alignTo _ (Bytes n) = n
alignTo (Alignment alignment) partsize
| alignment < 1 = n
| otherwise = case rem n alignment of
0 -> n
r -> n - r + alignment
where
n = fromPartSize partsize