summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 12:56:01 -0400
committerJoey Hess2015-10-23 12:56:01 -0400
commit64877fd287eb05bb9ff0beaa4fa0a6fe236013c2 (patch)
treef4b8f26355b46cc142d755d42f097251447cb28a
parenta270dd1eddda3874b94e21b60995784a14e2b3a7 (diff)
parent6dc70ff8d01871d2e37a3c5dfea8912737cb63c2 (diff)
Merge branch 'joeyconfig'
-rw-r--r--config-joey.hs5
-rw-r--r--debian/changelog2
-rw-r--r--src/Propellor/Property/Chroot.hs6
-rw-r--r--src/Propellor/Property/DiskImage.hs72
-rw-r--r--src/Propellor/Property/Mount.hs158
-rw-r--r--src/Propellor/Property/Partition.hs2
6 files changed, 193 insertions, 52 deletions
diff --git a/config-joey.hs b/config-joey.hs
index 21d7194f..fce4f7a1 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -82,14 +82,15 @@ darkstar = host "darkstar.kitenet.net"
& JoeySites.dkimMilter
& imageBuilt "/tmp/img" c MSDOS (grubBooted PC)
- [ partition EXT4 `mountedAt` "/"
- `addFreeSpace` MegaBytes 100
+ [ partition EXT2 `mountedAt` "/boot"
`setFlag` BootFlag
+ , partition EXT4 `mountedAt` "/"
, swapPartition (MegaBytes 256)
]
where
c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
& Apt.installed ["linux-image-amd64"]
+ & User "root" `User.hasInsecurePassword` "root"
gnu :: Host
gnu = host "gnu.kitenet.net"
diff --git a/debian/changelog b/debian/changelog
index 578f374d..9ea3129e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -4,6 +4,8 @@ propellor (2.11.1) UNRELEASED; urgency=medium
* Add a ChrootTarball chroot type, for using pre-built tarballs
as chroots. Thanks, Ben Boeckel.
* HostName: Improve domain extraction code.
+ * Added Mount.fstabbed property to generate /etc/fstab to replicate
+ current mounts.
-- Joey Hess <id@joeyh.name> Thu, 22 Oct 2015 20:24:18 -0400
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index d17edae7..2b5391fa 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -1,13 +1,13 @@
{-# LANGUAGE FlexibleContexts, GADTs #-}
module Propellor.Property.Chroot (
+ debootstrapped,
+ bootstrapped,
+ provisioned,
Chroot(..),
ChrootBootstrapper(..),
Debootstrapped(..),
ChrootTarball(..),
- debootstrapped,
- bootstrapped,
- provisioned,
-- * Internal use
provisioned',
propagateChrootInfo,
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 1e3a5407..97880cf4 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -47,7 +47,7 @@ import Propellor.Property.Partition
import Propellor.Property.Rsync
import Utility.Path
-import Data.List (isPrefixOf, sortBy)
+import Data.List (isPrefixOf, isInfixOf, sortBy)
import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
@@ -77,6 +77,10 @@ type DiskImage = FilePath
-- > `addFreeSpace` MegaBytes 100
-- > , swapPartition (MegaBytes 256)
-- > ]
+--
+-- Note that the disk image file is reused if it already exists,
+-- to avoid expensive IO to generate a new one. And, it's updated in-place,
+-- so its contents are undefined during the build process.
imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
imageBuilt = imageBuilt' False
@@ -119,21 +123,21 @@ 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, t) = fitChrootSize tabletype partspec $
+ let (mnts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty $
- imageExists img (partTableSize t)
+ imageExists img (partTableSize parttable)
`before`
- partitioned YesReallyDeleteDiskContents img t
+ partitioned YesReallyDeleteDiskContents img parttable
`before`
- kpartx img (mkimg' mnts)
- mkimg' mnts devs =
+ kpartx img (mkimg' mnts parttable)
+ mkimg' mnts parttable devs =
partitionsPopulated chrootdir mnts devs
`before`
- imageFinalized final mnts devs
+ imageFinalized final mnts devs parttable
rmimg = File.notPresent img
-partitionsPopulated :: FilePath -> [MountPoint] -> [LoopDev] -> Property NoInfo
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo
partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs
where
desc = "partitions populated from " ++ chrootdir
@@ -155,6 +159,8 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m
-- Include the child mount point, but exclude its contents.
[ Include (Pattern m)
, Exclude (filesUnder m)
+ -- Preserve any lost+found directory that mkfs made
+ , Exclude (Pattern "lost+found")
]) childmnts
-- | Ensures that a disk image file of the specified size exists.
@@ -197,14 +203,14 @@ dirSizes top = go M.empty top [top]
else go (M.insertWith (+) dir sz m) dir is
subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
-getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize
+getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
-isChild :: FilePath -> MountPoint -> Bool
+isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
| otherwise = mntpt `dirContains` d
@@ -217,18 +223,16 @@ toSysDir chrootdir d = case makeRelative chrootdir d of
"." -> "/"
sysdir -> "/" ++ sysdir
--- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
-type MountPoint = Maybe FilePath
-
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).
+-- 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)
+fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
-- | Specifies a mount point and a constructor for a Partition.
--
@@ -240,7 +244,7 @@ fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3)
-- (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 = (MountPoint, PartSize -> Partition)
+type PartSpec = (Maybe MountPoint, PartSize -> Partition)
-- | Specifies a swap partition of a given size.
swapPartition :: PartSize -> PartSpec
@@ -279,7 +283,7 @@ adjustp (mp, p) f = (mp, f . p)
-- | 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] -> ([MountPoint], PartTable)
+fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], PartTable)
fitChrootSize tt l basesizes = (mounts, parttable)
where
(mounts, sizers) = unzip l
@@ -297,19 +301,25 @@ fitChrootSize tt l basesizes = (mounts, parttable)
-- in the partition tree.
type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
-imageFinalized :: Finalization -> [MountPoint] -> [LoopDev] -> Property NoInfo
-imageFinalized (_, final) mnts devs = property "disk image finalized" $
- withTmpDir "mnt" $ \top ->
- go top `finally` liftIO (unmountall top)
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized (_, final) mnts devs (PartTable _ parts) =
+ property "disk image finalized" $
+ withTmpDir "mnt" $ \top ->
+ go top `finally` liftIO (unmountall top)
where
- go mnt = do
- liftIO $ mountall mnt
- ensureProperty $ final mnt devs
+ go top = do
+ liftIO $ mountall top
+ liftIO $ writefstab top
+ ensureProperty $ final top devs
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
- orderedmntsdevs :: [(MountPoint, LoopDev)]
+ orderedmntsdevs :: [(Maybe MountPoint, LoopDev)]
orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs
+
+ swaps = map (SwapPartition . partitionLoopDev . snd) $
+ filter ((== LinuxSwap) . partFs . fst) $
+ zip parts devs
mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of
Nothing -> noop
@@ -322,6 +332,16 @@ imageFinalized (_, final) mnts devs = property "disk image finalized" $
unmountall top = do
unmountBelow top
umountLazy top
+
+ writefstab top = do
+ let fstab = top ++ "/etc/fstab"
+ old <- catchDefaultIO [] $ filter (not . unconfigured) . lines
+ <$> readFileStrict fstab
+ new <- genFstab (map (top ++) (catMaybes mnts))
+ swaps (toSysDir top)
+ writeFile fstab $ unlines $ new ++ old
+ -- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"
+ unconfigured s = "UNCONFIGURED" `isInfixOf` s
noFinalization :: Finalization
noFinalization = (doNothing, \_ _ -> doNothing)
@@ -335,6 +355,8 @@ grubBooted bios = (Grub.installed' bios, boots)
[ bindMount "/dev" (inmnt "/dev")
, mounted "proc" "proc" (inmnt "/proc")
, mounted "sysfs" "sys" (inmnt "/sys")
+ -- update the initramfs so it gets the uuid of the root partition
+ , inchroot "update-initramfs" ["-u"]
-- work around for http://bugs.debian.org/802717
, check haveosprober $ inchroot "chmod" ["-x", osprober]
, inchroot "update-grub" []
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 09016011..a08f9e3b 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -1,29 +1,159 @@
module Propellor.Property.Mount where
import Propellor.Base
+import qualified Propellor.Property.File as File
import Utility.Path
+import Data.Char
+import Data.List
+import Utility.Table
+
type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect)
type Source = String
+type MountPoint = FilePath
+
+-- | Mounts a device.
+mounted :: FsType -> Source -> MountPoint -> Property NoInfo
+mounted fs src mnt = property (mnt ++ " mounted") $
+ toResult <$> liftIO (mount fs src mnt)
+
+-- | Bind mounts the first directory so its contents also appear
+-- in the second directory.
+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]
+
+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 NoInfo
+fstabbed mnts swaps = property "fstabbed" $ do
+ fstab <- liftIO $ genFstab mnts swaps id
+ ensureProperty $
+ "/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
+ , fromMaybe "defaults" <$> getFsOptions mnt
+ , pure "0"
+ , pure (if mnt == "/" then "1" else "2")
+ ]
+ getswapcfg (SwapPartition swap) = sequence
+ [ fromMaybe swap <$> getM (\a -> a swap)
+ [ uuidprefix getSourceUUID
+ , sourceprefix getSourceLabel
+ ]
+ , pure "none"
+ , pure "swap"
+ , pure "defaults"
+ , 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
+
-- | Lists all mount points of the system.
-mountPoints :: IO [FilePath]
+mountPoints :: IO [MountPoint]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
-- | Finds all filesystems mounted inside the specified directory.
-mountPointsBelow :: FilePath -> IO [FilePath]
+mountPointsBelow :: FilePath -> IO [MountPoint]
mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
-- | Filesystem type mounted at a given location.
-getFsType :: FilePath -> IO (Maybe FsType)
-getFsType mnt = catchDefaultIO Nothing $
- headMaybe . lines
- <$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]
+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"
+
+type UUID = String
+
+-- | UUID of filesystem mounted at a given location.
+getMountUUID :: MountPoint -> IO (Maybe UUID)
+getMountUUID = findmntField "uuid"
--- | Unmounts a device, lazily so any running processes don't block it.
+-- | UUID of a device
+getSourceUUID :: Source -> IO (Maybe UUID)
+getSourceUUID = blkidTag "UUID"
+
+type Label = String
+
+-- | Label of filesystem mounted at a given location.
+getMountLabel :: MountPoint -> IO (Maybe Label)
+getMountLabel = findmntField "label"
+
+-- | Label of a device
+getSourceLabel :: Source -> IO (Maybe UUID)
+getSourceLabel = blkidTag "LABEL"
+
+-- | Device mounted at a given location.
+getMountSource :: MountPoint -> IO (Maybe Source)
+getMountSource = findmntField "source"
+
+findmntField :: String -> FilePath -> IO (Maybe String)
+findmntField field mnt = catchDefaultIO Nothing $
+ headMaybe . filter (not . null) . lines
+ <$> readProcess "findmnt" ["-n", mnt, "--output", field]
+
+blkidTag :: String -> Source -> IO (Maybe String)
+blkidTag tag dev = catchDefaultIO Nothing $
+ headMaybe . filter (not . null) . lines
+ <$> readProcess "blkid" [dev, "-s", tag, "-o", "value"]
+
+-- | Unmounts a device or mountpoint,
+-- lazily so any running processes don't block it.
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
@@ -34,17 +164,3 @@ unmountBelow :: FilePath -> IO ()
unmountBelow d = do
submnts <- mountPointsBelow d
forM_ submnts umountLazy
-
--- | Mounts a device.
-mounted :: FsType -> Source -> FilePath -> Property NoInfo
-mounted fs src mnt = property (mnt ++ " mounted") $
- toResult <$> liftIO (mount fs src mnt)
-
--- | Bind mounts the first directory so its contents also appear
--- in the second directory.
-bindMount :: FilePath -> FilePath -> Property NoInfo
-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
- `describe` ("bind mounted " ++ src ++ " to " ++ dest)
-
-mount :: FsType -> Source -> FilePath -> IO Bool
-mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index fd3c7930..d39ceea6 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -11,7 +11,7 @@ import Data.List
-- | Filesystems etc that can be used for a partition.
data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
- deriving (Show)
+ deriving (Show, Eq)
data Eep = YesReallyFormatPartition