diff options
| -rw-r--r-- | debian/changelog | 1 | ||||
| -rw-r--r-- | propellor.cabal | 1 | ||||
| -rw-r--r-- | src/Propellor/Gpg.hs | 10 | ||||
| -rw-r--r-- | src/Propellor/PrivData.hs | 7 | ||||
| -rw-r--r-- | src/Propellor/Spin.hs | 29 | ||||
| -rw-r--r-- | src/Utility/Process/NonConcurrent.hs | 33 |
6 files changed, 55 insertions, 26 deletions
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 <id@joeyh.name> 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 <id@joeyh.name> + - + - 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 |