{-# 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 (Int -> Fs -> ShowS
[Fs] -> ShowS
Fs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fs] -> ShowS
$cshowList :: [Fs] -> ShowS
show :: Fs -> String
$cshow :: Fs -> String
showsPrec :: Int -> Fs -> ShowS
$cshowsPrec :: Int -> Fs -> ShowS
Show, Fs -> Fs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fs -> Fs -> Bool
$c/= :: Fs -> Fs -> Bool
== :: Fs -> Fs -> Bool
$c== :: Fs -> Fs -> Bool
Eq)

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

data Eep = YesReallyFormatPartition

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

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

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

data LoopDev = LoopDev
	{ LoopDev -> String
partitionLoopDev :: FilePath -- ^ device for a loop partition
	, LoopDev -> String
wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
	} deriving (Int -> LoopDev -> ShowS
[LoopDev] -> ShowS
LoopDev -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoopDev] -> ShowS
$cshowList :: [LoopDev] -> ShowS
show :: LoopDev -> String
$cshow :: LoopDev -> String
showsPrec :: Int -> LoopDev -> ShowS
$cshowsPrec :: Int -> LoopDev -> ShowS
Show)

isLoopDev :: LoopDev -> IO Bool
isLoopDev :: LoopDev -> IO Bool
isLoopDev LoopDev
l = String -> IO Bool
isLoopDev' (LoopDev -> String
partitionLoopDev LoopDev
l) forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> String -> IO Bool
isLoopDev' (LoopDev -> String
wholeDiskLoopDev LoopDev
l)

isLoopDev' :: FilePath -> IO Bool
isLoopDev' :: String -> IO Bool
isLoopDev' String
f
	| String
"loop" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
f = forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO forall a b. (a -> b) -> a -> b
$
		FileStatus -> Bool
isBlockDevice forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
f
	| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: String -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx String
diskimage [LoopDev] -> Property DebianLike
mkprop = Property DebianLike
go forall x y. Combines x y => x -> y -> CombinedType x y
`requires` MkfsOpts -> Property DebianLike
Apt.installed [String
"kpartx"]
  where
	go :: Property DebianLike
	go :: Property DebianLike
go = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (forall p. IsProp p => p -> String
getDesc ([LoopDev] -> Property DebianLike
mkprop [])) forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		Propellor ()
cleanup -- idempotency
		[LoopDev]
loopdevs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> [LoopDev]
kpartxParse
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MkfsOpts -> IO String
readProcess String
"kpartx" [String
"-avs", String
diskimage]
		[LoopDev]
bad <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Bool -> Bool
not forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<$$> LoopDev -> IO Bool
isLoopDev) [LoopDev]
loopdevs
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LoopDev]
bad) forall a b. (a -> b) -> a -> b
$
			forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"kpartx output seems to include non-loop-devices (possible parse failure): " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [LoopDev]
bad
		Result
r <- forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w ([LoopDev] -> Property DebianLike
mkprop [LoopDev]
loopdevs)
		Propellor ()
cleanup
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	cleanup :: Propellor ()
cleanup = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> [CommandParam] -> IO Bool
boolSystem String
"kpartx" [String -> CommandParam
Param String
"-d", String -> CommandParam
File String
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 :: String -> [LoopDev]
kpartxParse = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (MkfsOpts -> Maybe LoopDev
finddev forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MkfsOpts
words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MkfsOpts
lines
  where
	finddev :: MkfsOpts -> Maybe LoopDev
finddev (String
"add":String
"map":String
ld:String
_:String
_:String
_:String
_:String
s:MkfsOpts
_) = do
		String
wd <- if String -> Bool
isAbsolute String
s
			then forall a. a -> Maybe a
Just String
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 forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) String
ld) of
				[] -> forall a. Maybe a
Nothing
				String
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"/dev" String -> ShowS
</> String
"loop" forall a. [a] -> [a] -> [a]
++ String
n
		forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LoopDev
			{ partitionLoopDev :: String
partitionLoopDev = String
"/dev/mapper/" forall a. [a] -> [a] -> [a]
++ String
ld
			, wholeDiskLoopDev :: String
wholeDiskLoopDev = String
wd
			}
	finddev MkfsOpts
_ = forall a. Maybe a
Nothing