From baf65fa9fff4b8451ba7f1ee129484723a8deb9b Mon Sep 17 00:00:00 2001 From: Daniel Brooks Date: Tue, 4 Apr 2017 23:32:57 -0700 Subject: break Fstab.mounted into smaller pieces which can be composed --- src/Propellor/Property/Fstab.hs | 52 ++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 16 deletions(-) (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 602276ea..7bf18726 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -14,6 +14,17 @@ import Data.Char import Data.List import Utility.Table +-- | Ensures that contains a line mounting the specified +-- `Source` on the specified `MountPoint`. +listed :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux +listed fs src mnt opts = tightenTargets $ + "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + -- | Ensures that contains a line mounting the specified -- `Source` on the specified `MountPoint`, and that it's currently mounted. -- @@ -24,20 +35,29 @@ import Utility.Table -- Note that if anything else is already mounted at the `MountPoint`, it -- will be left as-is by this property. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux -mounted fs src mnt opts = tightenTargets $ - "/etc/fstab" `File.containsLine` l - `describe` (mnt ++ " mounted by fstab") - `onChange` mountnow - where - l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] - dump = "0" - passno = "2" - -- This use of mountPoints, which is linux-only, is why this - -- property currently only supports linux. - mountnow = check (notElem mnt <$> mountPoints) $ - if fs == "swap" - then cmdProperty "swapon" [mnt] - else cmdProperty "mount" [mnt] +mounted fs src mnt opts = (listed fs src mnt opts) `onChange` (mountNow src) + +-- | Ensures that contains a line enabling the specified +-- `Source` to be used as swap space, and that it's enabled +swap :: Source -> Property Linux +swap src = (listed "swap" src "none" mempty) `onChange` (swapOn src) + +-- This use of mountPoints, which is linux-only, is why this +-- property currently only supports linux. +mountNow :: Source -> RevertableProperty Linux Linux +mountNow mnt = tightenTargets domount tightenTargets doumount + where domount = check (notElem mnt <$> mountPoints) $ + cmdProperty "mount" [mnt] + doumount = check (elem mnt <$> mountPoints) $ + cmdProperty "umount" [mnt] + +swapOn :: Source -> RevertableProperty Linux Linux +swapOn mnt = tightenTargets doswapon tightenTargets doswapoff + where swaps = lines <$> readProcess "swapon" ["--no-headings", "--show=NAME"] + doswapon = check (notElem mnt <$> swaps) $ + cmdProperty "swapon" [mnt] + doswapoff = check (elem mnt <$> swaps) $ + cmdProperty "swapoff" [mnt] newtype SwapPartition = SwapPartition FilePath @@ -79,8 +99,8 @@ genFstab mnts swaps mnttransform = do , pure "0" , pure (if mnt == "/" then "1" else "2") ] - getswapcfg (SwapPartition swap) = sequence - [ fromMaybe swap <$> getM (\a -> a swap) + getswapcfg (SwapPartition s) = sequence + [ fromMaybe s <$> getM (\a -> a s) [ uuidprefix getSourceUUID , sourceprefix getSourceLabel ] -- cgit v1.2.3