summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 15:14:00 -0400
committerJoey Hess2015-10-23 15:14:00 -0400
commite9fdfd5de1546f880d3bc8868a235a68f5f01e54 (patch)
treef46a402d83bc3d264ee50ddeb62391098b196f2c /src
parentc9e408af6ddb296d60c6eeb6cdb3210262dd7cde (diff)
allow specifying filesystem mount options
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Chroot.hs2
-rw-r--r--src/Propellor/Property/DiskImage.hs52
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs40
-rw-r--r--src/Propellor/Property/Mount.hs48
-rw-r--r--src/Propellor/Property/OS.hs6
5 files changed, 92 insertions, 56 deletions
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