summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-09-04 14:08:20 -0700
committerJoey Hess2015-09-04 14:08:20 -0700
commit3e6d85c7b01e1a2a6e6751ca99514bd54e184299 (patch)
treeae89c7d8de14b4b9be6264f7a34c3cac75ecad4b
parent9d546f04c640c0eb1ded6e585c99e2cd11fb1847 (diff)
propellor spin
-rw-r--r--src/Propellor/Property/DiskImage.hs73
-rw-r--r--src/Propellor/Property/Rsync.hs27
2 files changed, 40 insertions, 60 deletions
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"