propellor 4.0.4 → 4.0.6

raw patch · 10 files changed

+90/−77 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +8/−0
• config-freebsd.hs +1/−1
• debian/changelog +8/−0
• joeyconfig.hs +4/−21
• propellor.cabal +1/−1
• src/Propellor/Info.hs +2/−2
• src/Propellor/Message.hs +2/−2
• src/Propellor/Protocol.hs +7/−3
• src/Propellor/Spin.hs +56/−46
• src/Propellor/Types/OS.hs +1/−1

@@ -1,3 +1,11 @@+propellor (4.0.6) unstable; urgency=medium++  * Fix bug that sometimes made --spin fail with +    "fatal: Couldn't find remote ref HEAD"+  * Display error and warning messages to stderr, not stdout.++ -- Joey Hess <id@joeyh.name>  Sun, 18 Jun 2017 19:30:50 -0400+ propellor (4.0.5) unstable; urgency=medium    * Switch cabal file from Extensions to Default-Extensions to fix

@@ -59,7 +59,7 @@ -- A generic webserver in a Docker container. webserverContainer :: Docker.Container webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props-	& osDebian' KFreeBSD (Stable "jessie") X86_64+	& osDebian' KFreeBSD (Stable "stretch") X86_64 	& Apt.stdSourcesList 	& Docker.publish "80:80" 	& Docker.volume "/var/www:/var/www"

@@ -1,3 +1,11 @@+propellor (4.0.6) unstable; urgency=medium++  * Fix bug that sometimes made --spin fail with +    "fatal: Couldn't find remote ref HEAD"+  * Display error and warning messages to stderr, not stdout.++ -- Joey Hess <id@joeyh.name>  Sun, 18 Jun 2017 19:30:50 -0400+ propellor (4.0.5) unstable; urgency=medium    * Switch cabal file from Extensions to Default-Extensions to fix

@@ -50,7 +50,6 @@ 	, gnu 	, dragon 	, clam-	, mayfly 	, orca 	, baleen 	, honeybee@@ -124,7 +123,7 @@ clam = host "clam.kitenet.net" $ props 	& standardSystem Unstable X86_64 		["Unreliable server. Anything here may be lost at any time!" ]-	& ipv4 "64.137.231.62"+	& ipv4 "64.137.239.3"  	& CloudAtCost.decruft 	& Ssh.hostKeys hostContext@@ -133,7 +132,6 @@ 		, (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBPhfvcOuw0Yt+MnsFc4TI2gWkKi62Eajxz+TgbHMO/uRTYF8c5V8fOI3o+J/3m5+lT0S5o8j8a7xIC3COvi+AVw=") 		] 	& Apt.unattendedUpgrades-	& Network.ipv6to4 	& Systemd.persistentJournal 	& Journald.systemMaxUse "50MiB" @@ -147,22 +145,6 @@ 	& alias "scroll.joeyh.name" 	& alias "us.scroll.joeyh.name" -mayfly :: Host-mayfly = host "mayfly.kitenet.net" $ props-	& standardSystem (Stable "jessie") X86_64-		[ "Scratch VM. Contents can change at any time!" ]-	& ipv4 "167.88.36.193"--	& CloudAtCost.decruft-	& Apt.unattendedUpgrades-	& Network.ipv6to4-	& Systemd.persistentJournal-	& Journald.systemMaxUse "500MiB"--	& Tor.isRelay-	& Tor.named "kite3"-	& Tor.bandwidthRate (Tor.PerMonth "400 GB")- baleen :: Host baleen = host "baleen.kitenet.net" $ props 	& standardSystem Unstable X86_64 [ "New git-annex build box." ]@@ -468,6 +450,7 @@ 	& alias "dist-bugs.kitenet.net" 	& alias "family.kitenet.net" +	& osDebian (Stable "jessie") X86_64 	& Apt.installed ["linux-image-amd64"] 	& Apt.unattendedUpgrades 	& Branchable.server hosts@@ -478,7 +461,7 @@ keysafe = host "keysafe.joeyh.name" $ props 	& ipv4 "139.59.17.168" 	& Hostname.sane-	& osDebian (Stable "jessie") X86_64+	& osDebian (Stable "stretch") X86_64 	& Apt.stdSourcesList `onChange` Apt.upgrade 	& Apt.unattendedUpgrades 	& DigitalOcean.distroKernel@@ -567,7 +550,7 @@  kiteShellBox :: Systemd.Container kiteShellBox = Systemd.debContainer "kiteshellbox" $ props-	& standardContainer (Stable "jessie")+	& standardContainer (Stable "stretch") 	& JoeySites.kiteShellBox  type Motd = [String]

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

@@ -84,13 +84,13 @@ -- It also lets the type checker know that all the properties of the -- host must support Debian. ----- >	& osDebian (Stable "jessie") X86_64+-- >	& osDebian (Stable "stretch") X86_64 osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) osDebian = osDebian' Linux  -- Use to specify a different `DebianKernel` than the default `Linux` ----- >	& osDebian' KFreeBSD (Stable "jessie") X86_64+-- >	& osDebian' KFreeBSD (Stable "stretch") X86_64 osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian) osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch) 

