summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2016-03-06 20:54:22 -0400
committerJoey Hess2016-03-06 20:54:22 -0400
commit6cb5e3bbf5bf05637d71695ebc001be103526782 (patch)
tree09324a71087268d915948f59208770d308927b6f
parent4d09233efd8ad7a238f8002d1aa4cfe3a37013e6 (diff)
parentcef0ee73bb57980bb084025971734cb158842fdc (diff)
Merge branch 'joeyconfig'
-rw-r--r--debian/changelog1
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Gpg.hs10
-rw-r--r--src/Propellor/PrivData.hs7
-rw-r--r--src/Propellor/Spin.hs26
-rw-r--r--src/Utility/Process.hs12
-rw-r--r--src/Utility/Process/NonConcurrent.hs35
7 files changed, 64 insertions, 28 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 495ebaf4..83654105 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -30,6 +30,7 @@ import Propellor.Types.Info
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
+import Utility.Process.NonConcurrent
commitSpin :: IO ()
commitSpin = do
@@ -59,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,7 +84,7 @@ spin' mprivdata relay target hst = do
=<< getprivdata
-- 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
@@ -187,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 =
@@ -212,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
@@ -276,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"
@@ -313,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.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
diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs
new file mode 100644
index 00000000..d25d2a24
--- /dev/null
+++ b/src/Utility/Process/NonConcurrent.hs
@@ -0,0 +1,35 @@
+{- 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
+import Control.Applicative
+import Prelude
+
+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