{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}

-- | Properties in this module ensure that things are currently mounted,
-- but without making the mount persistent. Use `Propellor.Property.Fstab`
-- to configure persistent mounts.

module Propellor.Property.Mount where

import Propellor.Base
import Utility.Path

import Data.List
import qualified Data.Semigroup as Sem

-- | type of filesystem to mount ("auto" to autodetect)
type FsType = String

-- | A device or other thing to be mounted.
type Source = String

-- | A mount point for a filesystem.
type MountPoint = FilePath

-- | Filesystem mount options. Eg, MountOpts ["errors=remount-ro"]
--
-- For default mount options, use `mempty`.
newtype MountOpts = MountOpts [String]
	deriving (b -> MountOpts -> MountOpts
NonEmpty MountOpts -> MountOpts
MountOpts -> MountOpts -> MountOpts
(MountOpts -> MountOpts -> MountOpts)
-> (NonEmpty MountOpts -> MountOpts)
-> (forall b. Integral b => b -> MountOpts -> MountOpts)
-> Semigroup MountOpts
forall b. Integral b => b -> MountOpts -> MountOpts
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> MountOpts -> MountOpts
$cstimes :: forall b. Integral b => b -> MountOpts -> MountOpts
sconcat :: NonEmpty MountOpts -> MountOpts
$csconcat :: NonEmpty MountOpts -> MountOpts
<> :: MountOpts -> MountOpts -> MountOpts
$c<> :: MountOpts -> MountOpts -> MountOpts
Sem.Semigroup, Semigroup MountOpts
MountOpts
Semigroup MountOpts
-> MountOpts
-> (MountOpts -> MountOpts -> MountOpts)
-> ([MountOpts] -> MountOpts)
-> Monoid MountOpts
[MountOpts] -> MountOpts
MountOpts -> MountOpts -> MountOpts
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [MountOpts] -> MountOpts
$cmconcat :: [MountOpts] -> MountOpts
mappend :: MountOpts -> MountOpts -> MountOpts
$cmappend :: MountOpts -> MountOpts -> MountOpts
mempty :: MountOpts
$cmempty :: MountOpts
$cp1Monoid :: Semigroup MountOpts
Monoid)

class ToMountOpts a where
	toMountOpts :: a -> MountOpts
	
instance ToMountOpts MountOpts where
	toMountOpts :: MountOpts -> MountOpts
toMountOpts = MountOpts -> MountOpts
forall a. a -> a
id

instance ToMountOpts String where
	toMountOpts :: String -> MountOpts
toMountOpts String
s = [String] -> MountOpts
MountOpts [String
s]

formatMountOpts :: MountOpts -> String
formatMountOpts :: MountOpts -> String
formatMountOpts (MountOpts []) = String
"defaults"
formatMountOpts (MountOpts [String]
l) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
l

-- | Mounts a device, without listing it in </etc/fstab>.
--
-- Note that this property will fail if the device is already mounted
-- at the MountPoint.
mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted :: String -> String -> String -> MountOpts -> Property UnixLike
mounted String
fs String
src String
mnt MountOpts
opts = String -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property (String
mnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" mounted") (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$ 
	Bool -> Result
forall t. ToResult t => t -> Result
toResult (Bool -> Result) -> Propellor Bool -> Propellor Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> String -> MountOpts -> IO Bool
mount String
fs String
src String
mnt MountOpts
opts)

-- | Bind mounts the first directory so its contents also appear
-- in the second directory.
bindMount :: FilePath -> FilePath -> Property Linux
bindMount :: String -> String -> Property Linux
bindMount String
src String
dest = 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
$
	String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"mount" [String
"--bind", String
src, String
dest]
		UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		Property UnixLike -> String -> Property UnixLike
forall p. IsProp p => p -> String -> p
`describe` (String
"bind mounted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)

-- | Enables swapping to a device, which must be formatted already as a swap
-- partition.
swapOn :: Source -> RevertableProperty Linux Linux
swapOn :: String -> RevertableProperty Linux Linux
swapOn String
mnt = 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
doswapon Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> 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
doswapoff
  where
	swaps :: IO [String]
swaps = String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"swapon" [String
"--show=NAME"]
	doswapon :: Property UnixLike
doswapon = IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
mnt ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
swaps) (UncheckedProperty UnixLike -> Property UnixLike)
-> UncheckedProperty UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
		String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"swapon" [String
mnt]
	doswapoff :: Property UnixLike
doswapoff = IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
mnt ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
swaps) (UncheckedProperty UnixLike -> Property UnixLike)
-> UncheckedProperty UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
		String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"swapoff" [String
mnt]

mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount :: String -> String -> String -> MountOpts -> IO Bool
mount String
fs String
src String
mnt MountOpts
opts = String -> [CommandParam] -> IO Bool
boolSystem String
"mount" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$
	[ String -> CommandParam
Param String
"-t", String -> CommandParam
Param String
fs
	, String -> CommandParam
Param String
"-o", String -> CommandParam
Param (MountOpts -> String
formatMountOpts MountOpts
opts)
	, String -> CommandParam
Param String
src
	, String -> CommandParam
Param String
mnt
	]

-- | Lists all mount points of the system.
mountPoints :: IO [MountPoint]
mountPoints :: IO [String]
mountPoints = String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"findmnt" [String
"-rn", String
"--output", String
"target"]

