From 3c0575f156eead78ed98a8cd9276bc663c8d587c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 03:30:03 -0400 Subject: Added Mount.fstabbed property to generate /etc/fstab to replicate current mounts. --- debian/changelog | 2 + src/Propellor/Property/DiskImage.hs | 17 ++-- src/Propellor/Property/Mount.hs | 158 +++++++++++++++++++++++++++++++----- 3 files changed, 146 insertions(+), 31 deletions(-) diff --git a/debian/changelog b/debian/changelog index 051a9748..487826e1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,8 @@ propellor (2.11.1) UNRELEASED; urgency=medium * The DiskImage module can now make bootable images using grub. * Add a ChrootTarball chroot type, for using pre-built tarballs as chroots. Thanks, Ben Boeckel. + * Added Mount.fstabbed property to generate /etc/fstab to replicate + current mounts. -- Joey Hess Thu, 22 Oct 2015 20:24:18 -0400 diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 1e3a5407..b65d399c 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -133,7 +133,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg imageFinalized final mnts devs rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [MountPoint] -> [LoopDev] -> Property NoInfo +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs where desc = "partitions populated from " ++ chrootdir @@ -197,14 +197,14 @@ dirSizes top = go M.empty top [top] else go (M.insertWith (+) dir sz m) dir is subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent -getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize +getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize getMountSz _ _ Nothing = Nothing getMountSz szm l (Just mntpt) = fmap (`reducePartSize` childsz) (M.lookup mntpt szm) where childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) -isChild :: FilePath -> MountPoint -> Bool +isChild :: FilePath -> Maybe MountPoint -> Bool isChild mntpt (Just d) | d `equalFilePath` mntpt = False | otherwise = mntpt `dirContains` d @@ -217,9 +217,6 @@ toSysDir chrootdir d = case makeRelative chrootdir d of "." -> "/" sysdir -> "/" ++ sysdir --- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. -type MountPoint = Maybe FilePath - defSz :: PartSize defSz = MegaBytes 128 @@ -240,7 +237,7 @@ fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3) -- (Partitions that are not to be mounted (ie, LinuxSwap), or that have -- no corresponding directory in the chroot will have 128 MegaBytes -- provided as a default size.) -type PartSpec = (MountPoint, PartSize -> Partition) +type PartSpec = (Maybe MountPoint, PartSize -> Partition) -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec @@ -279,7 +276,7 @@ adjustp (mp, p) f = (mp, f . p) -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable) +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], PartTable) fitChrootSize tt l basesizes = (mounts, parttable) where (mounts, sizers) = unzip l @@ -297,7 +294,7 @@ fitChrootSize tt l basesizes = (mounts, parttable) -- in the partition tree. type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) -imageFinalized :: Finalization -> [MountPoint] -> [LoopDev] -> Property NoInfo +imageFinalized :: Finalization -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo imageFinalized (_, final) mnts devs = property "disk image finalized" $ withTmpDir "mnt" $ \top -> go top `finally` liftIO (unmountall top) @@ -308,7 +305,7 @@ imageFinalized (_, final) mnts devs = property "disk image finalized" $ -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local - orderedmntsdevs :: [(MountPoint, LoopDev)] + orderedmntsdevs :: [(Maybe MountPoint, LoopDev)] orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of 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 = ["# ", "", "", "", "", ""] + 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] -- cgit v1.2.3