Merge branch 'master' into joeyconfig

3 files changed, 286 insertions, 66 deletions

diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
index 5f64fd69..5678a865 100644
--- a/src/Propellor/Property/Bootstrap.hs
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -5,12 +5,14 @@ import Propellor.Bootstrap
 import Propellor.Property.Chroot
 
 import Data.List
-import System.Posix.Directory
+import qualified Data.ByteString as B
 
 -- | Where a propellor repository should be bootstrapped from.
 data RepoSource
 	= GitRepoUrl String
 	| GitRepoOutsideChroot
+	-- ^ When used in a chroot, this copies the git repository from
+	-- outside the chroot, including its configuration.
 
 -- | Bootstraps a propellor installation into
 -- /usr/local/propellor/
@@ -38,81 +40,64 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource
 
 -- | Clones the propellor repeository into /usr/local/propellor/
 --
--- GitRepoOutsideChroot can be used when this is used in a chroot.
--- In that case, it clones the /usr/local/propellor/ from outside the
--- chroot into the same path inside the chroot.
---
 -- If the propellor repo has already been cloned, pulls to get it
 -- up-to-date.
 clonedFrom :: RepoSource -> Property Linux
-clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ do
-	ifM needclone
-		( do
-			let tmpclone = localdir ++ ".tmpclone"
-			system <- getOS
-			assumeChange $ exposeTrueLocaldir $ \sysdir -> do
-				let originloc = case reposource of
-					GitRepoUrl s -> s
-					GitRepoOutsideChroot -> sysdir
-				runShellCommand $ buildShellCommand
-					[ installGitCommand system
-					, "rm -rf " ++ tmpclone
-					, "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
-					, "mkdir -p " ++ localdir
-						-- This is done rather than deleting
-					-- the old localdir, because if it is bound
-					-- mounted from outside the chroot, deleting
-					-- it after unmounting in unshare will remove
-					-- the bind mount outside the unshare.
-					, "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
-					, "rm -rf " ++ tmpclone
-					]
-		, assumeChange $ exposeTrueLocaldir $ const $
+clonedFrom reposource = case reposource of
+	GitRepoOutsideChroot -> go `onChange` copygitconfig
+	_ -> go
+  where
+	go :: Property Linux
+	go = property ("Propellor repo cloned from " ++ sourcedesc) $
+		ifM needclone (makeclone, updateclone)
+	
+	makeclone = do
+		let tmpclone = localdir ++ ".tmpclone"
+		system <- getOS
+		assumeChange $ exposeTrueLocaldir $ \sysdir -> do
+			let originloc = case reposource of
+				GitRepoUrl s -> s
+				GitRepoOutsideChroot -> sysdir
 			runShellCommand $ buildShellCommand
-				[ "cd " ++ localdir
-				, "git pull"
+				[ installGitCommand system
+				, "rm -rf " ++ tmpclone
+				, "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
+				, "mkdir -p " ++ localdir
+				-- This is done rather than deleting
+				-- the old localdir, because if it is bound
+				-- mounted from outside the chroot, deleting
+				-- it after unmounting in unshare will remove
+				-- the bind mount outside the unshare.
+				, "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
+				, "rm -rf " ++ tmpclone
 				]
-		)
-  where
+	
+	updateclone = assumeChange $ exposeTrueLocaldir $ const $
+		runShellCommand $ buildShellCommand
+			[ "cd " ++ localdir
+			, "git pull"
+			]
+	
+	-- Copy the git config of the repo outside the chroot into the
+	-- chroot. This way it has the same remote urls, and other git
+	-- configuration.
+	copygitconfig :: Property Linux
+	copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
+		let gitconfig = localdir <> ".git" <> "config"
+		cfg <- liftIO $ B.readFile gitconfig
+		exposeTrueLocaldir $ const $
+			liftIO $ B.writeFile gitconfig cfg
+		return MadeChange
+
 	needclone = (inChroot <&&> truelocaldirisempty)
 		<||> (liftIO (not <$> doesDirectoryExist localdir))
+	
 	truelocaldirisempty = exposeTrueLocaldir $ const $
 		runShellCommand ("test ! -d " ++ localdir ++ "/.git")
+
 	sourcedesc = case reposource of
 		GitRepoUrl s -> s
-		GitRepoOutsideChroot -> localdir
-
--- | Runs an action with the true localdir exposed,
--- not the one bind-mounted into a chroot. The action is passed the
--- path containing the contents of the localdir outside the chroot.
---
--- In a chroot, this is accomplished by temporily bind mounting the localdir
--- to a temp directory, to preserve access to the original bind mount. Then
--- we unmount the localdir to expose the true localdir. Finally, to cleanup,
--- the temp directory is bind mounted back to the localdir.
-exposeTrueLocaldir :: (FilePath -> IO a) -> Propellor a
-exposeTrueLocaldir a = ifM inChroot
-	( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
-		bracket_
-			(movebindmount localdir tmpdir)
-			(movebindmount tmpdir localdir)
-			(a tmpdir)
-	, liftIO $ a localdir
-	)
-  where
-	movebindmount from to = do
-		run "mount" [Param "--bind", File from, File to]
-		-- Have to lazy unmount, because the propellor process
-		-- is running in the localdir that it's unmounting..
-		run "umount" [Param "-l", File from]
-		-- We were in the old localdir; move to the new one after
-		-- flipping the bind mounts. Otherwise, commands that try
-		-- to access the cwd will fail because it got umounted out
-		-- from under.
-		changeWorkingDirectory "/"
-		changeWorkingDirectory localdir
-	run cmd ps = unlessM (boolSystem cmd ps) $
-		error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
+		GitRepoOutsideChroot -> localdir ++ " outside the chroot"
 
 assumeChange :: Propellor Bool -> Propellor Result
 assumeChange a = do
@@ -122,5 +107,5 @@ assumeChange a = do
 buildShellCommand :: [String] -> String
 buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
 
-runShellCommand :: String -> IO Bool
+runShellCommand :: String -> Propellor Bool
 runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 01cd4d3e..ad2ae705 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -11,6 +11,7 @@ module Propellor.Property.Chroot (
 	ChrootTarball(..),
 	noServices,
 	inChroot,
+	exposeTrueLocaldir,
 	-- * Internal use
 	provisioned',
 	propagateChrootInfo,
@@ -295,6 +296,38 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) }
 newtype InChroot = InChroot Bool
 	deriving (Typeable, Show)
 
