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