module Propellor.Property.Mount where
import Propellor.Base
import qualified Propellor.Property.File as File
import Utility.Path
import Data.Char
import Data.List
import Utility.Table
type FsType = String
type Source = String
type MountPoint = FilePath
newtype MountOpts = MountOpts [String]
deriving Monoid
class ToMountOpts a where
toMountOpts :: a -> MountOpts
instance ToMountOpts MountOpts where
toMountOpts = id
instance ToMountOpts String where
toMountOpts s = MountOpts [s]
formatMountOpts :: MountOpts -> String
formatMountOpts (MountOpts []) = "defaults"
formatMountOpts (MountOpts l) = intercalate "," l
mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted fs src mnt opts = property (mnt ++ " mounted") $
toResult <$> liftIO (mount fs src mnt opts)
bindMount :: FilePath -> FilePath -> Property Linux
bindMount src dest = tightenTargets $
cmdProperty "mount" ["--bind", src, dest]
`assume` MadeChange
`describe` ("bind mounted " ++ src ++ " to " ++ dest)
mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount fs src mnt opts = boolSystem "mount" $
[ Param "-t", Param fs
, Param "-o", Param (formatMountOpts opts)
, Param src
, Param mnt
]
newtype SwapPartition = SwapPartition FilePath
fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
fstabbed mnts swaps = property' "fstabbed" $ \o -> do
fstab <- liftIO $ genFstab mnts swaps id
ensureProperty o $
"/etc/fstab" `File.hasContent` fstab
genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]
genFstab mnts swaps mnttransform = do
fstab <- liftIO $ mapM getcfg (sort mnts)
swapfstab <- liftIO $ mapM getswapcfg swaps
return $ header ++ formatTable (legend : fstab ++ swapfstab)
where
header =
[ "# /etc/fstab: static file system information. See fstab(5)"
, "# "
]
legend = ["# <file system>", "<mount point>", "<type>", "<options>", "<dump>", "<pass>"]
getcfg mnt = sequence
[ fromMaybe (error $ "unable to find mount source for " ++ mnt)
<$> getM (\a -> a mnt)
[ uuidprefix getMountUUID
, sourceprefix getMountLabel
, getMountSource
]
, pure (mnttransform mnt)
, fromMaybe "auto" <$> getFsType mnt
, formatMountOpts <$> getFsMountOpts mnt
, pure "0"
, pure (if mnt == "/" then "1" else "2")
]
getswapcfg (SwapPartition swap) = sequence
[ fromMaybe swap <$> getM (\a -> a swap)
[ uuidprefix getSourceUUID
, sourceprefix getSourceLabel
]
, pure "none"
, pure "swap"
, pure (formatMountOpts mempty)
, pure "0"
, pure "0"
]
prefix s getter m = fmap (s ++) <$> getter m
uuidprefix = prefix "UUID="
sourceprefix = prefix "LABEL="
noFstab :: IO Bool
noFstab = ifM (doesFileExist "/etc/fstab")
( null . filter iscfg . lines <$> readFile "/etc/fstab"
, return True
)
where
iscfg l
| null l = False
| otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l
mountPoints :: IO [MountPoint]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
mountPointsBelow :: FilePath -> IO [MountPoint]
mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
getFsType :: MountPoint -> IO (Maybe FsType)
getFsType = findmntField "fstype"
getFsMountOpts :: MountPoint -> IO MountOpts
getFsMountOpts p = maybe mempty toMountOpts
<$> findmntField "fs-options" p
type UUID = String
getMountUUID :: MountPoint -> IO (Maybe UUID)
getMountUUID = findmntField "uuid"
getSourceUUID :: Source -> IO (Maybe UUID)
getSourceUUID = blkidTag "UUID"
type Label = String
getMountLabel :: MountPoint -> IO (Maybe Label)
getMountLabel = findmntField "label"
getSourceLabel :: Source -> IO (Maybe UUID)
getSourceLabel = blkidTag "LABEL"
getMountSource :: MountPoint -> IO (Maybe Source)
getMountSource = findmntField "source"
findmntField :: String -> FilePath -> IO (Maybe String)
findmntField field mnt = catchDefaultIO Nothing $
headMaybe . filter (not . null) . lines
<$> readProcess "findmnt" ["-n", mnt, "--output", field]
blkidTag :: String -> Source -> IO (Maybe String)
blkidTag tag dev = catchDefaultIO Nothing $
headMaybe . filter (not . null) . lines
<$> readProcess "blkid" [dev, "-s", tag, "-o", "value"]
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
errorMessage $ "failed unmounting " ++ mnt
unmountBelow :: FilePath -> IO ()
unmountBelow d = do
submnts <- mountPointsBelow d
forM_ submnts umountLazy