{-# 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
data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
deriving (Show, Eq)
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
formatted :: Eep -> Fs -> FilePath -> Property DebianLike
formatted = formatted' []
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]
eff l = "-F":l
q l = "-q":l
data LoopDev = LoopDev
{ partitionLoopDev :: FilePath
, wholeDiskLoopDev :: FilePath
} 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
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
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]
kpartxParse :: String -> [LoopDev]
kpartxParse = mapMaybe (finddev . words) . lines
where
finddev ("add":"map":ld:_:_:_:_:s:_) = do
wd <- if isAbsolute s
then Just s
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