{-# 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.Partition (Fs(..))
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)