module Propellor.Property.Fstab (
	FsType,
	Source,
	MountPoint,
	MountOpts(..),
	module Propellor.Property.Fstab,
) where

import Propellor.Base
import qualified Propellor.Property.File as File
import Propellor.Property.Mount

import Data.Char
import Data.List
import Utility.Table

-- | Ensures that </etc/fstab> contains a line mounting the specified
-- `Source` on the specified `MountPoint`, and that it's currently mounted.
--
-- For example:
--
-- > mounted "auto" "/dev/sdb1" "/srv" mempty
--
-- Note that if anything else is already mounted at the `MountPoint`, it
-- will be left as-is by this property.
mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux
mounted :: MountPoint
-> MountPoint -> MountPoint -> MountOpts -> Property Linux
mounted MountPoint
fs MountPoint
src MountPoint
mnt MountOpts
opts = Property UnixLike -> Property Linux
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$ 
	MountPoint
-> MountPoint -> MountPoint -> MountOpts -> Property UnixLike
listed MountPoint
fs MountPoint
src MountPoint
mnt MountOpts
opts
		Property UnixLike
-> Property UnixLike
-> CombinedType (Property UnixLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
mountnow
		Property UnixLike
-> Property UnixLike
-> CombinedType (Property UnixLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` MountPoint -> Property UnixLike
File.dirExists MountPoint
mnt
  where
	-- This use of mountPoints, which is linux-only, is why this
	-- property currently only supports linux.
	mountnow :: Property UnixLike
mountnow = IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (MountPoint -> [MountPoint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem MountPoint
mnt ([MountPoint] -> Bool) -> IO [MountPoint] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [MountPoint]
mountPoints) (UncheckedProperty UnixLike -> Property UnixLike)
-> UncheckedProperty UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
		MountPoint -> [MountPoint] -> UncheckedProperty UnixLike
cmdProperty MountPoint
"mount" [MountPoint
mnt]

-- | Ensures that </etc/fstab> contains a line mounting the specified
-- `Source` on the specified `MountPoint`. Does not ensure that it's
-- currently `mounted`.
listed :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
listed :: MountPoint
-> MountPoint -> MountPoint -> MountOpts -> Property UnixLike
listed MountPoint
fs MountPoint
src MountPoint
mnt MountOpts
opts = MountPoint
"/etc/fstab" MountPoint -> MountPoint -> Property UnixLike
`File.containsLine` MountPoint
l
	Property UnixLike -> MountPoint -> Property UnixLike
forall p. IsProp p => p -> MountPoint -> p
`describe` (MountPoint
mnt MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" mounted by fstab")
  where
	l :: MountPoint
l = MountPoint -> [MountPoint] -> MountPoint
forall a. [a] -> [[a]] -> [a]
intercalate MountPoint
"\t" [MountPoint
src, MountPoint
mnt, MountPoint
fs, MountOpts -> MountPoint
formatMountOpts MountOpts
opts, MountPoint
dump, MountPoint
passno]
	dump :: MountPoint
dump = MountPoint
"0"
	passno :: MountPoint
passno = MountPoint
"2"

-- | Ensures that </etc/fstab> contains a line enabling the specified
-- `Source` to be used as swap space, and that it's enabled.
swap :: Source -> Property Linux
swap :: MountPoint -> Property Linux
swap MountPoint
src = MountPoint
-> MountPoint -> MountPoint -> MountOpts -> Property UnixLike
listed MountPoint
"swap" MountPoint
src MountPoint
"none" MountOpts
forall a. Monoid a => a
mempty
	Property UnixLike
-> RevertableProperty Linux Linux
-> CombinedType
     (Property UnixLike) (RevertableProperty Linux Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` MountPoint -> RevertableProperty Linux Linux
swapOn MountPoint
src

newtype SwapPartition = SwapPartition FilePath

-- | Replaces </etc/fstab> with a file that should cause the currently
-- mounted partitions to be re-mounted the same way on boot.
--
-- For each specified MountPoint, the UUID of each partition
-- (or if there is no UUID, its label), its filesystem type,
-- and its mount options are all automatically probed.
--
-- The SwapPartitions are also included in the generated fstab.
fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
fstabbed [MountPoint]
mnts [SwapPartition]
swaps = MountPoint
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
"fstabbed" ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
       'Targeting 'OSArchLinux]
  -> Propellor Result)
 -> Property Linux)
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property Linux
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
o -> do
	[MountPoint]
