    {-# 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 s :: String
    s = [String] -> MountOpts
    MountOpts [String
    s]

    formatMountOpts :: MountOpts -> String
    formatMountOpts :: MountOpts -> String
    formatMountOpts (MountOpts []) = "defaults"
    formatMountOpts (MountOpts l :: [String]
    l) = String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate "," [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 fs :: String
    fs src :: String
    src mnt :: String
    mnt opts :: 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]
    ++ " 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 src :: String
    src dest :: 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 "mount" ["--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` ("bind mounted " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    src String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " 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 mnt :: 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 "swapon" ["--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 "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 "swapoff" [String
    mnt]

    mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
    mount :: String -> String -> String -> MountOpts -> IO Bool
    mount fs :: String
    fs src :: String
    src mnt :: String
    mnt opts :: MountOpts
    opts = String -> [CommandParam] -> IO Bool
    boolSystem "mount" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
    forall a b. (a -> b) -> a -> b
    $
    	[ String -> CommandParam
    Param "-t", String -> CommandParam
    Param String
    fs
    	, String -> CommandParam
    Param "-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 "findmnt" ["-rn", "--output", "target"]

    -- | Checks if anything is mounted at the MountPoint.
    isMounted :: MountPoint -> IO Bool
    isMounted :: String -> IO Bool
    isMounted mnt :: 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 target :: String
    target = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\p :: 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 sourceDir :: String
    sourceDir =
    	(String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop 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
    /= ']')) ([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 "findmnt" ["-rn", "--output", "source,target"]
      where
    	getThem :: String -> Bool
    getThem l :: 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
    /= ' ') String
    l)
    	bracketed :: String
    bracketed = "[" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    sourceDir String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "]"

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

    -- | Mount options for the filesystem mounted at a given location.
    getFsMountOpts :: MountPoint -> IO MountOpts
    getFsMountOpts :: String -> IO MountOpts
    getFsMountOpts p :: 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 "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 p :: String
    p = String -> [String] -> IO (Maybe String)
    findmntField "uuid" [String
    p]

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

    type Label = String

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

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

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

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

    findmntField :: String -> [String] -> IO (Maybe String)
    findmntField :: String -> [String] -> IO (Maybe String)
    findmntField field :: String
    field ps :: [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 "findmnt" ("-n" String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    ps [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ ["--output", String
    field])

    blkidTag :: String -> Source -> IO (Maybe String)
    blkidTag :: String -> String -> IO (Maybe String)
    blkidTag tag :: String
    tag dev :: 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 "blkid" [String
    dev, "-s", String
    tag, "-o", "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 mnt :: String
    mnt =
    	IO Bool -> IO () -> IO ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    unlessM (String -> [CommandParam] -> IO Bool
    boolSystem "umount" [ String -> CommandParam
    Param "-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
    $ "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 d :: 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