propellor 5.11 → 5.12

raw patch · 9 files changed

+128/−63 lines, 9 files

Files

• CHANGELOG +17/−0
• Makefile +5/−1
• debian/changelog +17/−0
• debian/control +2/−0
• propellor.cabal +2/−2
• src/Propellor/Bootstrap.hs +5/−2
• src/Propellor/PropAccum.hs +1/−1
• src/Propellor/Property/Borg.hs +62/−53
• src/Propellor/Types/MetaTypes.hs +17/−4

@@ -1,3 +1,20 @@+propellor (5.12) unstable; urgency=medium++  * Worked around a situation where ghc uses insane amounts of memory+    displaying an error message about a property of a host having the+    wrong number of arguments.+  * Added libghc-type-errors-dev to debian/control recommends, and+    install it if available when bootstrapping propellor.+  * Borg: add UseUmask to BorgRepoOpt.+    Thanks, Nicolas Schodet+  * Borg: use "{now}" instead of $(date ...)+    Thanks, Nicolas Schodet+  * Makefile: Deal with cabal change that made sdist+    not output tarball to stdout.+    Thanks, Sean Whitton++ -- Joey Hess <id@joeyh.name>  Mon, 14 Sep 2020 12:06:46 -0400+ propellor (5.11) unstable; urgency=medium    * Fix display of concurrent output from processes when using

@@ -17,7 +17,11 @@ 		install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor; \ 	fi 	mkdir -p gittmp-	$(CABAL) sdist -o - | (cd gittmp && tar zx --strip-components=1)+	if [ "$(CABAL)" = ./Setup ]; then \+		./Setup sdist --output-directory=gittmp; \+	else \+		$(CABAL) sdist -o - | (cd gittmp && tar zx --strip-components=1); \+	fi 	# cabal sdist does not preserve symlinks, so copy over file 	cd gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../$$f $$f; done 	# reset mtime on files in git bundle so bundle is reproducible

@@ -1,3 +1,20 @@+propellor (5.12) unstable; urgency=medium++  * Worked around a situation where ghc uses insane amounts of memory+    displaying an error message about a property of a host having the+    wrong number of arguments.+  * Added libghc-type-errors-dev to debian/control recommends, and+    install it if available when bootstrapping propellor.+  * Borg: add UseUmask to BorgRepoOpt.+    Thanks, Nicolas Schodet+  * Borg: use "{now}" instead of $(date ...)+    Thanks, Nicolas Schodet+  * Makefile: Deal with cabal change that made sdist+    not output tarball to stdout.+    Thanks, Sean Whitton++ -- Joey Hess <id@joeyh.name>  Mon, 14 Sep 2020 12:06:46 -0400+ propellor (5.11) unstable; urgency=medium    * Fix display of concurrent output from processes when using

@@ -18,6 +18,7 @@ 	libghc-exceptions-dev (>= 0.6), 	libghc-text-dev, 	libghc-hashable-dev,+	libghc-type-errors-dev, Maintainer: Joey Hess <id@joeyh.name> Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor@@ -42,6 +43,7 @@ 	libghc-text-dev, 	libghc-hashable-dev, 	git (>= 2.0),+Recommends: libghc-type-errors-dev, Description: property-based host configuration management in haskell  Propellor ensures that the system it's run in satisfies a list of  properties, taking action as necessary when a property is not yet met.

@@ -1,5 +1,5 @@ Name: propellor-Version: 5.11+Version: 5.12 Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -36,7 +36,7 @@  It is configured using haskell.  Flag WithTypeErrors-  Description: Build with type-errors library for better error messages+  Description: Build with type-errors library for better error messages and less memory use  Library   Default-Language: Haskell98

@@ -103,7 +103,7 @@ 	go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" 	go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" -data Dep = Dep String | OldDep String+data Dep = Dep String | OptDep String | OldDep String  -- Install build dependencies of propellor, using the specified -- Bootstrapper.@@ -139,7 +139,8 @@ 	useapt builder = "apt-get update" : map aptinstall (debdeps builder)  	aptinstall (Dep p) = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p-	aptinstall (OldDep p) = "if LANG=C apt-cache policy " ++ p ++ "| grep -q Candidate:; then " ++ aptinstall (Dep p) ++ "; fi"+	aptinstall (OptDep p) = "if LANG=C apt-cache policy " ++ p ++ "| grep -q Candidate:; then " ++ aptinstall (Dep p) ++ "; fi"+	aptinstall (OldDep p) = aptinstall (OptDep p) 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p 	pacmaninstall p = "pacman -S --noconfirm --needed " ++ p @@ -160,6 +161,8 @@ 		, Dep "libghc-exceptions-dev" 		, Dep "libghc-text-dev" 		, Dep "libghc-hashable-dev"+		-- Deps that can be skipped on old systems.+		, OptDep "libghc-type-errors-dev" 		-- Deps that are only needed on old systems. 		, OldDep "libghc-stm-dev" 		]

