{-# 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 :: forall t. Monoid t => Fs -> PartSpec t
partition Fs
fs = (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty, Maybe Fs -> PartSize -> Partition
mkPartition (forall a. a -> Maybe a
Just Fs
fs), forall a. Monoid a => a
mempty)

-- | Specifies a swap partition of a given size.
swapPartition :: Monoid t => PartSize -> PartSpec t
swapPartition :: forall t. Monoid t => PartSize -> PartSpec t
swapPartition PartSize
sz = (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty, forall a b. a -> b -> a
const (Maybe Fs -> PartSize -> Partition
mkPartition (forall a. a -> Maybe a
Just Fs
LinuxSwap) PartSize
sz), forall a. Monoid a => a
mempty)

-- | Specifies a partition without any filesystem, of a given size.
rawPartition :: Monoid t => PartSize -> PartSpec t
rawPartition :: forall t. Monoid t => PartSize -> PartSpec t
rawPartition PartSize
sz = (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty, forall a b. a -> b -> a
const (Maybe Fs -> PartSize -> Partition
mkPartition forall a. Maybe a
Nothing PartSize
sz), forall a. Monoid a => a
mempty)

-- | Specifies where to mount a partition.
mountedAt :: PartSpec t -> MountPoint -> PartSpec t
mountedAt :: forall t. PartSpec t -> String -> PartSpec t
mountedAt (Maybe String
_, MountOpts
o, PartSize -> Partition
p, t
t) String
mp = (forall a. a -> Maybe a
Just String
mp, MountOpts
o, PartSize -> Partition
p, t
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 :: forall t. PartSpec t -> PartSize -> PartSpec t
addFreeSpace (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, t
t) PartSize
freesz = (Maybe String
mp, MountOpts
o, PartSize -> Partition
p', t
t)
  where
	p' :: PartSize -> Partition
p' = \PartSize
sz -> PartSize -> Partition
p (PartSize
sz forall a. Semigroup a => a -> a -> a
<> PartSize
freesz)

-- | Specify a fixed size for a partition.
setSize :: PartSpec t -> PartSize -> PartSpec t
setSize :: forall t. PartSpec t -> PartSize -> PartSpec t
setSize (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, t
t) PartSize
sz = (Maybe String
mp, MountOpts
o, forall a b. a -> b -> a
const (PartSize -> Partition
p PartSize
sz), t
t)

-- | Specifies a mount option, such as "noexec"
mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
mountOpt :: forall o t. ToMountOpts o => PartSpec t -> o -> PartSpec t
mountOpt (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, t
t) o
o' = (Maybe String
mp, MountOpts
o forall a. Semigroup a => a -> a -> a
<> forall a. ToMountOpts a => a -> MountOpts
toMountOpts o
o', PartSize -> Partition
p, t
t)

-- | Mount option to make a partition be remounted readonly when there's an
-- error accessing it.
errorReadonly :: MountOpts
errorReadonly :: MountOpts
errorReadonly = forall a. ToMountOpts a => a -> MountOpts
toMountOpts String
"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 :: forall t. PartSpec t -> Int -> PartSpec t
reservedSpacePercentage PartSpec t
s Int
percent = forall t. PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp PartSpec t
s forall a b. (a -> b) -> a -> b
$ \Partition
p -> 
	Partition
p { partMkFsOpts :: MkfsOpts
partMkFsOpts = (String
"-m")forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Int
percentforall a. a -> [a] -> [a]
:Partition -> MkfsOpts
partMkFsOpts Partition
p }

-- | Sets a flag on the partition.
setFlag :: PartSpec t -> PartFlag -> PartSpec t
setFlag :: forall t. PartSpec t -> PartFlag -> PartSpec t
setFlag PartSpec t
s PartFlag
f = forall t. PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp PartSpec t
s forall a b. (a -> b) -> a -> b
$ \Partition
p -> Partition
p { partFlags :: [(PartFlag, Bool)]
partFlags = (PartFlag
f, Bool
True)forall a. a -> [a] -> [a]
:Partition -> [(PartFlag, Bool)]
partFlags Partition
p }

-- | Makes a MSDOS partition be Extended, rather than Primary.
extended :: PartSpec t -> PartSpec t
extended :: forall t. PartSpec t -> PartSpec t
extended PartSpec t
s = forall t. PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp PartSpec t
s forall a b. (a -> b) -> a -> b
$ \Partition
p -> Partition
p { partType :: PartType
partType = PartType
Extended }

adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp :: forall t. PartSpec t -> (Partition -> Partition) -> PartSpec t
adjustp (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, t
t) Partition -> Partition
f = (Maybe String
mp, MountOpts
o, Partition -> Partition
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartSize -> Partition
p, t
t)

data PartInfoVal
	= TableTypeInfo TableType
	| PartSpecInfo (PartSpec PartLocation)
	| AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation)

