From 1f62b0d3a3d247f16f875f02e5bc89c7b7dc9ace Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 14:18:19 -0400 Subject: Changed how the operating system is provided to Chroot (API change). * Where before debootstrapped and bootstrapped took a System parameter, the os property should now be added to the Chroot. * Follow-on change to Systemd.container, which now takes a System parameter. Two motivations for this change: 1. When using ChrootTarball, there may be no particular System that makes sense for the contents of the tarball, so don't force the user to specify one. 2. When creating a chroot for a disk image with the same properties as an existing Host, using hostProperties host to get them, this allows inheriting the os property from the host, and doesn't require it to be redundantly passed to Chroot.debootstrapped. --- src/Propellor/Property/Chroot.hs | 68 +++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 33 deletions(-) (limited to 'src/Propellor/Property/Chroot.hs') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 2b5391fa..f32a9117 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -34,25 +34,26 @@ import System.Posix.Directory -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot + Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot -chrootSystem :: Chroot -> System -chrootSystem (Chroot _ system _ _) = system +chrootSystem :: Chroot -> Maybe System +chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) instance Show Chroot where - show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system + show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) instance PropAccum Chroot where - (Chroot l s c h) `addProp` p = Chroot l s c (h & p) - (Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p) - getProperties (Chroot _ _ _ h) = hostProperties h + (Chroot l c h) `addProp` p = Chroot l c (h & p) + (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) + getProperties (Chroot _ _ h) = hostProperties h -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. - -- If the operating System is not supported, return Nothing. - buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo) + -- If the operating System is not supported, return + -- Left error message. + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -63,7 +64,7 @@ class ChrootBootstrapper b where data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property HasInfo extractTarball target src = toProp . @@ -83,27 +84,28 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig instance ChrootBootstrapper Debootstrapped where buildchroot (Debootstrapped cf) system loc = case system of - (System (Debian _) _) -> Just debootstrap - (System (Ubuntu _) _) -> Just debootstrap + (Just s@(System (Debian _) _)) -> Right $ debootstrap s + (Just s@(System (Ubuntu _) _)) -> Right $ debootstrap s + Nothing -> Left "Cannot debootstrap; `os` property not specified" where - debootstrap = Debootstrap.built loc system cf + debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- --- Properties can be added to configure the Chroot. +-- Properties can be added to configure the Chroot. At a minimum, +-- add the `os` property to specify the operating system to bootstrap. -- --- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev" +-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" +-- > & os (System (Debian Unstable) "amd64") -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot -debootstrapped system conf = bootstrapped system (Debootstrapped conf) +debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot -bootstrapped system bootstrapper location = - Chroot location system bootstrapper h - & os system +bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot +bootstrapped bootstrapper location = Chroot location bootstrapper h where h = Host location [] mempty @@ -117,7 +119,7 @@ provisioned :: Chroot -> RevertableProperty provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty -provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly = +provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propigator $ propertyList (chrootDesc c "exists") [setup]) (propertyList (chrootDesc c "removed") [teardown]) @@ -125,18 +127,18 @@ provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly = setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly `requires` toProp built - built = case buildchroot bootstrapper system loc of - Just p -> p - Nothing -> cantbuild + built = case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> p + Left e -> cantbuild e - cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty [] + cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo -propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c p' +propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty (propertyDesc p) @@ -145,12 +147,12 @@ propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c (propertyChildren p) chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ _ h) = mempty `addInfo` +chrootInfo (Chroot loc _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo -propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -189,7 +191,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " return r toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _ _) systemdonly = do +toChain parenthost (Chroot loc _ _) systemdonly = do onconsole <- isConsole <$> mkMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -214,7 +216,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do +inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -234,10 +236,10 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _ _) = "chroot" mungeloc loc ++ ".shim" +shimdir (Chroot loc _ _) = "chroot" mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- cgit v1.3-2-g0d8e 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/Chroot.hs') 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.3-2-g0d8e