From 9679e44fe7392f227c6e7245ae29c1e5666ac20c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 10:36:01 -0700 Subject: improve format --- src/Propellor/Property/DiskImage.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 5a41edd0..bb8b4b2a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -64,8 +64,10 @@ type DiskImage = FilePath -- > & Apt.installed ["linux-image-amd64"] -- > & ... -- > in imageBuilt "/srv/images/foo.img" chroot MSDOS --- > [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100 +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 100 -- > , swapPartition (MegaBytes 256) -- > ] (grubBooted PC) imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty -- cgit v1.3-2-g0d8e From 7759d41d5371318c224ce56b45338eb3fb6a6418 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 12:06:24 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 41 +++++++++++++++++++++++++++++++------ 1 file changed, 35 insertions(+), 6 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index bb8b4b2a..b77b5470 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -41,6 +41,7 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Propellor.Property.Parted import Propellor.Property.Mount +import Propellor.Property.Partition import Utility.Path import qualified Data.Map.Strict as M @@ -108,7 +109,8 @@ imageBuilt' rebuild img mkchroot tabletype partspec final = imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg where - mkimg = property (img ++ " built from " ++ chrootdir) $ do + desc = img ++ " built from " ++ chrootdir + mkimg = property desc $ do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -121,8 +123,33 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg imageExists img (partTableSize t) `before` partitioned YesReallyDeleteDiskContents img t + `before` + kpartx img (copyin mnts) rmimg = File.notPresent img + copyin mnts devs = property desc $ + mconcat $ map (uncurry copyinto) (zip mnts devs) + copyinto Nothing _ = noChange + copyinto (Just mnt) dev = liftIO $ withTmpDir "mnt" $ \tmpdir -> do + let d = chrootdir ++ mnt + bracket + (mount "auto" dev tmpdir) + (const $ umountLazy tmpdir) + $ \mounted -> if mounted + then do + ok <- allM (\i -> copy i tmpdir) + . filter (wantcopy d) + =<< dirContents d + return (toResult ok) + else return FailedChange + copy src dest = do + print ("copy", src, dest) + -- boolSystem "cp" [Param "-a", File src, File dest] + return True + -- skip copying files inside child mountpoints + wantcopy d f = not (any (`dirContains` f) (filter (isChild d . Just) mntpoints)) + mntpoints = map (chrootdir ++) $ catMaybes $ map fst partspec + -- | 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. @@ -174,11 +201,13 @@ getMountSz szm l (Just mntpt) = fmap (`reducePartSize` childsz) (M.lookup mntpt szm) where childsz = mconcat $ catMaybes $ - map (getMountSz szm l) (filter childmntpt l) - childmntpt Nothing = False - childmntpt (Just d) - | d `equalFilePath` mntpt = False - | otherwise = mntpt `dirContains` d + map (getMountSz szm l) (filter (isChild mntpt) l) + +isChild :: FilePath -> MountPoint -> Bool +isChild mntpt (Just d) + | d `equalFilePath` mntpt = False + | otherwise = mntpt `dirContains` d +isChild _ Nothing = False -- | From a location in a chroot (eg, /tmp/chroot/usr) to -- the corresponding location inside (eg, /usr). -- cgit v1.3-2-g0d8e From 160ea6015fa4b46f6cd35fcefd5df960a870d103 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Sep 2015 09:01:56 -0700 Subject: wip --- src/Propellor/Property/DiskImage.hs | 49 ++++++++++++++++++++++++++++--------- src/Propellor/Property/File.hs | 14 +++++++++++ 2 files changed, 51 insertions(+), 12 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index b77b5470..663bf822 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -131,24 +131,49 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg mconcat $ map (uncurry copyinto) (zip mnts devs) copyinto Nothing _ = noChange copyinto (Just mnt) dev = liftIO $ withTmpDir "mnt" $ \tmpdir -> do - let d = chrootdir ++ mnt + let fromdir = chrootdir ++ mnt bracket (mount "auto" dev tmpdir) (const $ umountLazy tmpdir) $ \mounted -> if mounted - then do - ok <- allM (\i -> copy i tmpdir) - . filter (wantcopy d) - =<< dirContents d - return (toResult ok) + then toResult <$> + catchBoolIO (copyRecursive tmpdir fromdir "" >> return True) else return FailedChange - copy src dest = do - print ("copy", src, dest) - -- boolSystem "cp" [Param "-a", File src, File dest] - return True - -- skip copying files inside child mountpoints - wantcopy d f = not (any (`dirContains` f) (filter (isChild d . Just) mntpoints)) + +-- Recursively copy from frombase into destbase, skipping +-- TODO When a subdirectory is a mount point, copy the directory, +-- but skip its contents. +copyRecursive :: FilePath -> FilePath -> FilePath -> IO () +copyRecursive destbase frombase = go + where + go i = do + let src = frombase i + let dest = destbase i + s <- getFileStatus src + if isDirectory s + then do + createDirectoryIfMissing True dest + mapM_ go . filter (not . dirCruft) + =<< getDirectoryContents src + else L.writeFile dest =<< L.readFile src + setFileMode dest (fileMode s) + setOwnerAndGroup dest (fileOwner s) (fileGroup s) +{- + copy src dest fromdir + | wantcopy fromdir src = do + print ("copy to" ++ fromdir, ":", src, dest) + -- boolSystem "cp" [Param "-a", File src, File dest] + return True + | wantmountpoint fromdir src = do + -- TODO mkdir dest, preserving permissions of src + return True + | otherwise = return True + -- skip copying files located inside child mountpoints + wantcopy fromdir f = not (any (`dirContains` f) (filter (isChild fromdir . Just) mntpoints)) + -- want mount points that are immediate children only + wantmountpoint fromdir f = mntpoints = map (chrootdir ++) $ catMaybes $ map fst partspec +-} -- | Ensures that a disk image file of the specified size exists. -- diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index adced166..239095c7 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -105,3 +105,17 @@ mode :: FilePath -> FileMode -> Property NoInfo mode f v = property (f ++ " mode " ++ show v) $ do liftIO $ modifyFileMode f (\_old -> v) noChange + +-- | Ensures that the second directory exists and has identical contents +-- as the first directory. +-- +-- Implemented with rsync. +-- +-- rsync -av 1/ 2/ --exclude='2/*' --delete --delete-excluded +copyDir :: FilePath -> FilePath -> Property NoInfo +copyDir src dest = copyDir' src dest [] + +-- | Like copyDir, but avoids copying anything into directories +-- in the list. Those directories are created, but will be kept empty. +copyDir' :: FilePath -> FilePath -> [FilePath] -> Property NoInfo +copyDir' src dest exclude = undefined -- cgit v1.3-2-g0d8e From 3e6d85c7b01e1a2a6e6751ca99514bd54e184299 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Sep 2015 14:08:20 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 73 +++++++++++++------------------------ src/Propellor/Property/Rsync.hs | 27 +++++++------- 2 files changed, 40 insertions(+), 60 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 663bf822..2e1ebc46 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -42,8 +42,10 @@ import qualified Propellor.Property.Apt as Apt import Propellor.Property.Parted import Propellor.Property.Mount import Propellor.Property.Partition +import Propellor.Property.Rsync import Utility.Path +import Data.List (isPrefixOf) import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L import System.Posix.Files @@ -124,56 +126,33 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg `before` partitioned YesReallyDeleteDiskContents img t `before` - kpartx img (copyin mnts) + kpartx img (partitionsPopulated chrootdir mnts) rmimg = File.notPresent img - copyin mnts devs = property desc $ - mconcat $ map (uncurry copyinto) (zip mnts devs) - copyinto Nothing _ = noChange - copyinto (Just mnt) dev = liftIO $ withTmpDir "mnt" $ \tmpdir -> do - let fromdir = chrootdir ++ mnt - bracket - (mount "auto" dev tmpdir) - (const $ umountLazy tmpdir) - $ \mounted -> if mounted - then toResult <$> - catchBoolIO (copyRecursive tmpdir fromdir "" >> return True) - else return FailedChange - --- Recursively copy from frombase into destbase, skipping --- TODO When a subdirectory is a mount point, copy the directory, --- but skip its contents. -copyRecursive :: FilePath -> FilePath -> FilePath -> IO () -copyRecursive destbase frombase = go +partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo +partitionsPopulated chrootdir mnts devs = property desc $ + mconcat $ map (uncurry go) (zip mnts devs) where - go i = do - let src = frombase i - let dest = destbase i - s <- getFileStatus src - if isDirectory s - then do - createDirectoryIfMissing True dest - mapM_ go . filter (not . dirCruft) - =<< getDirectoryContents src - else L.writeFile dest =<< L.readFile src - setFileMode dest (fileMode s) - setOwnerAndGroup dest (fileOwner s) (fileGroup s) -{- - copy src dest fromdir - | wantcopy fromdir src = do - print ("copy to" ++ fromdir, ":", src, dest) - -- boolSystem "cp" [Param "-a", File src, File dest] - return True - | wantmountpoint fromdir src = do - -- TODO mkdir dest, preserving permissions of src - return True - | otherwise = return True - -- skip copying files located inside child mountpoints - wantcopy fromdir f = not (any (`dirContains` f) (filter (isChild fromdir . Just) mntpoints)) - -- want mount points that are immediate children only - wantmountpoint fromdir f = - mntpoints = map (chrootdir ++) $ catMaybes $ map fst partspec --} + desc = "partitions populated from " ++ chrootdir + + go Nothing _ = noChange + go (Just mnt) dev = withTmpDir "mnt" $ \tmpdir -> bracket + (liftIO $ mount "auto" dev tmpdir) + (const $ liftIO $ umountLazy tmpdir) + $ \mounted -> if mounted + then ensureProperty $ + syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir + else return FailedChange + + filtersfor mnt = + let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $ + filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m) + (catMaybes mnts) + in concatMap (\m -> + -- Include the child mount point, but exclude its contents. + [ Include (Pattern m) + , Exclude (filesUnder m) + ]) childmnts -- | Ensures that a disk image file of the specified size exists. -- diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs index 064d129f..809cfc22 100644 --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -9,9 +9,16 @@ type Dest = FilePath class RsyncParam p where toRsync :: p -> String --- | Rsync checks each name to be transferred against its list of Filter --- rules, and the first matching one is acted on. If no matching rule --- is found, the file is processed. +-- | A pattern that matches all files under a directory, but does not +-- match the directory itself. +filesUnder :: FilePath -> Pattern +filesUnder d = Pattern (d ++ "/*") + +-- | Ensures that the Dest directory exists and has identical contents as +-- the Src directory. +syncDir :: Src -> Dest -> Property NoInfo +syncDir = syncDirFiltered [] + data Filter = Include Pattern | Exclude Pattern @@ -28,18 +35,12 @@ instance RsyncParam Filter where -- directory, relative to the 'Src' that rsync is acting on. newtype Pattern = Pattern String --- | A pattern that matches all files under a directory, but does not --- match the directory itself. -filesUnder :: FilePath -> Pattern -filesUnder d = Pattern (d ++ "/*") - --- | Ensures that the Dest directory exists and has identical contents as --- the Src directory. -syncDir :: Src -> Dest -> Property NoInfo -syncDir = syncDirFiltered [] - -- | Like syncDir, but avoids copying anything that the filter list -- excludes. Anything that's filtered out will be deleted from Dest. +-- +-- Rsync checks each name to be transferred against its list of Filter +-- rules, and the first matching one is acted on. If no matching rule +-- is found, the file is processed. syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo syncDirFiltered filters src dest = rsync $ [ "-av" -- cgit v1.3-2-g0d8e From 555c82f69eaa929ac5aef9e277a488e9d38ea626 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Sep 2015 14:20:13 -0700 Subject: fudge factor for partition sizes --- src/Propellor/Property/DiskImage.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 2e1ebc46..3cd4b46a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -118,7 +118,7 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) - let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts + let calcsz = \mnts -> maybe defSz fudge . getMountSz szm mnts -- tie the knot! let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts) ensureProperty $ @@ -194,11 +194,6 @@ 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 --- | Gets the size to allocate for a particular mount point, given the --- map of sizes. --- --- A list of all mount points is provided, so that when eg calculating --- the size for /, if /boot is a mount point, its size can be subtracted. getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize getMountSz _ _ Nothing = Nothing getMountSz szm l (Just mntpt) = @@ -226,11 +221,14 @@ type MountPoint = Maybe FilePath defSz :: PartSize defSz = MegaBytes 128 +fudge :: PartSize -> PartSize +fudge (MegaBytes n) = MegaBytes (n + n `div` 10) + -- | Specifies a mount point 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. +-- 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 -- cgit v1.3-2-g0d8e From 265576507f11b887dd0f1094e29bc52e234d79d2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Sep 2015 14:26:19 -0700 Subject: update docs --- src/Propellor/Property/DiskImage.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 3cd4b46a..d7fd6a04 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -228,7 +228,8 @@ fudge (MegaBytes n) = MegaBytes (n + n `div` 10) -- -- 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. +-- mounted. Plus a 10% 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 -- cgit v1.3-2-g0d8e From c796ff513c71783ace1c3265bb63bc12e7e7a366 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Sep 2015 15:04:07 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'src/Propellor/Property/DiskImage.hs') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index d7fd6a04..7a3460cb 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -1,6 +1,10 @@ -- | Disk image generation. -- -- This module is designed to be imported unqualified. +-- +-- TODO run final +-- +-- TODO avoid starting services while populating chroot and running final module Propellor.Property.DiskImage ( -- * Properties @@ -105,9 +109,6 @@ imageBuilt' rebuild img mkchroot tabletype partspec final = -- | Builds a disk image from the contents of a chroot. -- -- The passed property is run inside the mounted disk image. --- --- TODO copy in --- TODO run final imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg where @@ -221,14 +222,18 @@ 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). fudge :: PartSize -> PartSize -fudge (MegaBytes n) = MegaBytes (n + n `div` 10) +fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3) -- | Specifies a mount point 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 10% fudge factor, since filesystems have some space +-- mounted. Plus a fudge factor, since filesystems have some space -- overhead. -- -- (Partitions that are not to be mounted (ie, LinuxSwap), or that have -- cgit v1.3-2-g0d8e