summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Mount.hs
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 03:30:03 -0400
committerJoey Hess2015-10-23 03:48:32 -0400
commit3c0575f156eead78ed98a8cd9276bc663c8d587c (patch)
treedebb7c244edbce545cd2bcde8d04d8e9c67c2753 /src/Propellor/Property/Mount.hs
parenta1a79784c892c9fb5370c4283be7d6adbc0cf46a (diff)
Added Mount.fstabbed property to generate /etc/fstab to replicate current mounts.
Diffstat (limited to 'src/Propellor/Property/Mount.hs')
-rw-r--r--src/Propellor/Property/Mount.hs158
1 files changed, 137 insertions, 21 deletions
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 09016011..315e2d48 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -1,29 +1,159 @@
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 of filesystem to mount ("auto" to autodetect)
type Source = String
+type MountPoint = FilePath
+
+-- | Mounts a device.
+mounted :: FsType -> Source -> MountPoint -> Property NoInfo
+mounted fs src mnt = property (mnt ++ " mounted") $
+ toResult <$> liftIO (mount fs src mnt)
+
+-- | Bind mounts the first directory so its contents also appear
+-- in the second directory.
+bindMount :: FilePath -> FilePath -> Property NoInfo
+bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
+ `describe` ("bind mounted " ++ src ++ " to " ++ dest)
+
+mount :: FsType -> Source -> MountPoint -> IO Bool
+mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
+
+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 NoInfo
+fstabbed mnts swaps = property "fstabbed" $ do
+ fstab <- liftIO $ genFstab mnts swaps id
+ ensureProperty $
+ "/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")
+ <$> getM (\a -> a mnt)
+ [ uuidprefix getMountUUID
+ , sourceprefix getMountLabel
+ , getMountSource
+ ]
+ , pure (mnttransform mnt)
+ , fromMaybe "auto" <$> getFsType mnt
+ , fromMaybe "defaults" <$> getFsOptions 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 "defaults"
+ , pure "0"
+ , pure "0"
+ ]
+ prefix s getter m = fmap (s ++) <$> getter m
+ uuidprefix = prefix "UUID="
+ sourceprefix = prefix "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 = 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
+
-- | Lists all mount points of the system.
-mountPoints :: IO [FilePath]
+mountPoints :: IO [MountPoint]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
-- | Finds all filesystems mounted inside the specified directory.
-mountPointsBelow :: FilePath -> IO [FilePath]
+mountPointsBelow :: FilePath -> IO [MountPoint]
mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
-- | Filesystem type mounted at a given location.
-getFsType :: FilePath -> IO (Maybe FsType)
-getFsType mnt = catchDefaultIO Nothing $
- headMaybe . lines
- <$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]
+getFsType :: MountPoint -> IO (Maybe FsType)
+getFsType = findmntField "fstype"
+
+-- | Mount options for the filesystem mounted at a given location.
+getFsOptions :: MountPoint -> IO (Maybe String)
+getFsOptions = findmntField "fs-options"
+
+type UUID = String
+
+-- | UUID of filesystem mounted at a given location.
+getMountUUID :: MountPoint -> IO (Maybe UUID)
+getMountUUID = findmntField "uuid"
--- | Unmounts a device, lazily so any running processes don't block it.
+-- | UUID of a device
+getSourceUUID :: Source -> IO (Maybe UUID)
+getSourceUUID = blkidTag "UUID"
+
+type Label = String
+
+-- | Label of filesystem mounted at a given location.
+getMountLabel :: MountPoint -> IO (Maybe Label)
+getMountLabel = findmntField "label"
+
+-- | Label of a device
+getSourceLabel :: Source -> IO (Maybe UUID)
+getSourceLabel = blkidTag "LABEL"
+
+-- | Device mounted at a given location.
+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]
+
+-- | Unmounts a device or mountpoint,
+-- lazily so any running processes don't block it.
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
@@ -34,17 +164,3 @@ unmountBelow :: FilePath -> IO ()
unmountBelow d = do
submnts <- mountPointsBelow d
forM_ submnts umountLazy
-
--- | Mounts a device.
-mounted :: FsType -> Source -> FilePath -> Property NoInfo
-mounted fs src mnt = property (mnt ++ " mounted") $
- toResult <$> liftIO (mount fs src mnt)
-
--- | Bind mounts the first directory so its contents also appear
--- in the second directory.
-bindMount :: FilePath -> FilePath -> Property NoInfo
-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
- `describe` ("bind mounted " ++ src ++ " to " ++ dest)
-
-mount :: FsType -> Source -> FilePath -> IO Bool
-mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]