summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile4
-rw-r--r--doc/centralized_git_repository.mdwn8
-rw-r--r--doc/security.mdwn16
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/CmdLine.hs324
-rw-r--r--src/Propellor/Git.hs64
-rw-r--r--src/Propellor/Message.hs26
-rw-r--r--src/Propellor/Property/Docker.hs8
-rw-r--r--src/Propellor/Protocol.hs9
-rw-r--r--src/Propellor/Ssh.hs43
-rw-r--r--src/Propellor/Types.hs5
11 files changed, 282 insertions, 227 deletions
diff --git a/Makefile b/Makefile
index 9185099c..43d7d055 100644
--- a/Makefile
+++ b/Makefile
@@ -8,8 +8,8 @@ run: deps build
dev: build tags
build: dist/setup-config
- if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi
- ln -sf dist/build/propellor-config/propellor-config propellor
+ @if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi
+ @ln -sf dist/build/propellor-config/propellor-config propellor
deps:
@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS) || (apt-get update && apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS)); fi || true
diff --git a/doc/centralized_git_repository.mdwn b/doc/centralized_git_repository.mdwn
index f47aa92e..46cf89e2 100644
--- a/doc/centralized_git_repository.mdwn
+++ b/doc/centralized_git_repository.mdwn
@@ -4,7 +4,13 @@ directly to the host. This makes it easy to get started with propellor.
A central git repository allows hosts to run propellor from cron and pick
up any updates you may have pushed. This is useful when managing several
-hosts with propellor.
+hosts with propellor.
+
+The central repository does not need to be trusted; it can be hosted
+anywhere, and propellor will only accept verified gpg signed git commits
+from it. See [[security]] for details, but this means you can put it
+on github without github being able to 0wn your propellor driven hosts, for
+example.
You can add a central git repository to your existing propellor setup easily:
diff --git a/doc/security.mdwn b/doc/security.mdwn
index 7edf25d1..831b2b41 100644
--- a/doc/security.mdwn
+++ b/doc/security.mdwn
@@ -6,13 +6,13 @@ The only trusted machine is the laptop where you run `propellor --spin`
to connect to a remote host. And that one only because you have a ssh key
or login password to the host.
-Since the hosts propellor deploys are not trusted by the central git
-repository, they have to use git:// or http:// to pull from the central
-git repository, rather than ssh://.
+Since the hosts propellor deploys do not trust the central git repository,
+and it doesn't trust them, it's normal to use git:// or http:// to pull
+from the central git repository, rather than ssh://.
-So, to avoid a MITM attack, propellor checks that any commit it fetches
-from origin is gpg signed by a trusted gpg key, and refuses to deploy it
-otherwise.
+Since propellor doesn't trust the central git repository, it checks
+that any commit it fetches from it is gpg signed by a trusted gpg key,
+and refuses to deploy it otherwise.
That is only done when privdata/keyring.gpg exists. To set it up:
@@ -21,8 +21,8 @@ That is only done when privdata/keyring.gpg exists. To set it up:
In order to be secure from the beginning, when `propellor --spin` is used
to bootstrap propellor on a new host, it transfers the local git repositry
-to the remote host over ssh. After that, the remote host knows the
-gpg key, and will use it to verify git fetches.
+to the remote host over ssh. After that, the host knows the gpg key, and
+will use it to verify git fetches.
Since the propoellor git repository is public, you can't store
in cleartext private data such as passwords, ssh private keys, etc.
diff --git a/propellor.cabal b/propellor.cabal
index 0a01ada8..2a8e3a02 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -113,8 +113,10 @@ Library
Other-Modules:
Propellor.Types.Info
Propellor.CmdLine
+ Propellor.Git
Propellor.Gpg
Propellor.SimpleSh
+ Propellor.Ssh
Propellor.PrivData.Paths
Propellor.Protocol
Propellor.Property.Docker.Shim
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index e7da0a80..ee563012 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -3,14 +3,9 @@ module Propellor.CmdLine where
import System.Environment (getArgs)
import Data.List
import System.Exit
-import System.Log.Logger
-import System.Log.Formatter
-import System.Log.Handler (setFormatter, LogHandler)
-import System.Log.Handler.Simple
import System.PosixCompat
import Control.Exception (bracket)
import System.Posix.IO
-import Data.Time.Clock.POSIX
import Control.Concurrent.Async
import qualified Data.ByteString as B
import System.Process (std_in, std_out)
@@ -19,54 +14,59 @@ import Propellor
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Gpg
+import Propellor.Git
+import Propellor.Ssh
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim
import Utility.FileMode
import Utility.SafeCommand
-import Utility.UserInfo
-usage :: IO a
-usage = do
- putStrLn $ unlines
- [ "Usage:"
- , " propellor"
- , " propellor hostname"
- , " propellor --spin hostname"
- , " propellor --add-key keyid"
- , " propellor --set field context"
- , " propellor --dump field context"
- , " propellor --edit field context"
- , " propellor --list-fields"
- ]
- exitFailure
+usage :: Handle -> IO ()
+usage h = hPutStrLn h $ unlines
+ [ "Usage:"
+ , " propellor"
+ , " propellor hostname"
+ , " propellor --spin hostname"
+ , " propellor --add-key keyid"
+ , " propellor --set field context"
+ , " propellor --dump field context"
+ , " propellor --edit field context"
+ , " propellor --list-fields"
+ ]
+
+usageError :: [String] -> IO a
+usageError ps = do
+ usage stderr
+ error ("(Unexpected: " ++ show ps)
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
- go ("--help":_) = usage
- go ("--spin":h:[]) = return $ Spin h
- go ("--boot":h:[]) = return $ Boot h
go ("--run":h:[]) = return $ Run h
+ go ("--spin":h:[]) = return $ Spin h
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump
go ("--edit":f:c:[]) = withprivfield f c Edit
go ("--list-fields":[]) = return ListFields
+ go ("--help":_) = do
+ usage stdout
+ exitFailure
+ go ("--update":h:[]) = return $ Update h
+ go ("--boot":h:[]) = return $ Update h -- for back-compat
go ("--continue":s:[]) = case readish s of
Just cmdline -> return $ Continue cmdline
- Nothing -> errorMessage "--continue serialization failure"
- go ("--chain":h:[]) = return $ Chain h
- go ("--docker":h:[]) = return $ Docker h
+ Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go (h:[])
- | "--" `isPrefixOf` h = usage
+ | "--" `isPrefixOf` h = usageError [h]
| otherwise = return $ Run h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
then errorMessage "Cannot determine hostname! Pass it on the command line."
else return $ Run s
- go _ = usage
+ go v = usageError v
withprivfield s c f = case readish s of
Just pf -> return $ f pf (Context c)
@@ -86,7 +86,8 @@ defaultMain hostlist = do
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
- go _ (Chain hn) = withhost hn $ \h -> do
+ go _ (Chain hn isconsole) = withhost hn $ \h -> do
+ when isconsole forceConsole
r <- runPropellor h $ ensureProperties $ hostProperties h
putStrLn $ "\n" ++ show r
go _ (Docker hn) = Docker.chain hn
@@ -94,11 +95,15 @@ defaultMain hostlist = do
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn
+ go False cmdline@(SimpleRun hn) = buildFirst cmdline $
+ go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withhost hn mainProperties
, go True (Spin hn)
)
- go False (Boot _) = onlyProcess boot
+ go False (Update _) = do
+ forceConsole
+ onlyProcess update
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
@@ -137,10 +142,6 @@ buildFirst cmdline next = do
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
-getCurrentBranch :: IO String
-getCurrentBranch = takeWhile (/= '\n')
- <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
-
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
@@ -153,29 +154,14 @@ updateFirst' cmdline next = do
oldsha <- getCurrentGitSha1 branchref
- whenM (doesFileExist keyring) $ do
- {- To verify origin branch commit's signature, have to
- - convince gpg to use our keyring. While running git log.
- - Which has no way to pass options to gpg.
- - Argh! -}
- let gpgconf = privDataDir </> "gpg.conf"
- writeFile gpgconf $ unlines
- [ " keyring " ++ keyring
- , "no-auto-check-trustdb"
- ]
- -- gpg is picky about perms
- modifyFileMode privDataDir (removeModes otherGroupModes)
- s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
- (Just [("GNUPGHOME", privDataDir)])
- nukeFile $ privDataDir </> "trustdb.gpg"
- nukeFile $ privDataDir </> "pubring.gpg"
- nukeFile $ privDataDir </> "gpg.conf"
- if s == "U\n" || s == "G\n"
- then do
+ whenM (doesFileExist keyring) $
+ ifM (verifyOriginBranch originbranch)
+ ( do
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
hFlush stdout
void $ boolSystem "git" [Param "merge", Param originbranch]
- else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+ , warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+ )
newsha <- getCurrentGitSha1 branchref
@@ -186,72 +172,26 @@ updateFirst' cmdline next = do
, errorMessage "Propellor build failed!"
)
-getCurrentGitSha1 :: String -> IO String
-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-
-- spin handles deploying propellor to a remote host, if it's not already
-- installed there, or updating it if it is. Once the remote propellor is
-- updated, it's run.
spin :: HostName -> Host -> IO ()
spin hn hst = do
- void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
+ void $ actionMessage "Git commit (signed)" $
+ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids
-- us needing to send stuff directly to the remote host.
whenM hasOrigin $
- void $ boolSystem "git" [Param "push"]
+ void $ actionMessage "Push to central git repository" $
+ boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
- comm cacheparams =<< hostprivdata
- unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
+ comm hn hst $ withBothHandles createProcessSuccess
+ (proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
+ unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
error $ "remote propellor failed (running: " ++ runcmd ++")"
where
- hostprivdata = show . filterPrivData hst <$> decryptPrivData
-
- comm cacheparams privdata =
- withBothHandles createProcessSuccess
- (proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
- (comm' cacheparams privdata)
- comm' cacheparams privdata (toh, fromh) = loop
- where
- loop = dispatch =<< (maybe Nothing readish <$> getMarked fromh statusMarker)
- dispatch (Just NeedRepoUrl) = do
- sendMarked toh repoUrlMarker
- =<< (fromMaybe "" <$> getRepoUrl)
- loop
- dispatch (Just NeedPrivData) = do
- sendprivdata toh privdata
- loop
- dispatch (Just NeedGitPush) = do
- void $ actionMessage ("Sending git update to " ++ hn) $ do
- sendMarked toh gitPushMarker ""
- let p = (proc "git" ["upload-pack", "."])
- { std_in = UseHandle fromh
- , std_out = UseHandle toh
- }
- (Nothing, Nothing, Nothing, h) <- createProcess p
- r <- waitForProcess h
- -- no more protocol possible after git push
- hClose fromh
- hClose toh
- return (r == ExitSuccess)
- dispatch (Just NeedGitClone) = do
- hClose toh
- hClose fromh
- sendGitClone hn
- comm cacheparams privdata
- -- Ready is only sent by old versions of
- -- propellor. They expect to get privdata,
- -- and then no more protocol communication.
- dispatch (Just Ready) = do
- sendprivdata toh privdata
- hClose toh
- -- Display remaining output.
- void $ tryIO $ forever $
- showremote =<< hGetLine fromh
- hClose fromh
- dispatch Nothing = return ()
-
user = "root@"++hn
mkcmd = shellWrap . intercalate " ; "
@@ -272,18 +212,82 @@ spin hn hst = do
]
runcmd = mkcmd
- [ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
+ [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
- showremote s = putStrLn s
+-- Update the privdata, repo url, and git repo over the ssh
+-- connection from the client that ran propellor --spin.
+update :: IO ()
+update = do
+ req NeedRepoUrl repoUrlMarker setRepoUrl
+ makePrivDataDir
+ req NeedPrivData privDataMarker $
+ writeFileProtected privDataLocal
+ req NeedGitPush gitPushMarker $ \_ -> do
+ hin <- dup stdInput
+ hout <- dup stdOutput
+ hClose stdin
+ hClose stdout
+ unlessM (boolSystem "git" (pullparams hin hout)) $
+ errorMessage "git pull from client failed"
+ where
+ pullparams hin hout =
+ [ Param "pull"
+ , Param "--progress"
+ , Param "--upload-pack"
+ , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+ , Param "."
+ ]
- sendprivdata toh privdata = void $
- actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
- sendMarked toh privDataMarker privdata
- return True
+comm :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
+comm hn hst connect = connect go
+ where
+ go (toh, fromh) = do
+ let loop = go (toh, fromh)
+ v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
+ case v of
+ (Just NeedRepoUrl) -> do
+ sendRepoUrl toh
+ loop
+ (Just NeedPrivData) -> do
+ sendPrivData hn hst toh
+ loop
+ (Just NeedGitPush) -> do
+ sendGitUpdate hn fromh toh
+ -- no more protocol possible after git push
+ hClose fromh
+ hClose toh
+ (Just NeedGitClone) -> do
+ hClose toh
+ hClose fromh
+ sendGitClone hn
+ comm hn hst connect
+ Nothing -> return ()
+
+sendRepoUrl :: Handle -> IO ()
+sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
+
+sendPrivData :: HostName -> Host -> Handle -> IO ()
+sendPrivData hn hst toh = do
+ privdata <- show . filterPrivData hst <$> decryptPrivData
+ void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+ sendMarked toh privDataMarker privdata
+ return True
+
+sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
+sendGitUpdate hn fromh toh =
+ void $ actionMessage ("Sending git update to " ++ hn) $ do
+ sendMarked toh gitPushMarker ""
+ (Nothing, Nothing, Nothing, h) <- createProcess p
+ (==) ExitSuccess <$> waitForProcess h
+ where
+ p = (proc "git" ["upload-pack", "."])
+ { std_in = UseHandle fromh
+ , std_out = UseHandle toh
+ }
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
-sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
+sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
branch <- getCurrentBranch
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
@@ -301,23 +305,6 @@ sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
, "rm -f " ++ remotebundle
]
--- Called "boot" for historical reasons, but what this really does is
--- update the privdata, repo url, and git repo over the ssh connection from the
--- client that ran propellor --spin.
-boot :: IO ()
-boot = do
- req NeedRepoUrl repoUrlMarker setRepoUrl
- makePrivDataDir
- req NeedPrivData privDataMarker $
- writeFileProtected privDataLocal
- req NeedGitPush gitPushMarker $ \_ -> do
- hin <- dup stdInput
- hout <- dup stdOutput
- hClose stdin
- hClose stdout
- unlessM (boolSystem "git" [Param "pull", Param "--progress", Param "--upload-pack", Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout, Param "."]) $
- errorMessage "git pull from client failed"
-
-- 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.
@@ -342,78 +329,3 @@ gitPush hin hout = void $ fromstdin `concurrently` tostdout
B.hPut toh b
hFlush toh
connect fromh toh
-
-hasOrigin :: IO Bool
-hasOrigin = do
- rs <- lines <$> readProcess "git" ["remote"]
- return $ "origin" `elem` rs
-
-setRepoUrl :: String -> IO ()
-setRepoUrl "" = return ()
-setRepoUrl url = do
- subcmd <- ifM hasOrigin (pure "set-url", pure "add")
- void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url]
- -- same as --set-upstream-to, except origin branch
- -- may not have been pulled yet
- branch <- getCurrentBranch
- let branchval s = "branch." ++ branch ++ "." ++ s
- void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"]
- void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch]
-
-getRepoUrl :: IO (Maybe String)
-getRepoUrl = getM get urls
- where
- urls = ["remote.deploy.url", "remote.origin.url"]
- get u = do
- v <- catchMaybeIO $
- takeWhile (/= '\n')
- <$> readProcess "git" ["config", u]
- return $ case v of
- Just url | not (null url) -> Just url
- _ -> Nothing
-
-checkDebugMode :: IO ()
-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
- where
- go (Just "1") = do
- f <- setFormatter
- <$> streamHandler stderr DEBUG
- <*> pure (simpleLogFormatter "[$time] $msg")
- updateGlobalLogger rootLoggerName $
- setLevel DEBUG . setHandlers [f]
- go _ = noop
-
--- Parameters can be passed to both ssh and scp, to enable a ssh connection
--- caching socket.
---
--- If the socket already exists, check if its mtime is older than 10
--- minutes, and if so stop that ssh process, in order to not try to
--- use an old stale connection. (atime would be nicer, but there's
--- a good chance a laptop uses noatime)
-sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hn = do
- home <- myHomeDir
- let cachedir = home </> ".ssh" </> "propellor"
- createDirectoryIfMissing False cachedir
- let socketfile = cachedir </> hn ++ ".sock"
- let ps =
- [ Param "-o", Param ("ControlPath=" ++ socketfile)
- , Params "-o ControlMaster=auto -o ControlPersist=yes"
- ]
-
- maybe noop (expireold ps socketfile)
- =<< catchMaybeIO (getFileStatus socketfile)
-
- return ps
-
- where
- expireold ps f s = do
- now <- truncate <$> getPOSIXTime :: IO Integer
- if modificationTime s > fromIntegral now - tenminutes
- then touchFile f
- else do
- void $ boolSystem "ssh" $
- [ Params "-O stop" ] ++ ps ++
- [ Param "localhost" ]
- nukeFile f
- tenminutes = 600
diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs
new file mode 100644
index 00000000..51ed3df2
--- /dev/null
+++ b/src/Propellor/Git.hs
@@ -0,0 +1,64 @@
+module Propellor.Git where
+
+import Propellor
+import Propellor.PrivData.Paths
+import Propellor.Gpg
+import Utility.SafeCommand
+import Utility.FileMode
+
+getCurrentBranch :: IO String
+getCurrentBranch = takeWhile (/= '\n')
+ <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
+
+getCurrentGitSha1 :: String -> IO String
+getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
+
+setRepoUrl :: String -> IO ()
+setRepoUrl "" = return ()
+setRepoUrl url = do
+ subcmd <- ifM hasOrigin (pure "set-url", pure "add")
+ void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url]
+ -- same as --set-upstream-to, except origin branch
+ -- may not have been pulled yet
+ branch <- getCurrentBranch
+ let branchval s = "branch." ++ branch ++ "." ++ s
+ void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"]
+ void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch]
+
+getRepoUrl :: IO (Maybe String)
+getRepoUrl = getM get urls
+ where
+ urls = ["remote.deploy.url", "remote.origin.url"]
+ get u = do
+ v <- catchMaybeIO $
+ takeWhile (/= '\n')
+ <$> readProcess "git" ["config", u]
+ return $ case v of
+ Just url | not (null url) -> Just url
+ _ -> Nothing
+
+hasOrigin :: IO Bool
+hasOrigin = do
+ rs <- lines <$> readProcess "git" ["remote"]
+ return $ "origin" `elem` rs
+
+{- To verify origin branch commit's signature, have to convince gpg
+ - to use our keyring.
+ - While running git log. Which has no way to pass options to gpg.
+ - Argh!
+ -}
+verifyOriginBranch :: String -> IO Bool
+verifyOriginBranch originbranch = do
+ let gpgconf = privDataDir </> "gpg.conf"
+ writeFile gpgconf $ unlines
+ [ " keyring " ++ keyring
+ , "no-auto-check-trustdb"
+ ]
+ -- gpg is picky about perms
+ modifyFileMode privDataDir (removeModes otherGroupModes)
+ s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
+ (Just [("GNUPGHOME", privDataDir)])
+ nukeFile $ privDataDir </> "trustdb.gpg"
+ nukeFile $ privDataDir </> "pubring.gpg"
+ nukeFile $ privDataDir </> "gpg.conf"
+ return (s == "U\n" || s == "G\n")
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index e184a59e..a1e510ab 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -5,21 +5,34 @@ module Propellor.Message where
import System.Console.ANSI
import System.IO
import System.Log.Logger
+import System.Log.Formatter
+import System.Log.Handler (setFormatter, LogHandler)
+import System.Log.Handler.Simple
import "mtl" Control.Monad.Reader
+import Data.Maybe
+import Control.Applicative
import Propellor.Types
import Utility.Monad
+import Utility.Env
data MessageHandle
= ConsoleMessageHandle
| TextMessageHandle
mkMessageHandle :: IO MessageHandle
-mkMessageHandle = ifM (hIsTerminalDevice stdout)
+mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
( return ConsoleMessageHandle
, return TextMessageHandle
)
+forceConsole :: IO ()
+forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
+
+isConsole :: MessageHandle -> Bool
+isConsole ConsoleMessageHandle = True
+isConsole _ = False
+
whenConsole :: MessageHandle -> IO () -> IO ()
whenConsole ConsoleMessageHandle a = a
whenConsole _ _ = return ()
@@ -88,3 +101,14 @@ colorLine h intensity color msg = do
-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
debug :: [String] -> IO ()
debug = debugM "propellor" . unwords
+
+checkDebugMode :: IO ()
+checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
+ where
+ go (Just "1") = do
+ f <- setFormatter
+ <$> streamHandler stderr DEBUG
+ <*> pure (simpleLogFormatter "[$time] $msg")
+ updateGlobalLogger rootLoggerName $
+ setLevel DEBUG . setHandlers [f]
+ go _ = noop
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 5a7a0840..491955dd 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -385,7 +385,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
liftIO $ writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"])
- [shim, "--docker", fromContainerId cid]
+ [shim, "--continue", show (Docker (fromContainerId cid))]
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
@@ -416,7 +416,7 @@ chain s = case toContainerId s of
-- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
- unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $
+ unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $
warningMessage "Boot provision failed!"
void $ async $ job reapzombies
void $ async $ job $ simpleSh $ namedPipe cid
@@ -440,13 +440,13 @@ chain s = case toContainerId s of
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+ msgh <- mkMessageHandle
+ let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
when (r /= FailedChange) $
setProvisionedFlag cid
return r
where
- params = ["--continue", show $ Chain $ containerHostName cid]
-
go lastline (v:rest) = case v of
StdoutLine s -> do
maybe noop putStrLn lastline
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index 99afb31f..f8b706cc 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -1,7 +1,7 @@
-- | This is a simple line-based protocol used for communication between
-- a local and remote propellor. It's sent over a ssh channel, and lines of
-- the protocol can be interspersed with other, non-protocol lines
--- that should be ignored.
+-- that should be passed through to be displayed.
module Propellor.Protocol where
@@ -9,7 +9,7 @@ import Data.List
import Propellor
-data Stage = Ready | NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
+data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
deriving (Read, Show, Eq)
type Marker = String
@@ -48,7 +48,10 @@ getMarked h marker = go =<< catchMaybeIO (hGetLine h)
where
go Nothing = return Nothing
go (Just l) = case fromMarked marker l of
- Nothing -> getMarked h marker
+ Nothing -> do
+ unless (null l) $
+ hPutStrLn stderr l
+ getMarked h marker
Just v -> return (Just v)
req :: Stage -> Marker -> (String -> IO ()) -> IO ()
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
new file mode 100644
index 00000000..969517a8
--- /dev/null
+++ b/src/Propellor/Ssh.hs
@@ -0,0 +1,43 @@
+module Propellor.Ssh where
+
+import Propellor
+import Utility.SafeCommand
+import Utility.UserInfo
+
+import System.PosixCompat
+import Data.Time.Clock.POSIX
+
+-- Parameters can be passed to both ssh and scp, to enable a ssh connection
+-- caching socket.
+--
+-- If the socket already exists, check if its mtime is older than 10
+-- minutes, and if so stop that ssh process, in order to not try to
+-- use an old stale connection. (atime would be nicer, but there's
+-- a good chance a laptop uses noatime)
+sshCachingParams :: HostName -> IO [CommandParam]
+sshCachingParams hn = do
+ home <- myHomeDir
+ let cachedir = home </> ".ssh" </> "propellor"
+ createDirectoryIfMissing False cachedir
+ let socketfile = cachedir </> hn ++ ".sock"
+ let ps =
+ [ Param "-o", Param ("ControlPath=" ++ socketfile)
+ , Params "-o ControlMaster=auto -o ControlPersist=yes"
+ ]
+
+ maybe noop (expireold ps socketfile)
+ =<< catchMaybeIO (getFileStatus socketfile)
+
+ return ps
+
+ where
+ expireold ps f s = do
+ now <- truncate <$> getPOSIXTime :: IO Integer
+ if modificationTime s > fromIntegral now - tenminutes
+ then touchFile f
+ else do
+ void $ boolSystem "ssh" $
+ [ Params "-O stop" ] ++ ps ++
+ [ Param "localhost" ]
+ nukeFile f
+ tenminutes = 600
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 72ccd228..a1d25b4f 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -138,14 +138,15 @@ instance ActionResult Result where
data CmdLine
= Run HostName
| Spin HostName
+ | SimpleRun HostName
| Set PrivDataField Context
| Dump PrivDataField Context
| Edit PrivDataField Context
| ListFields
| AddKey String
| Continue CmdLine
- | Chain HostName
- | Boot HostName
+ | Chain HostName Bool
+ | Update HostName
| Docker HostName
| GitPush Fd Fd
deriving (Read, Show, Eq)