propellor 3.0.3 → 3.0.4

raw patch · 20 files changed

+241/−22 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +11/−0
• debian/changelog +11/−0
• debian/control +1/−1
• propellor.cabal +4/−2
• src/Propellor/Base.hs +2/−2
• src/Propellor/PropAccum.hs +0/−6
• src/Propellor/Property/Attic.hs +2/−0
• src/Propellor/Property/Borg.hs +155/−0
• src/Propellor/Property/LetsEncrypt.hs +5/−1
• src/Propellor/Property/Obnam.hs +2/−0
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +2/−0
• src/Propellor/Types/ZFS.hs +1/−0
• src/Utility/Directory.hs +3/−3
• src/Utility/Exception.hs +5/−1
• src/Utility/FileMode.hs +2/−1
• src/Utility/FileSystemEncoding.hs +8/−0
• src/Utility/PosixFiles.hs +9/−1
• src/Utility/SystemDirectory.hs +16/−0
• src/Utility/Tmp.hs +1/−1
• src/Utility/UserInfo.hs +1/−3

@@ -1,3 +1,14 @@+propellor (3.0.4) unstable; urgency=medium++  * Run letsencrypt with --noninteractive.+  * Fix build with ghc 8.0.1.+    Thanks, davean.+  * Module added for the Borg backup system.+    Thanks, Félix Sipma.+  * Fix build with directory-1.2.6.2.++ -- Joey Hess <id@joeyh.name>  Sun, 22 May 2016 15:54:49 -0400+ propellor (3.0.3) unstable; urgency=medium    * Remove Propellor.DotDir from the propellor library, as its use of

@@ -1,3 +1,14 @@+propellor (3.0.4) unstable; urgency=medium++  * Run letsencrypt with --noninteractive.+  * Fix build with ghc 8.0.1.+    Thanks, davean.+  * Module added for the Borg backup system.+    Thanks, Félix Sipma.+  * Fix build with directory-1.2.6.2.++ -- Joey Hess <id@joeyh.name>  Sun, 22 May 2016 15:54:49 -0400+ propellor (3.0.3) unstable; urgency=medium    * Remove Propellor.DotDir from the propellor library, as its use of

@@ -20,7 +20,7 @@ 	libghc-text-dev, 	libghc-concurrent-output-dev, Maintainer: Joey Hess <id@joeyh.name>-Standards-Version: 3.9.6+Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/ 

@@ -1,7 +1,7 @@ Name: propellor-Version: 3.0.3+Version: 3.0.4 Cabal-Version: >= 1.8-License: BSD3+License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable@@ -81,6 +81,7 @@     Propellor.Property.Apt     Propellor.Property.Apt.PPA     Propellor.Property.Attic+    Propellor.Property.Borg     Propellor.Property.Cmd     Propellor.Property.Concurrent     Propellor.Property.Conductor@@ -206,6 +207,7 @@     Utility.Process.NonConcurrent     Utility.SafeCommand     Utility.Scheduled+    Utility.SystemDirectory     Utility.Table     Utility.ThreadScheduler     Utility.Tmp

@@ -20,7 +20,7 @@ 	, module Propellor.Utilities  	-- * System modules-	, module System.Directory+	, module Utility.SystemDirectory 	, module System.IO 	, module System.FilePath 	, module Data.Maybe@@ -47,7 +47,7 @@ import Propellor.Location import Propellor.Utilities -import System.Directory+import Utility.SystemDirectory import System.IO import System.FilePath import Data.Maybe

@@ -78,9 +78,3 @@ 	-> RevertableProperty (MetaTypes y) (MetaTypes z) 	-> Props (MetaTypes (Combine x z)) Props c ! p = Props (c ++ [toChildProperty (revert p)])---- addPropsHost :: Host -> [Prop] -> Host--- addPropsHost (Host hn ps i) p = Host hn ps' i'---   where--- 	ps' = ps ++ [toChildProperty p]--- 	i' = i <> getInfoRecursive p

@@ -1,4 +1,6 @@ -- | Maintainer: Félix Sipma <felix+propellor@gueux.org>+--+-- Support for the Attic backup tool <https://attic-backup.org/>  module Propellor.Property.Attic 	( installed

