summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-09-04 09:01:56 -0700
committerJoey Hess2015-09-04 09:01:56 -0700
commit160ea6015fa4b46f6cd35fcefd5df960a870d103 (patch)
tree9aed81c1654f19882480e040a194e142f83c91f6
parent7759d41d5371318c224ce56b45338eb3fb6a6418 (diff)
wip
-rw-r--r--src/Propellor/Property/DiskImage.hs49
-rw-r--r--src/Propellor/Property/File.hs14
2 files changed, 51 insertions, 12 deletions
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