    {-# 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