From 7e88dd094ec3f36e6213dd1ff7010e3bf7a152f5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 19:38:01 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 495ebaf4..718475e8 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -66,6 +66,7 @@ spin = spin' Nothing spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO () spin' mprivdata relay target hst = do + async $ boolSystem "sleep" [Param "500"] cacheparams <- if viarelay then pure ["-A"] else toCommand <$> sshCachingParams hn -- cgit v1.2.3 From ea649f770ef7e2fa8968adc2ff19cf5a4f4f6c2f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 19:45:29 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 718475e8..b148fe75 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -66,7 +66,6 @@ spin = spin' Nothing spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO () spin' mprivdata relay target hst = do - async $ boolSystem "sleep" [Param "500"] cacheparams <- if viarelay then pure ["-A"] else toCommand <$> sshCachingParams hn @@ -82,6 +81,7 @@ spin' mprivdata relay target hst = do (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) =<< getprivdata + async $ boolSystem "sleep" [Param "500"] -- And now we can run it. unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ -- cgit v1.2.3 From c4e2006f00ff78d56d3f4ad815564b53e87ec9fb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 19:47:09 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index b148fe75..7f8c87a2 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -31,6 +31,8 @@ import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand +import System.Console.Concurrent + commitSpin :: IO () commitSpin = do -- safety check #1: check we're on the configured spin branch @@ -81,7 +83,7 @@ spin' mprivdata relay target hst = do (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) =<< getprivdata - async $ boolSystem "sleep" [Param "500"] + async $ createProcessForeground $ proc "sleep" ["500"] -- And now we can run it. unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ -- cgit v1.2.3 From d09a67ea25be77300a4eeb06b7c922b0c28c5d25 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 20:21:30 -0400 Subject: refactor --- src/Utility/Process.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index c6699961e..ed02f49e 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -18,6 +18,7 @@ module Utility.Process ( readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, @@ -129,11 +130,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () -forceSuccessProcess p pid = do - code <- waitForProcess pid - case code of - ExitSuccess -> return () - ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (ExitFailure n) = fail $ + showCmd p ++ " exited " ++ show n -- | Waits for a ProcessHandle and returns True if it exited successfully. -- Note that using this with createProcessChecked will throw away -- cgit v1.2.3 From 979fc0e4c03bf6ccd88873f561040bfa1133111d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 20:39:44 -0400 Subject: Force ssh, scp, and git commands to be run in the foreground. Before, they could run in the background if another process was running, and so their output wouldn't immediately be visible. With this change, the concurrent-output layer is not used for these interactive commands. --- debian/changelog | 1 + propellor.cabal | 1 + src/Propellor/Gpg.hs | 10 ++-------- src/Propellor/PrivData.hs | 7 ++----- src/Propellor/Spin.hs | 29 ++++++++++++++++------------- src/Utility/Process/NonConcurrent.hs | 33 +++++++++++++++++++++++++++++++++ 6 files changed, 55 insertions(+), 26 deletions(-) create mode 100644 src/Utility/Process/NonConcurrent.hs (limited to 'src') diff --git a/debian/changelog b/debian/changelog index 1b4c3998..008ac687 100644 --- a/debian/changelog +++ b/debian/changelog @@ -14,6 +14,7 @@ propellor (2.17.0) UNRELEASED; urgency=medium * Locale.available: Run locale-gen, instead of dpkg-reconfigure locales, which modified the locale.gen file and sometimes caused the property to need to make changes every time. + * Force ssh, scp, and git commands to be run in the foreground. -- Joey Hess Mon, 29 Feb 2016 17:58:08 -0400 diff --git a/propellor.cabal b/propellor.cabal index 3518a7ee..7c781c43 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -175,6 +175,7 @@ Library Utility.PosixFiles Utility.Process Utility.Process.Shim + Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled Utility.Table diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs index d3550e88..a13734b4 100644 --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -6,8 +6,6 @@ import System.Directory import Data.Maybe import Data.List.Utils import Control.Monad -import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Control.Applicative import Prelude @@ -16,6 +14,7 @@ import Propellor.Message import Propellor.Git.Config import Utility.SafeCommand import Utility.Process +import Utility.Process.NonConcurrent import Utility.Monad import Utility.Misc import Utility.Tmp @@ -144,12 +143,7 @@ gitCommit msg ps = do let ps' = Param "commit" : ps ++ maybe [] (\m -> [Param "-m", Param m]) msg ps'' <- gpgSignParams ps' - if isNothing msg - then do - (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ - proc "git" (toCommand ps'') - checkSuccessProcess p - else boolSystem "git" ps'' + boolSystemNonConcurrent "git" ps'' gpgDecrypt :: FilePath -> IO String gpgDecrypt f = do diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 2ed75e33..ac7b00d3 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -34,8 +34,6 @@ import "mtl" Control.Monad.Reader import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Control.Applicative import Data.Monoid import Prelude @@ -52,12 +50,12 @@ import Utility.PartialPrelude import Utility.Exception import Utility.Tmp import Utility.SafeCommand +import Utility.Process.NonConcurrent import Utility.Misc import Utility.FileMode import Utility.Env import Utility.Table import Utility.FileSystemEncoding -import Utility.Process -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext. @@ -196,8 +194,7 @@ editPrivData field context = do hClose th maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v editor <- getEnvDefault "EDITOR" "vi" - (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f] - unlessM (checkSuccessProcess p) $ + unlessM (boolSystemNonConcurrent editor [File f]) $ error "Editor failed; aborting." PrivData <$> readFile f setPrivDataTo field context v' diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 7f8c87a2..83654105 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -30,8 +30,7 @@ import Propellor.Types.Info import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand - -import System.Console.Concurrent +import Utility.Process.NonConcurrent commitSpin :: IO () commitSpin = do @@ -61,7 +60,7 @@ commitSpin = do -- us needing to send stuff directly to the remote host. whenM hasOrigin $ void $ actionMessage "Push to central git repository" $ - boolSystem "git" [Param "push"] + boolSystemNonConcurrent "git" [Param "push"] spin :: Maybe HostName -> HostName -> Host -> IO () spin = spin' Nothing @@ -83,10 +82,9 @@ spin' mprivdata relay target hst = do (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) =<< getprivdata - async $ createProcessForeground $ proc "sleep" ["500"] -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ + unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ error "remote propellor failed" where hn = fromMaybe target relay @@ -190,9 +188,9 @@ update forhost = do hClose stdout -- Not using git pull because git 2.5.0 badly -- broke its option parser. - unlessM (boolSystem "git" (pullparams hin hout)) $ + unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $ errorMessage "git fetch from client failed" - unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $ + unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ errorMessage "git merge from client failed" where pullparams hin hout = @@ -215,8 +213,13 @@ updateServer -> CreateProcess -> PrivMap -> IO () -updateServer target relay hst connect haveprecompiled privdata = - withIOHandles createProcessSuccess connect go +updateServer target relay hst connect haveprecompiled privdata = do + (Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect + { std_in = CreatePipe + , std_out = CreatePipe + } + go (toh, fromh) + forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid where hn = fromMaybe target relay @@ -279,8 +282,8 @@ sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do cacheparams <- sshCachingParams hn withTmpFile "propellor.git" $ \tmp _ -> allM id [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] - , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] ] where remotebundle = "/usr/local/propellor.git" @@ -316,8 +319,8 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor withTmpFile "propellor.tar." $ \tarball _ -> allM id [ boolSystem "strip" [File me] , boolSystem "tar" [Param "czf", File tarball, File shimdir] - , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] ] remotetarball = "/usr/local/propellor.tar" diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs new file mode 100644 index 00000000..27eb5e92 --- /dev/null +++ b/src/Utility/Process/NonConcurrent.hs @@ -0,0 +1,33 @@ +{- Running processes in the foreground, not via the concurrent-output + - layer. + - + - Avoid using this in propellor properties! + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process.NonConcurrent where + +import System.Process +import System.Exit +import System.IO +import Utility.SafeCommand + +boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool +boolSystemNonConcurrent cmd params = do + (Nothing, Nothing, Nothing, p) <- createProcessNonConcurrent $ + proc cmd (toCommand params) + dispatch <$> waitForProcessNonConcurrent p + where + dispatch ExitSuccess = True + dispatch _ = False + +createProcessNonConcurrent :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcessNonConcurrent = createProcess + +waitForProcessNonConcurrent :: ProcessHandle -> IO ExitCode +waitForProcessNonConcurrent = waitForProcess -- cgit v1.2.3 From 57a6e9788953f9ee4714572e5d2c022b66380290 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 20:52:11 -0400 Subject: build with older ghc --- src/Utility/Process/NonConcurrent.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs index 27eb5e92..d25d2a24 100644 --- a/src/Utility/Process/NonConcurrent.hs +++ b/src/Utility/Process/NonConcurrent.hs @@ -16,6 +16,8 @@ import System.Process import System.Exit import System.IO import Utility.SafeCommand +import Control.Applicative +import Prelude boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool boolSystemNonConcurrent cmd params = do -- cgit v1.2.3