propellor 5.10.2 → 5.11

raw patch · 11 files changed

+188/−57 lines, 11 files

Files

• CHANGELOG +16/−0
• Makefile +22/−13
• debian/changelog +16/−0
• propellor.cabal +1/−1
• src/Propellor/Bootstrap.hs +19/−15
• src/Propellor/Property/Borg.hs +77/−14
• src/Propellor/Property/DiskImage/PartSpec.hs +0/−1
• src/Propellor/Property/SiteSpecific/JoeySites.hs +34/−10
• src/Propellor/Types/Dns.hs +1/−1
• src/Propellor/Wrapper.hs +0/−1
• src/Utility/Process/Shim.hs +2/−1

@@ -1,3 +1,19 @@+propellor (5.11) unstable; urgency=medium++  * Fix display of concurrent output from processes when using+    Propellor.Property.Conductor.+    (Reversion introduced in version 5.5.0.)+  * Support bootstrapping to hosts using cabal 3.x, with new-dist directory.+  * Makefile: Fix build with cabal 3.x.+  * Borg.restored: Fix restoration, which has apparently never worked,+    at least back to borg 1.0.9.+    Thanks, Nicolas Schodet.+  * Borg.init: Added the now required encryption type parameter.+    Thanks, Nicolas Schodet.+    (API change)++ -- Joey Hess <id@joeyh.name>  Fri, 14 Aug 2020 16:02:14 -0400+ propellor (5.10.2) unstable; urgency=medium    * Fix build with ghc 8.6.3.

@@ -1,35 +1,43 @@ CABAL?=cabal DATE := $(shell dpkg-parsechangelog 2>/dev/null | grep Date | cut -d " " -f2-) -build: tags propellor.1 dist/setup-config+build: tags propellor.1 configured 	$(CABAL) build-	ln -sf dist/build/propellor-config/propellor-config propellor+	@if [ -d dist-newstyle ]; then \+		ln -sf $$(cabal exec -- sh -c 'command -v propellor-config') propellor; \+	else \+		ln -sf dist/build/propellor-config/propellor-config propellor; \+	fi  install: 	install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor-	install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor-	mkdir -p dist/gittmp-	$(CABAL) sdist-	cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1)+	if [ -d dist-newstyle ]; then \+		install -s $$(cabal exec -- sh -c 'command -v propellor') $(DESTDIR)/usr/bin/propellor; \+	else \+		install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor; \+	fi+	mkdir -p gittmp+	$(CABAL) sdist -o - | (cd gittmp && tar zx --strip-components=1) 	# cabal sdist does not preserve symlinks, so copy over file-	cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done+	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-	find dist/gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)"+	find gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)" 	export GIT_AUTHOR_NAME=build \ 	&& export GIT_AUTHOR_EMAIL=build@buildhost \ 	&& export GIT_AUTHOR_DATE="$(DATE)" \ 	&& export GIT_COMMITTER_NAME=build \ 	&& export GIT_COMMITTER_EMAIL=build@buildhost \ 	&& export GIT_COMMITTER_DATE="$(DATE)" \-	&& cd dist/gittmp && git init \+	&& cd gittmp && git init \ 	&& git add . \ 	&& git commit -q -m "distributed version of propellor" \ 	&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \ 	&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head-	rm -rf dist/gittmp+	rm -rf gittmp  clean:-	rm -rf dist Setup tags propellor propellor.1 privdata/local+	rm -rf dist dist-newstyle configured Setup \+		tags propellor propellor.1 privdata/local 	find . -name \*.o -exec rm {} \; 	find . -name \*.hi -exec rm {} \; @@ -37,11 +45,12 @@ # duplicate tags with Propellor.Property. removed from the start, as we # often import qualified by just the module base name. tags:-	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true+	@find . | grep -v /.git/ | grep -v /tmp/ | grep -v dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true -dist/setup-config: propellor.cabal+configured: propellor.cabal 	@if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi 	@$(CABAL) configure+	touch configured  propellor.1: doc/usage.mdwn doc/mdwn2man 	doc/mdwn2man propellor 1 < doc/usage.mdwn > propellor.1