fstab <- IO [MountPoint] -> Propellor [MountPoint]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [MountPoint] -> Propellor [MountPoint])
-> IO [MountPoint] -> Propellor [MountPoint]
forall a b. (a -> b) -> a -> b
$ [MountPoint]
-> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [MountPoint]
genFstab [MountPoint]
mnts [SwapPartition]
swaps MountPoint -> MountPoint
forall a. a -> a
id
	OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
-> Property UnixLike -> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
o (Property UnixLike -> Propellor Result)
-> Property UnixLike -> Propellor Result
forall a b. (a -> b) -> a -> b
$ 
		MountPoint
"/etc/fstab" MountPoint -> [MountPoint] -> Property UnixLike
`File.hasContent` [MountPoint]
fstab

genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]
genFstab :: [MountPoint]
-> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [MountPoint]
genFstab [MountPoint]
mnts [SwapPartition]
swaps MountPoint -> MountPoint
mnttransform = do
	[[MountPoint]]
fstab <- IO [[MountPoint]] -> IO [[MountPoint]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[MountPoint]] -> IO [[MountPoint]])
-> IO [[MountPoint]] -> IO [[MountPoint]]
forall a b. (a -> b) -> a -> b
$ (MountPoint -> IO [MountPoint])
-> [MountPoint] -> IO [[MountPoint]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MountPoint -> IO [MountPoint]
getcfg ([MountPoint] -> [MountPoint]
forall a. Ord a => [a] -> [a]
sort [MountPoint]
mnts)
	[[MountPoint]]
swapfstab <- IO [[MountPoint]] -> IO [[MountPoint]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[MountPoint]] -> IO [[MountPoint]])
-> IO [[MountPoint]] -> IO [[MountPoint]]
forall a b. (a -> b) -> a -> b
$ (SwapPartition -> IO [MountPoint])
-> [SwapPartition] -> IO [[MountPoint]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SwapPartition -> IO [MountPoint]
getswapcfg [SwapPartition]
swaps
	[MountPoint] -> IO [MountPoint]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MountPoint] -> IO [MountPoint])
-> [MountPoint] -> IO [MountPoint]
forall a b. (a -> b) -> a -> b
$ [MountPoint]
header [MountPoint] -> [MountPoint] -> [MountPoint]
forall a. [a] -> [a] -> [a]
++ [[MountPoint]] -> [MountPoint]
formatTable ([MountPoint]
legend [MountPoint] -> [[MountPoint]] -> [[MountPoint]]
forall a. a -> [a] -> [a]
: [[MountPoint]]
fstab [[MountPoint]] -> [[MountPoint]] -> [[MountPoint]]
forall a. [a] -> [a] -> [a]
++ [[MountPoint]]
swapfstab)
  where
	header :: [MountPoint]
header =
		[ MountPoint
"# /etc/fstab: static file system information. See fstab(5)"
		, MountPoint
"# "
		]
	legend :: [MountPoint]
legend = [MountPoint
"# <file system>", MountPoint
"<mount point>", MountPoint
"<type>", MountPoint
"<options>", MountPoint
"<dump>", MountPoint
"<pass>"]
	getcfg :: MountPoint -> IO [MountPoint]
getcfg MountPoint
mnt = [IO MountPoint] -> IO [MountPoint]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
		[ MountPoint -> Maybe MountPoint -> MountPoint
forall a. a -> Maybe a -> a
fromMaybe (MountPoint -> MountPoint
forall a. HasCallStack => MountPoint -> a
error (MountPoint -> MountPoint) -> MountPoint -> MountPoint
forall a b. (a -> b) -> a -> b
$ MountPoint
"unable to find mount source for " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
mnt)
			(Maybe MountPoint -> MountPoint)
-> IO (Maybe MountPoint) -> IO MountPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MountPoint -> IO (Maybe MountPoint)) -> IO (Maybe MountPoint))
-> [MountPoint -> IO (Maybe MountPoint)] -> IO (Maybe MountPoint)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
getM (\MountPoint -> IO (Maybe MountPoint)
a -> MountPoint -> IO (Maybe MountPoint)
a MountPoint
mnt)
				[ (MountPoint -> IO (Maybe MountPoint))
-> MountPoint -> IO (Maybe MountPoint)
forall {t}.
(t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
uuidprefix MountPoint -> IO (Maybe MountPoint)
getMountUUID
				, (MountPoint -> IO (Maybe MountPoint))
-> MountPoint -> IO (Maybe MountPoint)
forall {t}.
(t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
sourceprefix MountPoint -> IO (Maybe MountPoint)
getMountLabel
				, MountPoint -> IO (Maybe MountPoint)
getMountSource
				]
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MountPoint -> MountPoint
mnttransform MountPoint
mnt)
		, MountPoint -> Maybe MountPoint -> MountPoint
forall a. a -> Maybe a -> a
fromMaybe MountPoint
"auto" (Maybe MountPoint -> MountPoint)
-> IO (Maybe MountPoint) -> IO MountPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountPoint -> IO (Maybe MountPoint)
getFsType MountPoint
mnt
		, MountOpts -> MountPoint
formatMountOpts (MountOpts -> MountPoint) -> IO MountOpts -> IO MountPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountPoint -> IO MountOpts
getFsMountOpts MountPoint
mnt
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
"0"
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if MountPoint
mnt MountPoint -> MountPoint -> Bool
forall a. Eq a => a -> a -> Bool
== MountPoint
"/" then MountPoint
"1" else MountPoint
"2")
		]
	getswapcfg :: SwapPartition -> IO [MountPoint]