@@ -102,7 +102,7 @@  warningMessage :: MonadIO m => String -> m () warningMessage s = liftIO $-	outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)+	errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)  infoMessage :: MonadIO m => [String] -> m () infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls@@ -113,7 +113,7 @@ -- property fail. Propellor will continue to the next property. errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do-	outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)+	errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s) 	-- Normally this exception gets caught and is not displayed, 	-- and propellor continues. So it's only displayed if not 	-- caught, and so we say, cannot continue.

@@ -53,7 +53,11 @@ 	hFlush h  getMarked :: Handle -> Marker -> IO (Maybe String)-getMarked h marker = go =<< catchMaybeIO (hGetLine h)+getMarked h marker = do+	-- Avoid buffering anything in Handle, so that the data after+	-- the marker will be available to be read from the underlying Fd.+	hSetBuffering stdin NoBuffering+	go =<< catchMaybeIO (hGetLine h)   where 	go Nothing = return Nothing 	go (Just l) = case fromMarked marker l of@@ -65,8 +69,8 @@ 			debug ["received marked", marker] 			return (Just v) -req :: Stage -> Marker -> (String -> IO ()) -> IO ()-req stage marker a = do+reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()+reqMarked stage marker a = do 	debug ["requested marked", marker] 	sendMarked' stdout statusMarker (show stage) 	maybe noop a =<< getMarked stdin marker

@@ -178,34 +178,16 @@ update :: Maybe HostName -> IO () update forhost = do 	whenM hasGitRepo $-		req NeedRepoUrl repoUrlMarker setRepoUrl+		reqMarked NeedRepoUrl repoUrlMarker setRepoUrl  	makePrivDataDir 	createDirectoryIfMissing True (takeDirectory privfile)-	req NeedPrivData privDataMarker $+	reqMarked NeedPrivData privDataMarker $ 		writeFileProtected privfile  	whenM hasGitRepo $-		req NeedGitPush gitPushMarker $ \_ -> do-			hin <- dup stdInput-			hout <- dup stdOutput-			hClose stdin-			hClose stdout-			-- Not using git pull because git 2.5.0 badly-			-- broke its option parser.-			unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $-				errorMessage "git fetch from client failed"-			unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $-				errorMessage "git merge from client failed"+		gitPullFromUpdateServer   where-	pullparams hin hout =-		[ Param "fetch"-		, Param "--progress"-		, Param "--upload-pack"-		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout-		, Param "."-		]- 	-- When --spin --relay is run, get a privdata file 	-- to be relayed to the target host. 	privfile = maybe privDataLocal privDataRelay forhost@@ -336,31 +318,6 @@ 		, "rm -f " ++ remotetarball 		] --- Shim for git push over the propellor ssh channel.--- Reads from stdin and sends it to hout;--- reads from hin and sends it to stdout.-gitPushHelper :: Fd -> Fd -> IO ()-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout-  where-	fromstdin = do-		h <- fdToHandle hout-		connect stdin h-	tostdout = do-		h <- fdToHandle hin-		connect h stdout-	connect fromh toh = do-		hSetBinaryMode fromh True-		hSetBinaryMode toh True-		b <- B.hGetSome fromh 40960-		if B.null b-			then do-				hClose fromh-				hClose toh-			else do-				B.hPut toh b-				hFlush toh-				connect fromh toh- mergeSpin :: IO () mergeSpin = do 	branch <- getCurrentBranch@@ -388,3 +345,56 @@  spinCommitMessage :: String spinCommitMessage = "propellor spin"++-- Stdin and stdout are connected to the updateServer over ssh.+-- Request that it run git upload-pack, and connect that up to a git fetch+-- to receive the data.+gitPullFromUpdateServer :: IO ()+gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do+	-- Note that this relies on data not being buffered in the stdin+	-- Handle, since such buffered data would not be available in the+	-- FD passed to git fetch. +	hin <- dup stdInput+	hout <- dup stdOutput+	hClose stdin+	hClose stdout+	-- Not using git pull because git 2.5.0 badly+	-- broke its option parser.+	unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $+		errorMessage "git fetch from client failed"+	unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $+		errorMessage "git merge from client failed"+  where+	fetchparams hin hout =+		[ Param "fetch"+		, Param "--progress"+		, Param "--upload-pack"+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout+		, Param "."+		]++-- Shim for git push over the propellor ssh channel.+-- Reads from stdin and sends it to hout;+-- reads from hin and sends it to stdout.+gitPushHelper :: Fd -> Fd -> IO ()+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout+  where+	fromstdin = do+		h <- fdToHandle hout+		stdin *>* h+	tostdout = do+		h <- fdToHandle hin+		h *>* stdout++-- Forward data from one handle to another.+(*>*) :: Handle -> Handle -> IO ()+fromh *>* toh = do+	b <- B.hGetSome fromh 40960+	if B.null b+		then do+			hClose fromh+			hClose toh+		else do+			B.hPut toh b+			hFlush toh+			fromh *>* toh

@@ -59,7 +59,7 @@ 	deriving (Show, Eq)  -- | Debian has several rolling suites, and a number of stable releases,--- such as Stable "jessie".+-- such as Stable "stretch". data DebianSuite = Experimental | Unstable | Testing | Stable Release 	deriving (Show, Eq)