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