+-- | Runs an action with the true localdir exposed,
+-- not the one bind-mounted into a chroot. The action is passed the
+-- path containing the contents of the localdir outside the chroot.
+--
+-- In a chroot, this is accomplished by temporily bind mounting the localdir
+-- to a temp directory, to preserve access to the original bind mount. Then
+-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
+-- the temp directory is bind mounted back to the localdir.
+exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a
+exposeTrueLocaldir a = ifM inChroot
+	( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
+		bracket_
+			(movebindmount localdir tmpdir)
+			(movebindmount tmpdir localdir)
+			(a tmpdir)
+	, a localdir
+	)
+  where
+	movebindmount from to = liftIO $ do
+		run "mount" [Param "--bind", File from, File to]
+		-- Have to lazy unmount, because the propellor process
+		-- is running in the localdir that it's unmounting..
+		run "umount" [Param "-l", File from]
+		-- We were in the old localdir; move to the new one after
+		-- flipping the bind mounts. Otherwise, commands that try
+		-- to access the cwd will fail because it got umounted out
+		-- from under.
+		changeWorkingDirectory "/"
+		changeWorkingDirectory localdir
+	run cmd ps = unlessM (boolSystem cmd ps) $
+		error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
+
 -- | Generates a Chroot that has all the properties of a Host.
 -- 
 -- Note that it's possible to create loops using this, where a host
diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs
new file mode 100644
index 00000000..64cd4091
--- /dev/null
+++ b/src/Propellor/Property/Restic.hs
@@ -0,0 +1,202 @@
+-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
+--
+-- Support for the restic backup tool <https://github.com/restic/restic>
+
+module Propellor.Property.Restic
+	( ResticRepo (..)
+	, installed
+	, repoExists
+	, init
+	, restored
+	, backup
+	, KeepPolicy (..)
+	) where
+
+import Propellor.Base hiding (init)
+import Prelude hiding (init)
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Cron as Cron
+import qualified Propellor.Property.File as File
+import Data.List (intercalate)
+
+type Url = String
+
+type ResticParam = String
+
+data ResticRepo
+	= Direct FilePath
+	| SFTP User HostName FilePath
+	| REST Url
+
+instance ConfigurableValue ResticRepo where
+	val (Direct fp) = fp
+	val (SFTP u h fp) = "sftp:" ++ val u ++ "@" ++ val h ++ ":" ++ fp
+	val (REST url) = "rest:" ++ url
+
+installed :: Property DebianLike
+installed = withOS desc $ \w o -> case o of
+	(Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
+		Apt.installedBackport ["restic"]
+	_ -> ensureProperty w $
+		Apt.installed ["restic"]
+  where
+	desc = "installed restic"
+
+repoExists :: ResticRepo -> IO Bool
+repoExists repo = boolSystem "restic"
+	[ Param "-r"
+	, File (val repo)
+	, Param "--password-file"
+	, File (getPasswordFile repo)
+	, Param "snapshots"
+	]
+
+passwordFileDir :: FilePath
+passwordFileDir = "/etc/restic-keys"
+
+getPasswordFile :: ResticRepo -> FilePath
+getPasswordFile repo = passwordFileDir </> File.configFileName (val repo)
+
+passwordFileConfigured :: ResticRepo -> Property (HasInfo + UnixLike)
+passwordFileConfigured repo = propertyList "restic password file" $ props
+	& File.dirExists passwordFileDir
+	& File.mode passwordFileDir 0O2700
+	& getPasswordFile repo `File.hasPrivContent` hostContext
+
+-- | Inits a new restic repository
+init :: ResticRepo -> Property (HasInfo + DebianLike)
+init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs)
+	`requires` installed
+	`requires` passwordFileConfigured repo
+  where
+	initargs =
+		[ "-r"
+		, val repo
+		, "--password-file"
+		, getPasswordFile repo
+		, "init"
+		]
+
+-- | Restores a directory from a restic backup.
+--
+-- Only does anything if the directory does not exist, or exists,
+-- but is completely empty.
+--
+-- The restore is performed atomically; restoring to a temp directory
+-- and then moving it to the directory.
+restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike)
+restored dir repo = go
+	`requires` init repo
+  where
+	go :: Property DebianLike
+	go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore)
+		( do
+			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
+			liftIO restore
+		, noChange
+		)
+
+	needsRestore = null <$> catchDefaultIO [] (dirContents dir)
+
+	restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do
+		ok <- boolSystem "restic"
+			[ Param "-r"
+			, File (val repo)
+			, Param "--password-file"
+			, File (getPasswordFile repo)
+			, Param "restore"
+			, Param "latest"
+			, Param "--target"
+			, File tmpdir
+			]
+		let restoreddir = tmpdir ++ "/" ++ dir
+		ifM (pure ok <&&> doesDirectoryExist restoreddir)
+			( do
+				void $ tryIO $ removeDirectory dir
+				renameDirectory restoreddir dir
+				return MadeChange
+			, return FailedChange
+			)
+
+-- | Installs a cron job that causes a given directory to be backed
+-- up, by running restic with some parameters.
+--
+-- If the directory does not exist, or exists but is completely empty,
+-- this Property will immediately restore it from an existing backup.
+--
+-- So, this property can be used to deploy a directory of content
+-- to a host, while also ensuring any changes made to it get backed up.
+-- For example:
+--
+-- >	& Restic.backup "/srv/git"
+-- >		(Restic.SFTP (User root) (HostName myserver) /mnt/backup/git.restic")
+-- >		Cron.Daily
+-- >		["--exclude=/srv/git/tobeignored"]
+-- >		[Restic.KeepDays 7, Restic.KeepWeeks 4, Restic.KeepMonths 6, Restic.KeepYears 1]
+--
+-- Since restic uses a fair amount of system resources, only one restic
+-- backup job will be run at a time. Other jobs will wait their turns to
+-- run.
+backup :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike)
+backup dir repo crontimes extraargs kp = backup' dir repo crontimes extraargs kp
+	`requires` restored dir repo
+
+-- | Does a backup, but does not automatically restore.
+backup' :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike)
+backup' dir repo crontimes extraargs kp = cronjob
+	`describe` desc
+	`requires` init repo
+  where
+	desc = val repo ++ " restic backup"
+	cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $
+		"flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd
+	lockfile = "/var/lock/propellor-restic.lock"
+	backupcmd = intercalate " && " $
+		createCommand
+		: if null kp then [] else [pruneCommand]
+	createCommand = unwords $
+		[ "restic"
+		, "-r"
+		, shellEscape (val repo)
+		, "--password-file"
+		, shellEscape (getPasswordFile repo)
+		]
+		++ map shellEscape extraargs ++
+		[ "backup"
+		, shellEscape dir
+		]
+	pruneCommand = unwords $
+		[ "restic"
+		, "-r"
+		, shellEscape (val repo)
+		, "--password-file"
+		, shellEscape (getPasswordFile repo)
+		, "forget"
+		, "--prune"
+		]
+		++
+		map keepParam kp
+
+-- | Constructs a ResticParam that specifies which old backup generations to
+-- keep. By default, all generations are kept. However, when this parameter is
+-- passed to the `backup` property, they will run restic prune to clean out
+-- generations not specified here.
+keepParam :: KeepPolicy -> ResticParam
+keepParam (KeepLast n) = "--keep-last=" ++ val n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-weekly=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
+
+-- | Policy for backup generations to keep. For example, KeepDays 30 will
+-- keep the latest backup for each day when a backup was made, and keep the
+-- last 30 such backups. When multiple KeepPolicies are combined together,
+-- backups meeting any policy are kept. See restic's man page for details.
+data KeepPolicy
+	= KeepLast Int
+	| KeepHours Int
+	| KeepDays Int
+	| KeepWeeks Int
+	| KeepMonths Int
+	| KeepYears Int