@@ -1,3 +1,19 @@+propellor (5.11) unstable; urgency=medium++  * Fix display of concurrent output from processes when using+    Propellor.Property.Conductor.+    (Reversion introduced in version 5.5.0.)+  * Support bootstrapping to hosts using cabal 3.x, with new-dist directory.+  * Makefile: Fix build with cabal 3.x.+  * Borg.restored: Fix restoration, which has apparently never worked,+    at least back to borg 1.0.9.+    Thanks, Nicolas Schodet.+  * Borg.init: Added the now required encryption type parameter.+    Thanks, Nicolas Schodet.+    (API change)++ -- Joey Hess <id@joeyh.name>  Fri, 14 Aug 2020 16:02:14 -0400+ propellor (5.10.2) unstable; urgency=medium    * Fix build with ghc 8.6.3.

@@ -1,5 +1,5 @@ Name: propellor-Version: 5.10.2+Version: 5.11 Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>

@@ -81,13 +81,21 @@ 	go Cabal = 		[ "cabal configure" 		, "cabal build -j1 propellor-config"-		, "ln -sf dist/build/propellor-config/propellor-config propellor"+		, "ln -sf" `commandCabalBuildTo` "propellor" 		] 	go Stack = 		[ "stack build :propellor-config" 		, "ln -sf $(stack path --dist-dir)/build/propellor-config/propellor-config propellor" 		] +commandCabalBuildTo :: ShellCommand -> FilePath -> ShellCommand+commandCabalBuildTo cmd dest = intercalate "; "+	[ "if [ -d dist-newstyle ]"+	, "then " ++ cmd ++ " $(cabal exec -- sh -c 'command -v propellor-config') " ++ shellEscape dest+	, "else " ++ cmd ++ " dist/build/propellor-config/propellor-config " ++ shellEscape dest+	, "fi"+	]+ -- Check if all dependencies are installed; if not, run the depsCommand. checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand checkDepsCommand bs sys = go (getBuilder bs)@@ -257,32 +265,28 @@ -- dependencies and retries. cabalBuild :: Maybe System -> IO Bool cabalBuild msys = do-	make "dist/setup-config" ["propellor.cabal"] cabal_configure+	make "configured" ["propellor.cabal"] cabal_configure 	unlessM cabal_build $ 		unlessM (cabal_configure <&&> cabal_build) $ 			error "cabal build failed"-	-- For safety against eg power loss in the middle of the build,-	-- make a copy of the binary, and move it into place atomically.-	-- This ensures that the propellor symlink only ever points at-	-- a binary that is fully built. Also, avoid ever removing-	-- or breaking the symlink.-	---	-- Need cp -pfRL to make build timestamp checking work.-	unlessM (boolSystem "cp" [Param "-pfRL", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $+	-- Make a copy of the binary, and move it into place atomically.+	let safetycopy = "propellor.built"+	let cpcmd = "cp -pfL" `commandCabalBuildTo` safetycopy+	unlessM (boolSystem "sh" [Param "-c", Param cpcmd]) $ 		error "cp of binary failed"-	rename (tmpfor safetycopy) safetycopy-	symlinkPropellorBin safetycopy+	rename safetycopy "propellor" 	return True   where-	cabalbuiltbin = "dist/build/propellor-config/propellor-config"-	safetycopy = cabalbuiltbin ++ ".built" 	cabal_configure = ifM (cabal ["configure"])-		( return True+		( do+			writeFile "configured" ""+			return True 		, case msys of 			Nothing -> return False 			Just sys -> 				boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))] 					<&&> cabal ["configure"]+					<&&> (writeFile "configured" "" >> return True) 		) 	-- The -j1 is to only run one job at a time -- in some situations, 	-- eg in qemu, ghc does not run reliably in parallel.

