    {-# LANGUAGE FlexibleContexts #-}

    module Propellor.Property.Partition where

    import Propellor.Base
    import Propellor.Types.Core
    import qualified Propellor.Property.Apt as Apt
    import Utility.Applicative

    import System.Posix.Files
    import Data.List
    import Data.Char

    -- | Filesystems etc that can be used for a partition.
    data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
            deriving (Show, Eq)

    -- | Parse commonly used names of filesystems.
    parseFs :: String -> Maybe Fs
    parseFs "ext2" = Just EXT2
    parseFs "ext3" = Just EXT3
    parseFs "ext4" = Just EXT4
    parseFs "btrfs" = Just BTRFS
    parseFs "reiserfs" = Just REISERFS
    parseFs "xfs" = Just XFS
    parseFs "fat" = Just FAT
    parseFs "vfat" = Just VFAT
    parseFs "ntfs" = Just NTFS
    parseFs "swap" = Just LinuxSwap
    parseFs _ = Nothing

    data Eep = YesReallyFormatPartition

    -- | Formats a partition.
    formatted :: Eep -> Fs -> FilePath -> Property DebianLike
    formatted = formatted' []

    -- | Options passed to a mkfs.* command when making a filesystem.
    --
    -- Eg, ["-m0"]
    type MkfsOpts = [String]

    formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike
    formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts'
            `assume` MadeChange
            `requires` Apt.installed [pkg]
      where
            (cmd, opts', pkg) = case fs of
                    EXT2 -> ("mkfs.ext2", q $ eff optsdev, "e2fsprogs")
                    EXT3 -> ("mkfs.ext3", q $ eff optsdev, "e2fsprogs")
                    EXT4 -> ("mkfs.ext4", q $ eff optsdev, "e2fsprogs")
                    BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools")
                    REISERFS -> ("mkfs.reiserfs", q $ "-ff":optsdev, "reiserfsprogs")
                    XFS -> ("mkfs.xfs", "-f":q optsdev, "xfsprogs")
                    FAT -> ("mkfs.fat", optsdev, "dosfstools")
                    VFAT -> ("mkfs.vfat", optsdev, "dosfstools")
                    NTFS -> ("mkfs.ntfs", q $ eff optsdev, "ntfs-3g")
                    LinuxSwap -> ("mkswap", optsdev, "util-linux")
            optsdev = opts++[dev]
            -- -F forces creating a filesystem even if the device already has one
            eff l = "-F":l
            -- Be quiet.
            q l = "-q":l

    data LoopDev = LoopDev
            { partitionLoopDev :: FilePath -- ^ device for a loop partition
            , wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
            } deriving (Show)

    isLoopDev :: LoopDev -> IO Bool
    isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l)

    isLoopDev' :: FilePath -> IO Bool
    isLoopDev' f
            | "loop" `isInfixOf` f = catchBoolIO $
                    isBlockDevice <$> getFileStatus f
            | otherwise = return False

    -- | Uses the kpartx utility to create device maps for partitions contained
    -- within a disk image file. The resulting loop devices are passed to the
    -- property, which can operate on them. Always cleans up after itself,
    -- by removing the device maps after the property is run.
    kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
    kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
      where
            go :: Property DebianLike
            go = property' (getDesc (mkprop [])) $ \w -> do
                    cleanup -- idempotency
                    loopdevs <- liftIO $ kpartxParse
                            <$> readProcess "kpartx" ["-avs", diskimage]
                    bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
                    unless (null bad) $
                            error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
                    r <- ensureProperty w (mkprop loopdevs)
                    cleanup
                    return r
            cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]

    -- kpartx's output includes the device for the loop partition, and some
    -- information about the whole disk loop device. In earlier versions,
    -- this was simply the path to the loop device. But, in kpartx 0.6,
    -- this changed to the major:minor of the block device. Either is handled
    -- by this parser.
    kpartxParse :: String -> [LoopDev]
    kpartxParse = mapMaybe (finddev . words) . lines
      where
            finddev ("add":"map":ld:_:_:_:_:s:_) = do
                    wd <- if isAbsolute s
                            then Just s
                            -- A loop partition name loop0pn corresponds to
                            -- /dev/loop0. It would be more robust to check
                            -- that the major:minor matches, but haskell's
                            -- unix library lacks a way to do that.
                            else case takeWhile isDigit (dropWhile (not . isDigit) ld) of
                                    [] -> Nothing
                                    n -> Just $ "/dev" </> "loop" ++ n
                    Just $ LoopDev
                            { partitionLoopDev = "/dev/mapper/" ++ ld
                            , wholeDiskLoopDev = wd
                            }
            finddev _ = Nothing