getswapcfg (SwapPartition MountPoint
s) = [IO MountPoint] -> IO [MountPoint]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
		[ MountPoint -> Maybe MountPoint -> MountPoint
forall a. a -> Maybe a -> a
fromMaybe MountPoint
s (Maybe MountPoint -> MountPoint)
-> IO (Maybe MountPoint) -> IO MountPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MountPoint -> IO (Maybe MountPoint)) -> IO (Maybe MountPoint))
-> [MountPoint -> IO (Maybe MountPoint)] -> IO (Maybe MountPoint)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
getM (\MountPoint -> IO (Maybe MountPoint)
a -> MountPoint -> IO (Maybe MountPoint)
a MountPoint
s)
			[ (MountPoint -> IO (Maybe MountPoint))
-> MountPoint -> IO (Maybe MountPoint)
forall {t}.
(t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
uuidprefix MountPoint -> IO (Maybe MountPoint)
getSourceUUID
			, (MountPoint -> IO (Maybe MountPoint))
-> MountPoint -> IO (Maybe MountPoint)
forall {t}.
(t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
sourceprefix MountPoint -> IO (Maybe MountPoint)
getSourceLabel
			]
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
"none"
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
"swap"
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MountOpts -> MountPoint
formatMountOpts MountOpts
forall a. Monoid a => a
mempty)
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
"0"
		, MountPoint -> IO MountPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure MountPoint
"0"
		]
	prefix :: [a] -> (t -> f (f [a])) -> t -> f (f [a])
prefix [a]
s t -> f (f [a])
getter t
m = ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) (f [a] -> f [a]) -> f (f [a]) -> f (f [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> f (f [a])
getter t
m
	uuidprefix :: (t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
uuidprefix = MountPoint
-> (t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
forall {f :: * -> *} {f :: * -> *} {a} {t}.
(Functor f, Functor f) =>
[a] -> (t -> f (f [a])) -> t -> f (f [a])
prefix MountPoint
"UUID="
	sourceprefix :: (t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
sourceprefix = MountPoint
-> (t -> IO (Maybe MountPoint)) -> t -> IO (Maybe MountPoint)
forall {f :: * -> *} {f :: * -> *} {a} {t}.
(Functor f, Functor f) =>
[a] -> (t -> f (f [a])) -> t -> f (f [a])
prefix MountPoint
"LABEL="

-- | Checks if </etc/fstab> is not configured. 
-- This is the case if it doesn't exist, or
-- consists entirely of blank lines or comments.
--
-- So, if you want to only replace the fstab once, and then never touch it
-- again, allowing local modifications:
--
-- > check noFstab (fstabbed mnts [])
noFstab :: IO Bool
noFstab :: IO Bool
noFstab = IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (MountPoint -> IO Bool
doesFileExist MountPoint
"/etc/fstab")
	( [MountPoint] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([MountPoint] -> Bool)
-> (MountPoint -> [MountPoint]) -> MountPoint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MountPoint -> Bool) -> [MountPoint] -> [MountPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter MountPoint -> Bool
iscfg ([MountPoint] -> [MountPoint])
-> (MountPoint -> [MountPoint]) -> MountPoint -> [MountPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> [MountPoint]
lines (MountPoint -> Bool) -> IO MountPoint -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountPoint -> IO MountPoint
readFile MountPoint
"/etc/fstab"
	, Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
	)
  where
	iscfg :: MountPoint -> Bool
iscfg MountPoint
l
		| MountPoint -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MountPoint
l = Bool
False
		| Bool
otherwise = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MountPoint
"#" MountPoint -> MountPoint -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Bool) -> MountPoint -> MountPoint
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace MountPoint
l