@@ -6,6 +6,7 @@ 	( BorgParam 	, BorgRepo(..) 	, BorgRepoOpt(..)+	, BorgEnc(..) 	, installed 	, repoExists 	, init@@ -14,11 +15,12 @@ 	, KeepPolicy (..) 	) where -import Propellor.Base hiding (init)+import Propellor.Base hiding (init, last) import Prelude hiding (init) import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron-import Data.List (intercalate)+import Data.List (intercalate, isSuffixOf)+import Utility.SafeCommand (boolSystem')  -- | Parameter to pass to a borg command. type BorgParam = String@@ -40,17 +42,48 @@ 	-- borg on a BorgRepo. 	| UsesEnvVar (String, String) +-- | Borg Encryption type.+data BorgEnc+	-- | No encryption, no authentication.+	= BorgEncNone+	-- | Authenticated, using SHA-256 for hash/MAC.+	| BorgEncAuthenticated+	-- | Authenticated, using Blake2b for hash/MAC.+	| BorgEncAuthenticatedBlake2+	-- | Encrypted, storing the key in the repository, using SHA-256 for+	-- hash/MAC.+	| BorgEncRepokey+	-- | Encrypted, storing the key in the repository, using Blake2b for+	-- hash/MAC.+	| BorgEncRepokeyBlake2+	-- | Encrypted, storing the key outside of the repository, using+	-- SHA-256 for hash/MAC.+	| BorgEncKeyfile+	-- | Encrypted, storing the key outside of the repository, using+	-- Blake2b for hash/MAC.+	| BorgEncKeyfileBlake2+ repoLoc :: BorgRepo -> String repoLoc (BorgRepo s) = s repoLoc (BorgRepoUsing _ s) = s -runBorg :: BorgRepo -> [CommandParam] -> IO Bool-runBorg repo ps = case runBorgEnv repo of-	[] -> boolSystem "borg" ps+runBorg :: BorgRepo -> [CommandParam] -> Maybe FilePath -> IO Bool+runBorg repo ps chdir = case runBorgEnv repo of+	[] -> runBorg' Nothing 	environ -> do 		environ' <- addEntries environ <$> getEnvironment-		boolSystemEnv "borg" ps (Just environ')+		runBorg' (Just environ')+  where+	runBorg' environ = boolSystem' "borg" ps $+		\p -> p { cwd = chdir, env = environ } +readBorg :: BorgRepo -> [String] -> IO String+readBorg repo ps = case runBorgEnv repo of+	[] -> readProcess "borg" ps+	environ -> do+		environ' <- addEntries environ <$> getEnvironment+		readProcessEnv "borg" ps (Just environ')+ runBorgEnv :: BorgRepo -> [(String, String)] runBorgEnv (BorgRepo _) = [] runBorgEnv (BorgRepoUsing os _) = map go os@@ -71,16 +104,30 @@         desc = "installed borgbackup"  repoExists :: BorgRepo -> IO Bool-repoExists repo = runBorg repo [Param "list", Param (repoLoc repo)]+repoExists repo = runBorg repo [Param "list", Param (repoLoc repo)] Nothing +-- | Get the name of the latest archive.+latestArchive :: BorgRepo -> IO (Maybe String)+latestArchive repo = getLatest <$> readBorg repo listargs+  where+	getLatest = maybeLast . filter (not . isSuffixOf ".checkpoint") . lines+	maybeLast [] = Nothing+	maybeLast ps = Just $ last ps+	listargs =+		[ "list"+		, "--short"+		, repoLoc repo+		]+ -- | Inits a new borg repository-init :: BorgRepo -> Property DebianLike-init repo = check (not <$> repoExists repo)+init :: BorgRepo -> BorgEnc -> Property DebianLike+init repo enc = check (not <$> repoExists repo) 	(cmdPropertyEnv "borg" initargs (runBorgEnv repo)) 		`requires` installed   where 	initargs = 		[ "init"+		, encParam enc 		, repoLoc repo 		] @@ -98,18 +145,24 @@ 	go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore) 		( do 			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."-			liftIO restore+			latest <- liftIO (latestArchive repo)+			case latest of+				Nothing -> do+					warningMessage $ "no archive to extract"+					return FailedChange+				Just l -> liftIO (restore l) 		, noChange 		)  	needsRestore = isUnpopulated dir -	restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do-		ok <- runBorg repo $+	restore :: String -> IO Result+	restore latest = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do+		ok <- runBorg repo 			[ Param "extract"-			, Param (repoLoc repo)-			, Param tmpdir+			, Param ((repoLoc repo) ++ "::" ++ latest) 			]+			(Just tmpdir) 		let restoreddir = tmpdir ++ "/" ++ dir 		ifM (pure ok <&&> doesDirectoryExist restoreddir) 			( do@@ -202,3 +255,13 @@ 	| KeepWeeks Int 	| KeepMonths Int 	| 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"

@@ -38,7 +38,6 @@ import Propellor.Property.Parted import Propellor.Types.PartSpec import Propellor.Types.Info-import Propellor.Property.Partition (Fs(..)) import Propellor.Property.Mount  import Data.List (sortBy)

@@ -1238,33 +1238,46 @@ 		[ "# let users power control startech hub with uhubctl" 		, "ATTR{idVendor}==\"" ++ hubvendor ++ "\", ATTR{idProduct}==\"005a\", MODE=\"0666\"" 		]-	& autoMountDrivePort "archive-10" (USBHubPort hubvendor hubloc 1)+	& autoMountDrivePort "archive-10"+		(USBHubPort hubvendor 1)+		(USBDriveId wd "1230") 		(Just "archive-oldest")-	& autoMountDrivePort "archive-11" (USBHubPort hubvendor hubloc 2)+	& autoMountDrivePort "archive-11"+		(USBHubPort hubvendor 2)+		(USBDriveId wd "25ee") 		(Just "archive-older")-	& autoMountDrivePort "archive-12" (USBHubPort hubvendor hubloc 3)+	& autoMountDrivePort "archive-12"+		(USBHubPort hubvendor 3)+		(USBDriveId seagate "3322") 		(Just "archive-old")-	& autoMountDrivePort "archive-13" (USBHubPort hubvendor hubloc 4)+	& autoMountDrivePort "archive-13"+		(USBHubPort hubvendor 4)+		(USBDriveId wd "25a3") 		(Just "archive") 	& autoMountDrive "passport" Nothing 	& Apt.installed ["git-annex", "borgbackup"]   where 	hubvendor = "0409"-	hubloc = "4-1.6"+	wd = "1058"+	seagate = "0bc2"  data USBHubPort = USBHubPort 	{ hubVendor :: String-	, hubLocation :: String 	, hubPort :: Int 	} +data USBDriveId = USBDriveId+	{ driveVendorId :: String+	, driveProductId :: String+	}+ -- Makes a USB drive with the given label automount, and unmount after idle -- for a while. -- -- The hub port is turned on and off automatically as needed, using -- uhubctl.-autoMountDrivePort :: Mount.Label -> USBHubPort -> Maybe FilePath -> Property DebianLike-autoMountDrivePort label hp malias = propertyList desc $ props+autoMountDrivePort :: Mount.Label -> USBHubPort -> USBDriveId -> Maybe FilePath -> Property DebianLike+autoMountDrivePort label hp drive malias = propertyList desc $ props 	& File.hasContent ("/etc/systemd/system/" ++ hub) 		[ "[Unit]" 		, "Description=Startech usb hub port " ++ show (hubPort hp)@@ -1272,7 +1285,7 @@ 		, "[Service]" 		, "Type=oneshot" 		, "RemainAfterExit=true"-		, "ExecStart=/usr/sbin/uhubctl -a on " ++ selecthubport+		, "ExecStart=/bin/sh -c 'uhubctl -a on " ++ selecthubport ++ "'" 		, "ExecStop=/bin/sh -c 'uhubctl -a off " ++ selecthubport 			-- Powering off the port does not remove device 			-- files, so ask udev to remove the devfile; it will@@ -1300,7 +1313,18 @@ 	selecthubport = unwords 		[ "-p", show (hubPort hp) 		, "-n", hubVendor hp-		, "-l", hubLocation hp+		, "-l", concat+			-- The hub's location id, eg "1-1.4", does not seem+			-- as stable as uhubctl claims it will be,+			-- and the vendor is not sufficient since I have 2+			-- hubs from the same vendor. So search for the+			-- drive lsusb to find that. This works even if the+			-- port is powered off, as long as it's been on at+			-- some point before.+			[ "$(lsusb -tvv | perl -lne \"if (\\\\$h && m!/sys/bus/usb/devices/(.*?) !) {\\\\$v=\\\\$1}; if (m/Hub/) { \\\\$h=1 } else { \\\\$h=0 }; if (/"+			, driveVendorId drive ++ ":" ++ driveProductId drive+			++ "/) { print \\\\$v; last}\")"+			] 		]  -- Makes a USB drive with the given label automount, and unmount after idle

@@ -181,7 +181,7 @@ instance IsInfo NamedConfMap where 	propagateInfo _ = PropagateInfo False --- | Adding a Master NamedConf stanza for a particulr domain always+-- | Adding a Master NamedConf stanza for a particular domain always -- overrides an existing Secondary stanza for that domain, while a -- Secondary stanza is only added when there is no existing Master stanza. instance Sem.Semigroup NamedConfMap where

@@ -2,7 +2,6 @@ -- distribution. -- -- Distributions should install this program into PATH.--- (Cabal builds it as dist/build/propellor/propellor). -- -- This is not the propellor main program (that's config.hs). -- This bootstraps ~/.propellor/config.hs, builds it if

@@ -1,3 +1,4 @@ module Utility.Process.Shim (module X) where -import System.Process as X+import System.Process as X hiding (createProcess, waitForProcess)+import System.Process.Concurrent as X