@@ -0,0 +1,155 @@+-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>+--+-- Support for the Borg backup tool <https://github.com/borgbackup>++module Propellor.Property.Borg+	( 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 Data.List (intercalate)++type BorgParam = String++type BorgRepo = FilePath++installed :: Property DebianLike+installed = withOS desc $ \w o -> case o of+	(Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $+		Apt.installedBackport ["borgbackup"]+	_ -> ensureProperty w $+		Apt.installed ["borgbackup"]+  where+        desc = "installed borgbackup"++repoExists :: BorgRepo -> IO Bool+repoExists repo = boolSystem "borg" [Param "list", File repo]++-- | Inits a new borg repository+init :: BorgRepo -> Property DebianLike+init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs)+	`requires` installed+  where+	initargs =+		[ "init"+		, backupdir+		]++-- | Restores a directory from an borg 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 -> BorgRepo -> Property DebianLike+restored dir backupdir = go `requires` installed+  where+	go :: Property DebianLike+	go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore)+		( do+			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."+			liftIO restore+		, noChange+		)++	needsRestore = null <$> catchDefaultIO [] (dirContents dir)++	restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do+		ok <- boolSystem "borg" $+			[ Param "extract"+			, Param backupdir+			, Param 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 borg 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:+--+-- >	& Borg.backup "/srv/git" "root@myserver:/mnt/backup/git.borg" Cron.Daily+-- >		["--exclude=/srv/git/tobeignored"]+-- >		[Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1]+--+-- Note that this property does not make borg encrypt the backup+-- repository.+--+-- Since borg uses a fair amount of system resources, only one borg+-- backup job will be run at a time. Other jobs will wait their turns to+-- run.+backup :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike+backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp+	`requires` restored dir backupdir++-- | Does a backup, but does not automatically restore.+backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike+backup' dir backupdir crontimes extraargs kp = cronjob+	`describe` desc+	`requires` installed+  where+	desc = backupdir ++ " borg backup"+	cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $+		"flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd+	lockfile = "/var/lock/propellor-borg.lock"+	backupcmd = intercalate ";" $+		createCommand+		: if null kp then [] else [pruneCommand]+	createCommand = unwords $+		[ "borg"+		, "create"+		, "--stats"+		]+		++ map shellEscape extraargs +++		[ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)"+		, shellEscape dir+		]+	pruneCommand = unwords $+		[ "borg"+		, "prune"+		, shellEscape backupdir+		]+		+++		map keepParam kp++-- | Constructs an BorgParam 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 borg prune to clean out+-- generations not specified here.+keepParam :: KeepPolicy -> BorgParam+keepParam (KeepHours n) = "--keep-hourly=" ++ show n+keepParam (KeepDays n) = "--keep-daily=" ++ show n+keepParam (KeepWeeks n) = "--keep-daily=" ++ show n+keepParam (KeepMonths n) = "--keep-monthly=" ++ show n+keepParam (KeepYears n) = "--keep-yearly=" ++ show 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 borg's man page for details.+data KeepPolicy+	= KeepHours Int+	| KeepDays Int+	| KeepWeeks Int+	| KeepMonths Int+	| KeepYears Int

@@ -1,4 +1,5 @@--- | This module uses the letsencrypt reference client.+-- | This module gets LetsEncrypt <https://letsencrypt.org/> certificates +-- using CertBot <https://certbot.eff.org/>  module Propellor.Property.LetsEncrypt where @@ -7,6 +8,8 @@  import System.Posix.Files +-- Not using the certbot name yet, until it reaches jessie-backports and+-- testing. installed :: Property DebianLike installed = Apt.installed ["letsencrypt"] @@ -74,6 +77,7 @@ 		, "--webroot" 		, "--webroot-path", webroot 		, "--text"+		, "--noninteractive" 		, "--keep-until-expiring" 		] ++ map (\d -> "--domain="++d) alldomains 

@@ -1,3 +1,5 @@+-- | Support for the Obnam backup tool <http://obnam.org/>+ module Propellor.Property.Obnam where  import Propellor.Base

