{-# 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
(Int -> Fs -> ShowS)
-> (Fs -> String) -> ([Fs] -> ShowS) -> Show Fs
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
(Fs -> Fs -> Bool) -> (Fs -> Fs -> Bool) -> Eq Fs
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" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
EXT2
parseFs String
"ext3" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
EXT3
parseFs String
"ext4" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
EXT4
parseFs String
"btrfs" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
BTRFS
parseFs String
"reiserfs" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
REISERFS
parseFs String
"xfs" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
XFS
parseFs String
"fat" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
FAT
parseFs String
"vfat" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
VFAT
parseFs String
"ntfs" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
NTFS
parseFs String
"swap" = Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
LinuxSwap
parseFs String
_ = Maybe Fs
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'
	UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
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 (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
forall a b. (a -> b) -> a -> b
$ MkfsOpts -> MkfsOpts
eff MkfsOpts
optsdev, String
"e2fsprogs")
		Fs
EXT3 -> (String
"mkfs.ext3", MkfsOpts -> MkfsOpts
q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
forall a b. (a -> b) -> a -> b
$ MkfsOpts -> MkfsOpts
eff MkfsOpts
optsdev, String
"e2fsprogs")
		Fs
EXT4 -> (String
"mkfs.ext4", MkfsOpts -> MkfsOpts
q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
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 (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
forall a b. (a -> b) -> a -> b
$ String
"-ff"String -> MkfsOpts -> MkfsOpts
forall a. a -> [a] -> [a]
:MkfsOpts
optsdev, String
"reiserfsprogs")
		Fs
XFS -> (String
"mkfs.xfs", String
"-f"String -> MkfsOpts -> MkfsOpts
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 (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
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
optsMkfsOpts -> MkfsOpts -> MkfsOpts
forall 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"String -> MkfsOpts -> MkfsOpts
forall a. a -> [a] -> [a]
:MkfsOpts
l
	-- Be quiet.
	q :: MkfsOpts -> MkfsOpts
q MkfsOpts
l = String
"-q"String -> MkfsOpts -> MkfsOpts
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
(Int -> LoopDev -> ShowS)
-> (LoopDev -> String) -> ([LoopDev] -> ShowS) -> Show LoopDev
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) IO Bool -> IO Bool -> IO Bool
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" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
f = IO Bool -> IO Bool
forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
catchBoolIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
		FileStatus -> Bool
isBlockDevice (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
f
	| Bool
otherwise = Bool -> IO Bool
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 Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
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 = String
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall k (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (Property DebianLike -> String
forall p. IsProp p => p -> String
getDesc ([LoopDev] -> Property DebianLike
mkprop [])) ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
  -> Propellor Result)
 -> Property DebianLike)
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		Propellor ()
cleanup -- idempotency
		[LoopDev]
loopdevs <- IO [LoopDev] -> Propellor [LoopDev]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LoopDev] -> Propellor [LoopDev])
-> IO [LoopDev] -> Propellor [LoopDev]
forall a b. (a -> b) -> a -> b
$ String -> [LoopDev]
kpartxParse
			(String -> [LoopDev]) -> IO String -> IO [LoopDev]
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 <- IO [LoopDev] -> Propellor [LoopDev]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LoopDev] -> Propellor [LoopDev])
-> IO [LoopDev] -> Propellor [LoopDev]
forall a b. (a -> b) -> a -> b
$ (LoopDev -> IO Bool) -> [LoopDev] -> IO [LoopDev]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Bool -> Bool
not (Bool -> Bool) -> (LoopDev -> IO Bool) -> LoopDev -> IO Bool
forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<$$> LoopDev -> IO Bool
isLoopDev) [LoopDev]
loopdevs
		Bool -> Propellor () -> Propellor ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LoopDev] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LoopDev]
bad) (Propellor () -> Propellor ()) -> Propellor () -> Propellor ()
forall a b. (a -> b) -> a -> b
$
			String -> Propellor ()
forall a. HasCallStack => String -> a
error (String -> Propellor ()) -> String -> Propellor ()
forall a b. (a -> b) -> a -> b
$ String
"kpartx output seems to include non-loop-devices (possible parse failure): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [LoopDev] -> String
forall a. Show a => a -> String
show [LoopDev]
bad
		Result
r <- OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Property DebianLike -> Propellor Result
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
		Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	cleanup :: Propellor ()
cleanup = Propellor Bool -> Propellor ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Propellor Bool -> Propellor ()) -> Propellor Bool -> Propellor ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
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 = (String -> Maybe LoopDev) -> MkfsOpts -> [LoopDev]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (MkfsOpts -> Maybe LoopDev
finddev (MkfsOpts -> Maybe LoopDev)
-> (String -> MkfsOpts) -> String -> Maybe LoopDev
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MkfsOpts
words) (MkfsOpts -> [LoopDev])
-> (String -> MkfsOpts) -> String -> [LoopDev]
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 String -> Maybe String
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 (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) String
ld) of
				[] -> Maybe String
forall a. Maybe a
Nothing
				String
n -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"/dev" String -> ShowS
</> String
"loop" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
		LoopDev -> Maybe LoopDev
forall a. a -> Maybe a
Just (LoopDev -> Maybe LoopDev) -> LoopDev -> Maybe LoopDev
forall a b. (a -> b) -> a -> b
$ LoopDev :: String -> String -> LoopDev
LoopDev
			{ partitionLoopDev :: String
partitionLoopDev = String
"/dev/mapper/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ld
			, wholeDiskLoopDev :: String
wholeDiskLoopDev = String
wd
			}
	finddev MkfsOpts
_ = Maybe LoopDev
forall a. Maybe a
Nothing