-- | Checks if anything is mounted at the MountPoint.
isMounted :: MountPoint -> IO Bool
isMounted :: String -> IO Bool
isMounted String
mnt = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
getFsType String
mnt

-- | Finds all filesystems mounted inside the specified directory.
mountPointsBelow :: FilePath -> IO [MountPoint]
mountPointsBelow :: String -> IO [String]
mountPointsBelow String
target = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
p -> String -> String
simplifyPath String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> String
simplifyPath String
target)
	([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
dirContains String
target)
	([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
mountPoints

-- | Get mountpoints which are bind mounts of subdirectories of mounted
-- filesystems
--
-- E.g. as created by @mount --bind /etc/foo /etc/bar@ where @/etc/foo@ is not
-- itself a mount point, but just a subdirectory.  These are sometimes known as
-- "partial bind mounts"
partialBindMountsOf :: FilePath -> IO [MountPoint]
partialBindMountsOf :: String -> IO [String]
partialBindMountsOf String
sourceDir =
	(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']')) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
getThem ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
	(String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"findmnt" [String
"-rn", String
"--output", String
"source,target"]
  where
	getThem :: String -> Bool
getThem String
l = String
bracketed String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') String
l)
	bracketed :: String
bracketed = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sourceDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

-- | Filesystem type mounted at a given location.
getFsType :: MountPoint -> IO (Maybe FsType)
getFsType :: String -> IO (Maybe String)
getFsType String
p = String -> [String] -> IO (Maybe String)
findmntField String
"fstype" [String
p]

-- | Mount options for the filesystem mounted at a given location.
getFsMountOpts :: MountPoint -> IO MountOpts
getFsMountOpts :: String -> IO MountOpts
getFsMountOpts String
p = MountOpts -> (String -> MountOpts) -> Maybe String -> MountOpts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MountOpts
forall a. Monoid a => a
mempty String -> MountOpts
forall a. ToMountOpts a => a -> MountOpts
toMountOpts
	(Maybe String -> MountOpts) -> IO (Maybe String) -> IO MountOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO (Maybe String)
findmntField String
"fs-options" [String
p]

type UUID = String

-- | UUID of filesystem mounted at a given location.
getMountUUID :: MountPoint -> IO (Maybe UUID)
getMountUUID :: String -> IO (Maybe String)
getMountUUID String
p = String -> [String] -> IO (Maybe String)
findmntField String
"uuid" [String
p]

-- | UUID of a device
getSourceUUID :: Source -> IO (Maybe UUID)
getSourceUUID :: String -> IO (Maybe String)
getSourceUUID = String -> String -> IO (Maybe String)
blkidTag String
"UUID"

type Label = String

-- | Label of filesystem mounted at a given location.
getMountLabel :: MountPoint -> IO (Maybe Label)
getMountLabel :: String -> IO (Maybe String)
getMountLabel String
p = String -> [String] -> IO (Maybe String)
findmntField String
"label" [String
p]

-- | Label of a device
getSourceLabel :: Source -> IO (Maybe UUID)
getSourceLabel :: String -> IO (Maybe String)
getSourceLabel = String -> String -> IO (Maybe String)
blkidTag String
"LABEL"

-- | Device mounted at a given location.
getMountSource :: MountPoint -> IO (Maybe Source)
getMountSource :: String -> IO (Maybe String)
getMountSource String
p = String -> [String] -> IO (Maybe String)
findmntField String
"source" [String
p]

-- | Device that a given path is located within.
getMountContaining :: FilePath -> IO (Maybe Source)
getMountContaining :: String -> IO (Maybe String)
getMountContaining String
p = String -> [String] -> IO (Maybe String)
findmntField String
"source" [String
"-T", String
p]

findmntField :: String -> [String] -> IO (Maybe String)
findmntField :: String -> [String] -> IO (Maybe String)
findmntField String
field [String]
ps = Maybe String -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Maybe String
forall a. Maybe a
Nothing (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
	[String] -> Maybe String
forall a. [a] -> Maybe a
headMaybe ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		(String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"findmnt" (String
"-n" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--output", String
field])

blkidTag :: String -> Source -> IO (Maybe String)
blkidTag :: String -> String -> IO (Maybe String)
blkidTag String
tag String
dev = Maybe String -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Maybe String
forall a. Maybe a
Nothing (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
	[String] -> Maybe String
forall a. [a] -> Maybe a
headMaybe ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		(String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"blkid" [String
dev, String
"-s", String
tag, String
"-o", String
"value"]

-- | Unmounts a device or mountpoint,
-- lazily so any running processes don't block it.
--
-- Note that this will fail if it's not mounted.
umountLazy :: FilePath -> IO ()
umountLazy :: String -> IO ()
umountLazy String
mnt =  
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystem String
"umount" [ String -> CommandParam
Param String
"-l", String -> CommandParam
Param String
mnt ]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
stopPropellorMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"failed unmounting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mnt

-- | Unmounts anything mounted inside the specified directory,
-- not including the directory itself.
unmountBelow :: FilePath -> IO ()
unmountBelow :: String -> IO ()
unmountBelow String
d = do
	[String]
submnts <- String -> IO [String]
mountPointsBelow String
d
	-- sort so sub-mounts are unmounted before the mount point
	-- containing them
	[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
submnts)) String -> IO ()
umountLazy