@@ -48,7 +48,7 @@  -- When many properties are combined, ghc error message -- can include quite a lot of code, typically starting with--- `props  and including all the properties up to and including the+-- `props` and including all the properties up to and including the -- one that fails to combine. Point the user in the right direction. type family NoteFor symbol :: ErrorMessage where 	NoteFor symbol =

@@ -20,8 +20,13 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron import Data.List (intercalate, isSuffixOf)-import Utility.SafeCommand (boolSystem')+import Data.Char (intToDigit)+import Numeric (showIntAtBase)+import Utility.SafeCommand (boolSystem', toCommand) +-- | Borg command.+type BorgCommand = String+ -- | Parameter to pass to a borg command. type BorgParam = String @@ -38,6 +43,8 @@ 	-- | Use to specify a ssh private key to use when accessing a 	-- BorgRepo. 	= UseSshKey FilePath+	-- | Use to specify a umask to use when accessing BorgRepo.+	| UseUmask FileMode 	-- | Use to specify an environment variable to set when running 	-- borg on a BorgRepo. 	| UsesEnvVar (String, String)@@ -67,29 +74,40 @@ repoLoc (BorgRepo s) = s repoLoc (BorgRepoUsing _ s) = s -runBorg :: BorgRepo -> [CommandParam] -> Maybe FilePath -> IO Bool-runBorg repo ps chdir = case runBorgEnv repo of+runBorg :: BorgRepo -> BorgCommand -> [CommandParam] -> Maybe FilePath -> IO Bool+runBorg repo cmd ps chdir = case runBorgEnv repo of 	[] -> runBorg' Nothing 	environ -> do 		environ' <- addEntries environ <$> getEnvironment 		runBorg' (Just environ')   where-	runBorg' environ = boolSystem' "borg" ps $+	runBorg' environ = boolSystem' "borg" params $ 		\p -> p { cwd = chdir, env = environ }+	params = runBorgParam repo cmd ps -readBorg :: BorgRepo -> [String] -> IO String-readBorg repo ps = case runBorgEnv repo of-	[] -> readProcess "borg" ps+readBorg :: BorgRepo -> BorgCommand -> [CommandParam] -> IO String+readBorg repo cmd ps = case runBorgEnv repo of+	[] -> readProcess "borg" params 	environ -> do 		environ' <- addEntries environ <$> getEnvironment-		readProcessEnv "borg" ps (Just environ')+		readProcessEnv "borg" params (Just environ')+  where+	params = toCommand (runBorgParam repo cmd ps) +runBorgParam :: BorgRepo -> BorgCommand -> [CommandParam] -> [CommandParam]+runBorgParam (BorgRepo _) cmd ps = Param cmd : ps+runBorgParam (BorgRepoUsing os _) cmd ps = Param cmd : (concatMap go os ++ ps)+  where+	go (UseUmask i) = [Param "--umask", Param (showIntAtBase 8 intToDigit i "")]+	go _ = []+ runBorgEnv :: BorgRepo -> [(String, String)] runBorgEnv (BorgRepo _) = []-runBorgEnv (BorgRepoUsing os _) = map go os+runBorgEnv (BorgRepoUsing os _) = mapMaybe go os   where-	go (UseSshKey k) = ("BORG_RSH", "ssh -i " ++ k)-	go (UsesEnvVar (k, v)) = (k, v)+	go (UseSshKey k) = Just ("BORG_RSH", "ssh -i " ++ k)+	go (UsesEnvVar (k, v)) = Just (k, v)+	go _ = Nothing  installed :: Property DebianLike installed = pickOS installdebian aptinstall@@ -104,19 +122,18 @@         desc = "installed borgbackup"  repoExists :: BorgRepo -> IO Bool-repoExists repo = runBorg repo [Param "list", Param (repoLoc repo)] Nothing+repoExists repo = runBorg repo "list" [Param (repoLoc repo)] Nothing  -- | Get the name of the latest archive. latestArchive :: BorgRepo -> IO (Maybe String)-latestArchive repo = getLatest <$> readBorg repo listargs+latestArchive repo = getLatest <$> readBorg repo "list" listargs   where 	getLatest = maybeLast . filter (not . isSuffixOf ".checkpoint") . lines 	maybeLast [] = Nothing 	maybeLast ps = Just $ last ps 	listargs =-		[ "list"-		, "--short"-		, repoLoc repo+		[ Param "--short"+		, Param (repoLoc repo) 		]  -- | Inits a new borg repository@@ -125,10 +142,9 @@ 	(cmdPropertyEnv "borg" initargs (runBorgEnv repo)) 		`requires` installed   where-	initargs =-		[ "init"-		, encParam enc-		, repoLoc repo+	initargs = toCommand $ runBorgParam repo "init"+		[ encParam enc+		, Param (repoLoc repo) 		]  -- | Restores a directory from a borg backup.@@ -158,10 +174,8 @@  	restore :: String -> IO Result 	restore latest = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do-		ok <- runBorg repo-			[ Param "extract"-			, Param ((repoLoc repo) ++ "::" ++ latest)-			]+		ok <- runBorg repo "extract"+			[ Param (repoLoc repo ++ "::" ++ latest) ] 			(Just tmpdir) 		let restoreddir = tmpdir ++ "/" ++ dir 		ifM (pure ok <&&> doesDirectoryExist restoreddir)@@ -217,33 +231,28 @@ 		[ k ++ "=" ++ shellEscape v 		, "export " ++ k 		]-	createCommand = unwords $-		[ "borg"-		, "create"-		, "--stats"-		]-		++ map shellEscape extraargs ++-		[ shellEscape (repoLoc repo) ++ "::" ++ "$(date --iso-8601=ns --utc)"-		, shellEscape dir-		]-	pruneCommand = unwords $-		[ "borg"-		, "prune"-		, shellEscape (repoLoc repo)+	createCommand = unwords ("borg" : createCommandParams)+	createCommandParams = map shellEscape $ toCommand $ runBorgParam repo "create" $+		[ Param "--stats" ]+		++ map Param extraargs +++		[ Param (repoLoc repo ++ "::{now}")+		, File dir 		]-		++-		map keepParam kp+	pruneCommand = unwords $ ("borg" : pruneCommandParams)+	pruneCommandParams = map shellEscape $ toCommand $ runBorgParam repo "prune" $+		[ Param (repoLoc repo) ]+		++ 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, it will run borg prune to clean out -- generations not specified here.-keepParam :: KeepPolicy -> BorgParam-keepParam (KeepHours n) = "--keep-hourly=" ++ val n-keepParam (KeepDays n) = "--keep-daily=" ++ val n-keepParam (KeepWeeks n) = "--keep-daily=" ++ val n-keepParam (KeepMonths n) = "--keep-monthly=" ++ val n-keepParam (KeepYears n) = "--keep-yearly=" ++ val n+keepParam :: KeepPolicy -> CommandParam+keepParam (KeepHours n) = Param ("--keep-hourly=" ++ val n)+keepParam (KeepDays n) = Param ("--keep-daily=" ++ val n)+keepParam (KeepWeeks n) = Param ("--keep-daily=" ++ val n)+keepParam (KeepMonths n) = Param ("--keep-monthly=" ++ val n)+keepParam (KeepYears n) = Param ("--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@@ -257,11 +266,11 @@ 	| KeepYears Int  -- | Construct the encryption type parameter.-encParam :: BorgEnc -> BorgParam-encParam BorgEncNone = "--encryption=none"-encParam BorgEncAuthenticated = "--encryption=authenticated"-encParam BorgEncAuthenticatedBlake2 = "--encryption=authenticated-blake2"-encParam BorgEncRepokey = "--encryption=repokey"-encParam BorgEncRepokeyBlake2 = "--encryption=repokey-blake2"-encParam BorgEncKeyfile = "--encryption=keyfile"-encParam BorgEncKeyfileBlake2 = "--encryption=keyfile-blake2"+encParam :: BorgEnc -> CommandParam+encParam BorgEncNone = Param "--encryption=none"+encParam BorgEncAuthenticated = Param "--encryption=authenticated"+encParam BorgEncAuthenticatedBlake2 = Param "--encryption=authenticated-blake2"+encParam BorgEncRepokey = Param "--encryption=repokey"+encParam BorgEncRepokeyBlake2 = Param "--encryption=repokey-blake2"+encParam BorgEncKeyfile = Param "--encryption=keyfile"+encParam BorgEncKeyfileBlake2 = Param "--encryption=keyfile-blake2"

@@ -169,10 +169,10 @@ 				('Just ('Text "(" ':<>: note ':<>: 'Text ")")) 			) --- Checking IfStuck is to avoid massive and useless error message leaking --- type families from this module. type family CannotCombine (list1 :: [a]) (list2 :: [a]) (note :: Maybe ErrorMessage) :: Constraint where-	CannotCombine list1 list2 note = +	-- Checking IfStuck is to avoid ugly error+	-- message leaking type families from this module.+	CannotCombine list1 list2 'Nothing =  		IfStuck list1 			(IfStuck list2 				(DelayError (CannotCombineMessage UnknownType UnknownType UnknownTypeNote))@@ -180,8 +180,21 @@ 			) 			(IfStuck list2 				(DelayError (CannotCombineMessage (PrettyPrintMetaTypes list1) UnknownType UnknownTypeNote))-				(DelayErrorFcf (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) note))+				(DelayErrorFcf (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) 'Nothing)) 			)+	-- When there's a note, don't display the MetaTypes at all.+	-- This is because the note is used when eg, combining properties+	-- in a host with (&), and in that case, it's likely that the+	-- problem resulted in the type checker getting stuck, and that+	-- displaying the MetaTypes would involve a massive error messsage.+	-- Displaying, or even checking IfStuck in that case can result in+	-- huge amounts of memory being used by ghc. So, avoid it, and let+	-- the note point the user in the right direction to fixing their+	-- mistake.+	CannotCombine list1 list2 ('Just note) = +		TypeError ('Text "Cannot combine two Properties."+			':$$: 'Text "(They may have conflicting MetaTypes, or the wrong number of arguments.)"+			':$$: note)  type family UnknownType :: ErrorMessage where 	UnknownType = 'Text "<unknown>"