{-# 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 (NonEmpty MountOpts -> MountOpts
MountOpts -> MountOpts -> 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 :: forall b. Integral b => 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
[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
Monoid)

class ToMountOpts a where
	toMountOpts :: a -> MountOpts
	
instance ToMountOpts MountOpts where
	toMountOpts :: MountOpts -> MountOpts
toMountOpts = 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) = 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
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
mounted String
fs String
src String
mnt MountOpts
opts = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property (String
mnt forall a. [a] -> [a] -> [a]
++ String
" mounted") forall a b. (a -> b) -> a -> b
$ 
	forall t. ToResult t => t -> Result
toResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$
	String
-> [String]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
cmdProperty String
"mount" [String
"--bind", String
src, String
dest]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall p. IsProp p => p -> String -> p
`describe` (String
"bind mounted " forall a. [a] -> [a] -> [a]
++ String
src forall a. [a] -> [a] -> [a]
++ String
" to " 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 = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
doswapon forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
doswapoff
  where
	swaps :: IO [String]
swaps = String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"swapon" [String
"--show=NAME"]
	doswapon :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
doswapon = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
mnt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
swaps) forall a b. (a -> b) -> a -> b
$
		String
-> [String]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
cmdProperty String
"swapon" [String
mnt]
	doswapoff :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
doswapoff = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
mnt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
swaps) forall a b. (a -> b) -> a -> b
$
		String
-> [String]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
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" 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 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 = forall a. Maybe a -> Bool
isJust 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (\String
p -> String -> String
simplifyPath String
p forall a. Eq a => a -> a -> Bool
/= String -> String
simplifyPath String
target)
	forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
dirContains String
target)
	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 =
	forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
']')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
getThem forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
	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 forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') String
l)
	bracketed :: String
bracketed = String
"[" forall a. [a] -> [a] -> [a]
++ String
sourceDir 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. ToMountOpts a => a -> MountOpts
toMountOpts
	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 = forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
	forall a. [a] -> Maybe a
headMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"findmnt" (String
"-n" forall a. a -> [a] -> [a]
: [String]
ps 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 = forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
	forall a. [a] -> Maybe a
headMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		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 =  
	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 ]) forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *) a. MonadIO m => String -> m a
stopPropellorMessage forall a b. (a -> b) -> a -> b
$ String
"failed unmounting " 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
	forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse (forall a. Ord a => [a] -> [a]
sort [String]
submnts)) String -> IO ()
umountLazy