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') 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.2.3