@@ -135,6 +135,8 @@ 		& User.accountFor (User builduser) 		& tree arch flavor 		& stackInstalled+		-- Workaround https://github.com/commercialhaskell/stack/issues/2093+		& Apt.installed ["libtinfo-dev"]  stackInstalled :: Property Linux stackInstalled = withOS "stack installed" $ \w o ->

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstrainedClassMethods #-} -- | Types for ZFS Properties. -- -- Copyright 2016 Evan Cofsky <evan@theunixman.com>

@@ -6,15 +6,14 @@  -}  {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-tabs -w #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Directory ( 	module Utility.Directory,-	module System.Directory+	module Utility.SystemDirectory ) where  import System.IO.Error-import System.Directory hiding (isSymbolicLink) import Control.Monad import System.FilePath import Control.Applicative@@ -31,6 +30,7 @@ import Control.Monad.IfElse #endif +import Utility.SystemDirectory import Utility.PosixFiles import Utility.Tmp import Utility.Exception

@@ -21,7 +21,8 @@ 	tryNonAsync, 	tryWhenExists, 	catchIOErrorType,-	IOErrorType(..)+	IOErrorType(..),+	catchPermissionDenied, ) where  import Control.Monad.Catch as X hiding (Handler)@@ -97,3 +98,6 @@ 	onlymatching e 		| ioeGetErrorType e == errtype = onmatchingerr e 		| otherwise = throwM e++catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a+catchPermissionDenied = catchIOErrorType PermissionDenied

@@ -18,9 +18,10 @@ import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files+import Control.Monad.IO.Class (liftIO) #endif+import Control.Monad.IO.Class (MonadIO) import Foreign (complement)-import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch  import Utility.Exception

@@ -19,6 +19,7 @@ 	encodeW8NUL, 	decodeW8NUL, 	truncateFilePath,+	setConsoleEncoding, ) where  import qualified GHC.Foreign as GHC@@ -164,3 +165,10 @@ 					else go (c:coll) (cnt - x') (L8.drop 1 bs) 			_ -> coll #endif++{- This avoids ghc's output layer crashing on invalid encoded characters in+ - filenames when printing them out. -}+setConsoleEncoding :: IO ()+setConsoleEncoding = do+	fileEncoding stdout+	fileEncoding stderr

@@ -1,6 +1,6 @@ {- POSIX files (and compatablity wrappers).  -- - This is like System.PosixCompat.Files, except with a fixed rename.+ - This is like System.PosixCompat.Files, but with a few fixes.  -  - Copyright 2014 Joey Hess <id@joeyh.name>  -@@ -21,6 +21,7 @@ import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32+import qualified System.Win32.HardLink as Win32 #endif  {- System.PosixCompat.Files.rename on Windows calls renameFile,@@ -31,4 +32,11 @@ #ifdef mingw32_HOST_OS rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING+#endif++{- System.PosixCompat.Files.createLink throws an error, but windows+ - does support hard links. -}+#ifdef mingw32_HOST_OS+createLink :: FilePath -> FilePath -> IO ()+createLink = Win32.createHardLink #endif

@@ -0,0 +1,16 @@+{- System.Directory without its conflicting isSymbolicLink+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++-- Disable warnings because only some versions of System.Directory export+-- isSymbolicLink.+{-# OPTIONS_GHC -fno-warn-tabs -w #-}++module Utility.SystemDirectory (+	module System.Directory+) where++import System.Directory hiding (isSymbolicLink)

@@ -11,9 +11,9 @@ module Utility.Tmp where  import System.IO-import System.Directory import Control.Monad.IfElse import System.FilePath+import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp)

@@ -17,9 +17,7 @@ import Utility.Env  import System.PosixCompat-#ifndef mingw32_HOST_OS import Control.Applicative-#endif import Prelude  {- Current user's home directory.@@ -58,6 +56,6 @@ #ifndef mingw32_HOST_OS 	go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) #else-	go [] = error $ "environment not set: " ++ show envvars+	go [] = extract <$> error ("environment not set: " ++ show envvars) #endif 	go (v:vs) = maybe (go vs) return =<< getEnv v