newtype PartInfo = PartInfo [PartInfoVal]
	deriving (Semigroup PartInfo
PartInfo
[PartInfo] -> PartInfo
PartInfo -> PartInfo -> PartInfo
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [PartInfo] -> PartInfo
$cmconcat :: [PartInfo] -> PartInfo
mappend :: PartInfo -> PartInfo -> PartInfo
$cmappend :: PartInfo -> PartInfo -> PartInfo
mempty :: PartInfo
$cmempty :: PartInfo
Monoid, NonEmpty PartInfo -> PartInfo
PartInfo -> PartInfo -> PartInfo
forall b. Integral b => b -> PartInfo -> PartInfo
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> PartInfo -> PartInfo
$cstimes :: forall b. Integral b => b -> PartInfo -> PartInfo
sconcat :: NonEmpty PartInfo -> PartInfo
$csconcat :: NonEmpty PartInfo -> PartInfo
<> :: PartInfo -> PartInfo -> PartInfo
$c<> :: PartInfo -> PartInfo -> PartInfo
Sem.Semigroup, Typeable)

instance IsInfo PartInfo where
	propagateInfo :: PartInfo -> PropagateInfo
propagateInfo PartInfo
_ = Bool -> PropagateInfo
PropagateInfo Bool
False

instance Show PartInfo where
	show :: PartInfo -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartInfo -> PartTableSpec
toPartTableSpec

toPartTableSpec :: PartInfo -> PartTableSpec
toPartTableSpec :: PartInfo -> PartTableSpec
toPartTableSpec (PartInfo [PartInfoVal]
l) = TableType -> [PartSpec ()] -> PartTableSpec
PartTableSpec TableType
tt [PartSpec ()]
pil
  where
	tt :: TableType
tt = forall a. a -> Maybe a -> a
fromMaybe TableType
MSDOS forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMaybe forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PartInfoVal -> Maybe TableType
gettt [PartInfoVal]
l

	pil :: [PartSpec ()]
