From e9fdfd5de1546f880d3bc8868a235a68f5f01e54 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 15:14:00 -0400 Subject: allow specifying filesystem mount options --- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/DiskImage.hs | 52 ++++++++++++---------------- src/Propellor/Property/DiskImage/PartSpec.hs | 40 ++++++++++++++------- src/Propellor/Property/Mount.hs | 48 +++++++++++++++++++------ src/Propellor/Property/OS.hs | 6 ++-- 5 files changed, 92 insertions(+), 56 deletions(-) (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index f32a9117..ecac1115 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -223,7 +223,7 @@ inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do -- /proc needs to be mounted in the chroot for the linker to use -- /proc/self/exe which is necessary for some commands to work mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ - void $ mount "proc" "proc" procloc + void $ mount "proc" "proc" procloc mempty procloc = loc "proc" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 979a3e6a..90d0bcc6 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -62,6 +62,7 @@ type DiskImage = FilePath -- > `setFlag` BootFlag -- > , partition EXT4 `mountedAt` "/" -- > `addFreeSpace` MegaBytes 100 +-- > `mountOpt` errorReadonly -- > , swapPartition (MegaBytes 256) -- > ] -- @@ -110,28 +111,28 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg <$> liftIO (dirSizes chrootdir) let calcsz mnts = maybe defSz fudge . getMountSz szm mnts -- tie the knot! - let (mnts, parttable) = fitChrootSize tabletype partspec $ + let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts ensureProperty $ imageExists img (partTableSize parttable) `before` partitioned YesReallyDeleteDiskContents img parttable `before` - kpartx img (mkimg' mnts parttable) - mkimg' mnts parttable devs = - partitionsPopulated chrootdir mnts devs + kpartx img (mkimg' mnts mntopts parttable) + mkimg' mnts mntopts parttable devs = + partitionsPopulated chrootdir mnts mntopts devs `before` - imageFinalized final mnts devs parttable + imageFinalized final mnts mntopts devs parttable rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo -partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo +partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs where desc = "partitions populated from " ++ chrootdir - go Nothing _ = noChange - go (Just mnt) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket - (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir) + go Nothing _ _ = noChange + go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) (const $ liftIO $ umountLazy tmpdir) $ \ismounted -> if ismounted then ensureProperty $ @@ -152,10 +153,10 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m -- 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] -> ([Maybe MountPoint], PartTable) -fitChrootSize tt l basesizes = (mounts, parttable) +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) +fitChrootSize tt l basesizes = (mounts, mountopts, parttable) where - (mounts, sizers) = unzip l + (mounts, mountopts, sizers) = unzip3 l parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of @@ -187,15 +188,6 @@ getMountSz szm l (Just mntpt) = where childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) --- Add 2% for filesystem overhead. Rationalle for picking 2%: --- A filesystem with 1% overhead might just sneak by as acceptable. --- Double that just in case. Add an additional 3 mb to deal with --- non-scaling overhead of filesystems (eg, superblocks). --- Add an additional 200 mb for temp files, journals, etc. -fudge :: PartSize -> PartSize -fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) - - -- | Ensures that a disk image file of the specified size exists. -- -- If the file doesn't exist, or is too small, creates a new one, full of 0's. @@ -226,8 +218,8 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do -- in the partition tree. type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [LoopDev] -> PartTable -> Property NoInfo -imageFinalized (_, final) mnts devs (PartTable _ parts) = +imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo +imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = property "disk image finalized" $ withTmpDir "mnt" $ \top -> go top `finally` liftIO (unmountall top) @@ -239,19 +231,19 @@ imageFinalized (_, final) mnts devs (PartTable _ parts) = -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local - orderedmntsdevs :: [(Maybe MountPoint, LoopDev)] - orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs + orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))] + orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs) swaps = map (SwapPartition . partitionLoopDev . snd) $ filter ((== LinuxSwap) . partFs . fst) $ zip parts devs - mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of + mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of Nothing -> noop Just p -> do let mnt = top ++ p createDirectoryIfMissing True mnt - unlessM (mount "auto" (partitionLoopDev loopdev) mnt) $ + unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $ error $ "failed mounting " ++ mnt unmountall top = do @@ -278,8 +270,8 @@ grubBooted bios = (Grub.installed' bios, boots) boots mnt loopdevs = combineProperties "disk image boots using grub" -- bind mount host /dev so grub can access the loop devices [ bindMount "/dev" (inmnt "/dev") - , mounted "proc" "proc" (inmnt "/proc") - , mounted "sysfs" "sys" (inmnt "/sys") + , mounted "proc" "proc" (inmnt "/proc") mempty + , mounted "sysfs" "sys" (inmnt "/sys") mempty -- update the initramfs so it gets the uuid of the root partition , inchroot "update-initramfs" ["-u"] -- work around for http://bugs.debian.org/802717 diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs index 1bd4fb01..4b05df03 100644 --- a/src/Propellor/Property/DiskImage/PartSpec.hs +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -14,44 +14,60 @@ import Propellor.Base import Propellor.Property.Parted import Propellor.Property.Mount --- | Specifies a mount point and a constructor for a Partition. +-- | Specifies a mount point, mount options, and a constructor for a Partition. -- -- The size that is eventually provided is the amount of space needed to -- hold the files that appear in the directory where the partition is to be -- mounted. Plus a fudge factor, since filesystems have some space -- overhead. --- --- (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 = (Maybe MountPoint, PartSize -> Partition) +type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition) +-- | 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. defSz :: PartSize defSz = MegaBytes 128 +-- | Add 2% for filesystem overhead. Rationalle for picking 2%: +-- A filesystem with 1% overhead might just sneak by as acceptable. +-- Double that just in case. Add an additional 3 mb to deal with +-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc. +fudge :: PartSize -> PartSize +fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) + -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec -swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) +swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz)) -- | Specifies a partition with a given filesystem. -- -- The partition is not mounted anywhere by default; use the combinators -- below to configure it. partition :: Fs -> PartSpec -partition fs = (Nothing, mkPartition fs) +partition fs = (Nothing, mempty, mkPartition fs) -- | Specifies where to mount a partition. mountedAt :: PartSpec -> FilePath -> PartSpec -mountedAt (_, p) mp = (Just mp, p) +mountedAt (_, o, p) mp = (Just mp, o, p) + +-- | Specifies a mount option, such as "noexec" +mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec +mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p) + +-- | Mount option to make a partition be remounted readonly when there's an +-- error accessing it. +errorReadonly :: MountOpts +errorReadonly = toMountOpts "errors=remount-ro" -- | Adds additional free space to the partition. addFreeSpace :: PartSpec -> PartSize -> PartSpec -addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz)) +addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz)) -- | Forced a partition to be a specific size, instead of scaling to the -- size needed for the files in the chroot. setSize :: PartSpec -> PartSize -> PartSpec -setSize (mp, p) sz = (mp, const (p sz)) +setSize (mp, o, p) sz = (mp, o, const (p sz)) -- | Sets a flag on the partition. setFlag :: PartSpec -> PartFlag -> PartSpec @@ -62,4 +78,4 @@ extended :: PartSpec -> PartSpec extended s = adjustp s $ \p -> p { partType = Extended } adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, p) f = (mp, f . p) +adjustp (mp, o, p) f = (mp, o, f . p) diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index a08f9e3b..3f13388b 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} + module Propellor.Property.Mount where import Propellor.Base @@ -8,16 +10,36 @@ import Data.Char import Data.List import Utility.Table -type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect) +-- | 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, "errors=remount-ro" +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 + -- | Mounts a device. -mounted :: FsType -> Source -> MountPoint -> Property NoInfo -mounted fs src mnt = property (mnt ++ " mounted") $ - toResult <$> liftIO (mount fs src mnt) +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo +mounted fs src mnt opts = property (mnt ++ " mounted") $ + toResult <$> liftIO (mount fs src mnt opts) -- | Bind mounts the first directory so its contents also appear -- in the second directory. @@ -25,8 +47,13 @@ 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] +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 @@ -64,7 +91,7 @@ genFstab mnts swaps mnttransform = do ] , pure (mnttransform mnt) , fromMaybe "auto" <$> getFsType mnt - , fromMaybe "defaults" <$> getFsOptions mnt + , formatMountOpts <$> getFsMountOpts mnt , pure "0" , pure (if mnt == "/" then "1" else "2") ] @@ -75,7 +102,7 @@ genFstab mnts swaps mnttransform = do ] , pure "none" , pure "swap" - , pure "defaults" + , pure (formatMountOpts mempty) , pure "0" , pure "0" ] @@ -115,8 +142,9 @@ 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" +getFsMountOpts :: MountPoint -> IO MountOpts +getFsMountOpts p = maybe mempty toMountOpts + <$> findmntField "fs-options" p type UUID = String diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index e176e33d..1f22888c 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -123,16 +123,16 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- Remount /dev, so that block devices etc are -- available for other properties to use. - unlessM (mount devfstype devfstype "/dev") $ do + unlessM (mount devfstype devfstype "/dev" mempty) $ do warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic" void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"] -- Mount /sys too, needed by eg, grub-mkconfig. - unlessM (mount "sysfs" "sysfs" "/sys") $ + unlessM (mount "sysfs" "sysfs" "/sys" mempty) $ warningMessage "failed mounting /sys" -- And /dev/pts, used by apt. - unlessM (mount "devpts" "devpts" "/dev/pts") $ + unlessM (mount "devpts" "devpts" "/dev/pts" mempty) $ warningMessage "failed mounting /dev/pts" return MadeChange -- cgit v1.2.3