From 9d546f04c640c0eb1ded6e585c99e2cd11fb1847 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 4 Sep 2015 10:38:36 -0700
Subject: Added Propellor.Property.Rsync.

---
 src/Propellor/Property/Rsync.hs | 58 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)
 create mode 100644 src/Propellor/Property/Rsync.hs

(limited to 'src/Propellor/Property/Rsync.hs')

diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
new file mode 100644
index 00000000..064d129f
--- /dev/null
+++ b/src/Propellor/Property/Rsync.hs
@@ -0,0 +1,58 @@
+module Propellor.Property.Rsync where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+
+type Src = FilePath
+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.
+data Filter 
+	= Include Pattern
+	| Exclude Pattern
+
+instance RsyncParam Filter where
+	toRsync (Include (Pattern p)) = "--include=" ++ p
+	toRsync (Exclude (Pattern p)) = "--exclude=" ++ p
+
+-- | A pattern to match against files that rsync is going to transfer.
+--
+-- See "INCLUDE/EXCLUDE PATTERN RULES" in the rsync(1) man page.
+--
+-- For example, Pattern "/foo/*" matches all files under the "foo"
+-- 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.
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo
+syncDirFiltered filters src dest = rsync $
+	[ "-av"
+	-- Add trailing '/' to get rsync to sync the Dest directory,
+	-- rather than a subdir inside it, which it will do without a
+	-- trailing '/'.
+	, addTrailingPathSeparator src
+	, addTrailingPathSeparator dest
+	, "--delete"
+	, "--delete-exluded"
+	, "--quiet"
+	] ++ map toRsync filters
+
+rsync :: [String] -> Property NoInfo
+rsync ps = cmdProperty "rsync" ps
+	`requires` Apt.installed ["rsync"]
-- 
cgit v1.3-2-g0d8e


From 3e6d85c7b01e1a2a6e6751ca99514bd54e184299 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
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/Rsync.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 6db275cc18a24bf9bf3bf2a173aa2ce56974d86c Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 4 Sep 2015 14:10:23 -0700
Subject: propellor spin

---
 src/Propellor/Property/Rsync.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/Propellor/Property/Rsync.hs')

diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 809cfc22..8423eff6 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -50,7 +50,7 @@ syncDirFiltered filters src dest = rsync $
 	, addTrailingPathSeparator src
 	, addTrailingPathSeparator dest
 	, "--delete"
-	, "--delete-exluded"
+	, "--delete-excluded"
 	, "--quiet"
 	] ++ map toRsync filters
 
-- 
cgit v1.3-2-g0d8e