pil = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c} {d}. (a, b, c, d) -> (a, b, c, ())
convert forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall {a} {b} {c} {d}. (a, b, c, d) -> d
location) forall a b. (a -> b) -> a -> b
$ [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
-> [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
adjust [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
collect
	collect :: [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
collect = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PartInfoVal
-> Maybe
     (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
getspartspec [PartInfoVal]
l
	adjust :: [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
-> [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
adjust [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
ps = forall {a} {b} {c} {d}.
Eq a =>
[(Maybe a, b, c, d)]
-> [(a, (Maybe a, b, c, d) -> (Maybe a, b, c, d))]
-> [(Maybe a, b, c, d)]
adjust' [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)]
ps (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PartInfoVal
-> Maybe
     (String,
      (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
      -> (Maybe String, MountOpts, PartSize -> Partition, PartLocation))
getadjust [PartInfoVal]
l)
	adjust' :: [(Maybe a, b, c, d)]
-> [(a, (Maybe a, b, c, d) -> (Maybe a, b, c, d))]
-> [(Maybe a, b, c, d)]
adjust' [(Maybe a, b, c, d)]
ps [] = [(Maybe a, b, c, d)]
ps
	adjust' [(Maybe a, b, c, d)]
ps ((a
mp, (Maybe a, b, c, d) -> (Maybe a, b, c, d)
f):[(a, (Maybe a, b, c, d) -> (Maybe a, b, c, d))]
rest) = [(Maybe a, b, c, d)]
-> [(a, (Maybe a, b, c, d) -> (Maybe a, b, c, d))]
-> [(Maybe a, b, c, d)]
adjust' (forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b} {c} {d}.
Eq a =>
a
-> ((Maybe a, b, c, d) -> (Maybe a, b, c, d))
-> (Maybe a, b, c, d)
-> (Maybe a, b, c, d)
adjustone a
mp (Maybe a, b, c, d) -> (Maybe a, b, c, d)
f) [(Maybe a, b, c, d)]
ps) [(a, (Maybe a, b, c, d) -> (Maybe a, b, c, d))]
rest
	adjustone :: a
-> ((Maybe a, b, c, d) -> (Maybe a, b, c, d))
-> (Maybe a, b, c, d)
-> (Maybe a, b, c, d)
adjustone a
mp (Maybe a, b, c, d) -> (Maybe a, b, c, d)
f p :: (Maybe a, b, c, d)
p@(Maybe a
mp', b
_, c
_, d
_)
		| forall a. a -> Maybe a
Just a
mp forall a. Eq a => a -> a -> Bool
== Maybe a
mp' = (Maybe a, b, c, d) -> (Maybe a, b, c, d)
f (Maybe a, b, c, d)
p
		| Bool
otherwise = (Maybe a, b, c, d)
p
	location :: (a, b, c, d) -> d
location (a
_, b
_, c
_, d
loc) = d
loc
	convert :: (a, b, c, d) -> (a, b, c, ())
convert (a
mp, b
o, c
p, d
_) = (a
mp, b
o, c
p, ())
	
	gettt :: PartInfoVal -> Maybe TableType
gettt (TableTypeInfo TableType
t) = forall a. a -> Maybe a
Just TableType
t
	gettt PartInfoVal
_ = forall a. Maybe a
Nothing
	getspartspec :: PartInfoVal
-> Maybe
     (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
getspartspec (PartSpecInfo (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
ps) = forall a. a -> Maybe a
Just (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
ps
	getspartspec PartInfoVal
_ = forall a. Maybe a
Nothing
	getadjust :: PartInfoVal
-> Maybe
     (String,
      (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
      -> (Maybe String, MountOpts, PartSize -> Partition, PartLocation))
getadjust (AdjustPartSpecInfo String
mp (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
f) = forall a. a -> Maybe a
Just (String
mp, (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
f)
	getadjust PartInfoVal
_ = forall a. Maybe a
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 :: TableType -> Property (HasInfo + UnixLike)
hasPartitionTableType TableType
tt = forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
pureInfoProperty
	(String
"partition table type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TableType
tt)
	([PartInfoVal] -> PartInfo
PartInfo [TableType -> PartInfoVal
TableTypeInfo TableType
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 :: (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> Property (HasInfo + UnixLike)
hasPartition p :: (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
p@(Maybe String
mmp, MountOpts
_, PartSize -> Partition
_, PartLocation
_) = forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
pureInfoProperty String
desc
	([PartInfoVal] -> PartInfo
PartInfo [(Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> PartInfoVal
PartSpecInfo (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
p])
  where
	desc :: String
desc = case Maybe String
mmp of
		Just String
mp -> String
mp forall a. [a] -> [a] -> [a]
++ String
" partition"
		Maybe String
Nothing -> String
"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 :: String
-> ((Maybe String, MountOpts, PartSize -> Partition, PartLocation)
    -> (Maybe String, MountOpts, PartSize -> Partition, PartLocation))
-> Property (HasInfo + UnixLike)
adjustPartition String
mp (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
f = forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
pureInfoProperty
	(String
mp forall a. [a] -> [a] -> [a]
++ String
" adjusted")
	([PartInfoVal] -> PartInfo
PartInfo [String
-> ((Maybe String, MountOpts, PartSize -> Partition, PartLocation)
    -> (Maybe String, MountOpts, PartSize -> Partition, PartLocation))
-> PartInfoVal
AdjustPartSpecInfo String
mp (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
f])

-- | Indicates partition layout in a disk. Default is somewhere in the
-- middle.
data PartLocation = Beginning | Middle | End
	deriving (PartLocation -> PartLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartLocation -> PartLocation -> Bool
$c/= :: PartLocation -> PartLocation -> Bool
== :: PartLocation -> PartLocation -> Bool
$c== :: PartLocation -> PartLocation -> Bool
Eq, Eq PartLocation
PartLocation -> PartLocation -> Bool
PartLocation -> PartLocation -> Ordering
PartLocation -> PartLocation -> PartLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PartLocation -> PartLocation -> PartLocation
$cmin :: PartLocation -> PartLocation -> PartLocation
max :: PartLocation -> PartLocation -> PartLocation
$cmax :: PartLocation -> PartLocation -> PartLocation
>= :: PartLocation -> PartLocation -> Bool
$c>= :: PartLocation -> PartLocation -> Bool
> :: PartLocation -> PartLocation -> Bool
$c> :: PartLocation -> PartLocation -> Bool
<= :: PartLocation -> PartLocation -> Bool
$c<= :: PartLocation -> PartLocation -> Bool
< :: PartLocation -> PartLocation -> Bool
$c< :: PartLocation -> PartLocation -> Bool
compare :: PartLocation -> PartLocation -> Ordering
$ccompare :: PartLocation -> PartLocation -> Ordering
Ord)

instance Sem.Semigroup PartLocation where
	PartLocation
_ <> :: PartLocation -> PartLocation -> PartLocation
<> PartLocation
b = PartLocation
b

instance Monoid PartLocation where
	mempty :: PartLocation
mempty = PartLocation
Middle
	mappend :: PartLocation -> PartLocation -> PartLocation
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)

partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation
partLocation :: (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
-> PartLocation
-> (Maybe String, MountOpts, PartSize -> Partition, PartLocation)
partLocation (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, PartLocation
_) PartLocation
l = (Maybe String
mp, MountOpts
o, PartSize -> Partition
p, PartLocation
l)