summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Fstab.hs
blob: 7bf187267fc4654a7db5556c1f33be485ed034c4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
module Propellor.Property.Fstab (
	FsType,
	Source,
	MountPoint,
	MountOpts(..),
	module Propellor.Property.Fstab,
) where

import Propellor.Base
import qualified Propellor.Property.File as File
import Propellor.Property.Mount

import Data.Char
import Data.List
import Utility.Table

-- | Ensures that </etc/fstab> 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 </etc/fstab> contains a line mounting the specified
-- `Source` on the specified `MountPoint`, and that it's currently mounted.
--
-- For example:
--
-- > mounted "auto" "/dev/sdb1" "/srv" mempty
--
-- 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 = (listed fs src mnt opts) `onChange` (mountNow src)

-- | Ensures that </etc/fstab> 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

-- | 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 Linux
fstabbed mnts swaps = property' "fstabbed" $ \o -> do
	fstab <- liftIO $ genFstab mnts swaps id
	ensureProperty o $ 
		"/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 = ["# <file system>", "<mount point>", "<type>", "<options>", "<dump>", "<pass>"]
	getcfg mnt = sequence
		[ fromMaybe (error $ "unable to find mount source for " ++ mnt)
			<$> getM (\a -> a mnt)
				[ uuidprefix getMountUUID
				, sourceprefix getMountLabel
				, getMountSource
				]
		, pure (mnttransform mnt)
		, fromMaybe "auto" <$> getFsType mnt
		, formatMountOpts <$> getFsMountOpts mnt
		, pure "0"
		, pure (if mnt == "/" then "1" else "2")
		]
	getswapcfg (SwapPartition s) = sequence
		[ fromMaybe s <$> getM (\a -> a s)
			[ uuidprefix getSourceUUID
			, sourceprefix getSourceLabel
			]
		, pure "none"
		, pure "swap"
		, pure (formatMountOpts mempty)
		, 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