summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 17:33:21 -0400
committerJoey Hess2014-11-18 17:33:21 -0400
commit6df64ff653d7dddc7b87d633df0d38d46b19a523 (patch)
tree3a2b27905febf873d327263ba2fe0d14ff6d1ced
parent2fab1a08b4f197874ad6c613f118315ab0d474a3 (diff)
parenteaa460c04bfa65f566693c9262c591890d506725 (diff)
Merge branch 'joeyconfig'
-rw-r--r--config-joey.hs4
-rw-r--r--debian/changelog8
-rw-r--r--doc/README.mdwn23
-rw-r--r--doc/centralized_git_repository.mdwn31
-rw-r--r--doc/security.mdwn3
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/CmdLine.hs215
-rw-r--r--src/Propellor/Message.hs60
-rw-r--r--src/Propellor/Protocol.hs57
-rw-r--r--src/Propellor/Types.hs4
10 files changed, 288 insertions, 118 deletions
diff --git a/config-joey.hs b/config-joey.hs
index ee0c54a8..7d48aee3 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -191,9 +191,9 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64"
& JoeySites.annexWebSite "/srv/git/downloads.git"
"downloads.kitenet.net"
"840760dc-08f0-11e2-8c61-576b7e66acfd"
- [("usbackup", "ssh://usbackup.kitenet.net/~/lib/downloads/")]
+ [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")]
`requires` Ssh.keyImported SshRsa "joey" (Context "downloads.kitenet.net")
- `requires` Ssh.knownHost hosts "usbackup.kitenet.net" "joey"
+ `requires` Ssh.knownHost hosts "eubackup.kitenet.net" "joey"
& JoeySites.gitAnnexDistributor
& alias "tmp.kitenet.net"
& JoeySites.annexWebSite "/srv/git/joey/tmp.git"
diff --git a/debian/changelog b/debian/changelog
index 3858ac2f..2e5a8bbd 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,5 +1,11 @@
propellor (0.9.3) UNRELEASED; urgency=medium
+ * propellor --spin can now be used to update remote hosts, without
+ any central git repository being used. The git repository is updated
+ over propellor's ssh connection to the remote host. The central
+ git repository is still useful for running propellor from cron,
+ but this simplifies getting started with propellor.
+ * The git repo url, if any, is updated whenever propellor --spin is used.
* Added prosody module, contributed by Félix Sipma.
* Can be used to configure tor hidden services. Thanks, Félix Sipma.
* When multiple gpg keys are added, ensure that the privdata file
@@ -7,6 +13,8 @@ propellor (0.9.3) UNRELEASED; urgency=medium
* Convert GpgKeyId to newtype.
* DigitalOcean.distroKernel property now reboots into the distribution
kernel when necessary.
+ * Avoid outputting color setting sequences when not run on a terminal.
+ * Run remote propellor --spin with a controlling terminal.
-- Joey Hess <joeyh@debian.org> Mon, 10 Nov 2014 11:15:27 -0400
diff --git a/doc/README.mdwn b/doc/README.mdwn
index a0742f78..29e5fbb7 100644
--- a/doc/README.mdwn
+++ b/doc/README.mdwn
@@ -35,7 +35,7 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
## quick start
-1. Get propellor installed
+1. Get propellor installed on your laptop.
`cabal install propellor`
or
`apt-get install propellor`
@@ -44,25 +44,18 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
3. If you don't have a gpg private key already, generate one: `gpg --gen-key`
4. Run: `propellor --add-key $KEYID`, which will make propellor trust
your gpg key, and will sign your `~/.propellor` repository using it.
-5. Push the git repository to a central server (github or your own):
- `cd ~/.propellor/; git remote add origin ssh://git.example.com/propellor.git; git push -u origin master`
-6. Edit `~/.propellor/config.hs`, and add a host you want to manage.
+5. Edit `~/.propellor/config.hs`, and add a host you want to manage.
You can start by not adding any properties, or only a few.
-7. Pick a host and run: `propellor --spin $HOST`
-8. Now you have a simple propellor deployment, but it doesn't do
+6. Pick a host and run: `propellor --spin $HOST`
+7. Now you have a simple propellor deployment, but it doesn't do
much to the host yet, besides installing propellor.
So, edit `~/.propellor/config.hs` to configure the host (maybe
- start with a few simple properties), and re-run step 7.
+ start with a few simple properties), and re-run step 6.
Repeat until happy and move on to the next host. :)
-9. To move beyond manually running `propellor --spin` against hosts
- when you change their properties, add a property to your hosts
- like: `Cron.runPropellor "30 * * * *"`
-
- Now they'll automatically update every 30 minutes, and you can
- `git commit -S` and `git push` changes that affect any number of
- hosts.
-10. Write some neat new properties and send patches!
+8. Optionally, set up a [centralized git repository](https://propellor.branchable.com/centralized_git_repository/)
+ so multiple hosts can be updated with a simple `git commit -S; git push`
+9. Write some neat new properties and send patches!
## debugging
diff --git a/doc/centralized_git_repository.mdwn b/doc/centralized_git_repository.mdwn
new file mode 100644
index 00000000..98fe9bf2
--- /dev/null
+++ b/doc/centralized_git_repository.mdwn
@@ -0,0 +1,31 @@
+Propellor can be used without any centralized git repsitory. When
+`propellor --spin $HOST` is run, propellor pushes the local git repo
+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.
+
+You can add a central git repository to your existing propellor setup easily:
+
+1. Push propellor's git repository to a central server (github or your own):
+ `cd ~/.propellor/; git remote add origin ssh://git.example.com/propellor.git; git push -u origin master`
+
+2. Configure the url your hosts should use for the git repisitory, if
+ it differs from the url above, by setting up a remote named "deploy":
+ `cd ~/.propellor/; git remote add deploy git://git.example.com/propellor.git`
+
+2. Add a property to your hosts like:
+ `Cron.runPropellor "30 * * * *"`
+
+3. Let your hosts know about the changed configuration (including the url
+ to the central repository), by running `proellor --spin $HOST` for each
+ of your hosts.
+
+Now the hosts will automatically update every 30 minutes, and you can
+`git commit -S` and `git push` changes that affect any number of
+hosts.
+
+Note that private data, set with `propellor --set`, is gpg encrypted, and
+hosts cannot decrypt it! So after updating the private data of a host,
+you still need to manually run `propellor --spin $HOST`
diff --git a/doc/security.mdwn b/doc/security.mdwn
index fb174cb7..7edf25d1 100644
--- a/doc/security.mdwn
+++ b/doc/security.mdwn
@@ -1,5 +1,6 @@
Propellor's security model is that the hosts it's used to deploy are
-untrusted, and that the central git repository server is untrusted too.
+untrusted, and that the central git repository server, if any,
+is untrusted too.
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
diff --git a/propellor.cabal b/propellor.cabal
index 8e552f2d..0a01ada8 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -116,6 +116,7 @@ Library
Propellor.Gpg
Propellor.SimpleSh
Propellor.PrivData.Paths
+ Propellor.Protocol
Propellor.Property.Docker.Shim
Utility.Applicative
Utility.Data
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index c3b792d1..e7da0a80 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -11,8 +11,12 @@ 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)
import Propellor
+import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Gpg
import qualified Propellor.Property.Docker as Docker
@@ -42,6 +46,7 @@ processCmdLine = go =<< getArgs
go ("--help":_) = usage
go ("--spin":h:[]) = return $ Spin h
go ("--boot":h:[]) = return $ Boot h
+ go ("--run":h:[]) = return $ Run h
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump
@@ -52,6 +57,7 @@ processCmdLine = go =<< getArgs
Nothing -> errorMessage "--continue serialization failure"
go ("--chain":h:[]) = return $ Chain h
go ("--docker":h:[]) = return $ Docker h
+ go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go (h:[])
| "--" `isPrefixOf` h = usage
| otherwise = return $ Run h
@@ -84,6 +90,7 @@ defaultMain hostlist = do
r <- runPropellor h $ ensureProperties $ hostProperties h
putStrLn $ "\n" ++ show r
go _ (Docker hn) = Docker.chain hn
+ go _ (GitPush fin fout) = gitPush fin fout
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
@@ -91,7 +98,7 @@ defaultMain hostlist = do
( onlyProcess $ withhost hn mainProperties
, go True (Spin hn)
)
- go False (Boot hn) = onlyProcess $ withhost hn boot
+ go False (Boot _) = onlyProcess boot
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
@@ -135,7 +142,10 @@ getCurrentBranch = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
updateFirst :: CmdLine -> IO () -> IO ()
-updateFirst cmdline next = do
+updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
+
+updateFirst' :: CmdLine -> IO () -> IO ()
+updateFirst' cmdline next = do
branchref <- getCurrentBranch
let originbranch = "origin" </> branchref
@@ -179,37 +189,74 @@ updateFirst cmdline next = do
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
- url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
- void $ boolSystem "git" [Param "push"]
+ -- 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"]
+
cacheparams <- toCommand <$> sshCachingParams hn
- go cacheparams url =<< hostprivdata
+ comm cacheparams =<< hostprivdata
+ unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
+ error $ "remote propellor failed (running: " ++ runcmd ++")"
where
hostprivdata = show . filterPrivData hst <$> decryptPrivData
- go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
- let finish = do
- senddata toh "privdata" privDataMarker privdata
+ 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
- status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
- case status of
- Ready -> finish
- NeedGitClone -> do
- hClose toh
- hClose fromh
- sendGitClone hn url
- go cacheparams url privdata
+ dispatch Nothing = return ()
user = "root@"++hn
- bootstrapcmd = shellWrap $ intercalate " ; "
+ mkcmd = shellWrap . intercalate " ; "
+
+ bootstrapcmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
[ "apt-get update"
@@ -224,24 +271,19 @@ spin hn hst = do
, "fi"
]
- getstatus :: Handle -> IO BootStrapStatus
- getstatus h = do
- l <- hGetLine h
- case readish =<< fromMarked statusMarker l of
- Nothing -> do
- showremote l
- getstatus h
- Just status -> return status
-
+ runcmd = mkcmd
+ [ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
+
showremote s = putStrLn s
- senddata toh desc marker s = void $
- actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
- sendMarked toh marker s
+
+ sendprivdata toh privdata = void $
+ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
+ sendMarked toh privDataMarker privdata
return True
-- Initial git clone, used for bootstrapping.
-sendGitClone :: HostName -> String -> IO ()
-sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
+sendGitClone :: HostName -> IO ()
+sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
@@ -257,59 +299,71 @@ sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn)
, "git checkout -b " ++ branch
, "git remote rm origin"
, "rm -f " ++ remotebundle
- , "git remote add origin " ++ url
- -- same as --set-upstream-to, except origin branch
- -- has not been pulled yet
- , "git config branch."++branch++".remote origin"
- , "git config branch."++branch++".merge refs/heads/"++branch
]
-data BootStrapStatus = Ready | NeedGitClone
- deriving (Read, Show, Eq)
-
-type Marker = String
-type Marked = String
-
-statusMarker :: Marker
-statusMarker = "STATUS"
-
-privDataMarker :: String
-privDataMarker = "PRIVDATA "
-
-toMarked :: Marker -> String -> String
-toMarked marker = intercalate "\n" . map (marker ++) . lines
-
-sendMarked :: Handle -> Marker -> String -> IO ()
-sendMarked h marker s = do
- -- Prefix string with newline because sometimes a
- -- incomplete line is output.
- hPutStrLn h ("\n" ++ toMarked marker s)
- hFlush h
-
-fromMarked :: Marker -> Marked -> Maybe String
-fromMarked marker s
- | null matches = Nothing
- | otherwise = Just $ intercalate "\n" $
- map (drop len) matches
- where
- len = length marker
- matches = filter (marker `isPrefixOf`) $ lines s
-
-boot :: Host -> IO ()
-boot h = do
- sendMarked stdout statusMarker $ show Ready
- reply <- hGetContentsStrict stdin
-
+-- 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
- maybe noop (writeFileProtected privDataLocal) $
- fromMarked privDataMarker reply
- mainProperties h
+ 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.
+gitPush :: Fd -> Fd -> IO ()
+gitPush 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
+
+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]
-getUrl :: IO String
-getUrl = maybe nourl return =<< getM get urls
+getRepoUrl :: IO (Maybe String)
+getRepoUrl = getM get urls
where
urls = ["remote.deploy.url", "remote.origin.url"]
- nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
get u = do
v <- catchMaybeIO $
takeWhile (/= '\n')
@@ -321,8 +375,7 @@ getUrl = maybe nourl return =<< getM get urls
checkDebugMode :: IO ()
checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
where
- go (Just s)
- | s == "1" = do
+ go (Just "1") = do
f <- setFormatter
<$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg")
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index afbed1ca..e184a59e 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -8,6 +8,21 @@ import System.Log.Logger
import "mtl" Control.Monad.Reader
import Propellor.Types
+import Utility.Monad
+
+data MessageHandle
+ = ConsoleMessageHandle
+ | TextMessageHandle
+
+mkMessageHandle :: IO MessageHandle
+mkMessageHandle = ifM (hIsTerminalDevice stdout)
+ ( return ConsoleMessageHandle
+ , return TextMessageHandle
+ )
+
+whenConsole :: MessageHandle -> IO () -> IO ()
+whenConsole ConsoleMessageHandle a = a
+whenConsole _ _ = return ()
-- | Shows a message while performing an action, with a colored status
-- display.
@@ -21,46 +36,55 @@ actionMessageOn = actionMessage' . Just
actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do
- liftIO $ do
+ h <- liftIO mkMessageHandle
+ liftIO $ whenConsole h $ do
setTitle $ "propellor: " ++ desc
hFlush stdout
r <- a
liftIO $ do
- setTitle "propellor: running"
- showhn mhn
+ whenConsole h $
+ setTitle "propellor: running"
+ showhn h mhn
putStr $ desc ++ " ... "
let (msg, intensity, color) = getActionResult r
- colorLine intensity color msg
+ colorLine h intensity color msg
hFlush stdout
return r
where
- showhn Nothing = return ()
- showhn (Just hn) = do
- setSGR [SetColor Foreground Dull Cyan]
+ showhn _ Nothing = return ()
+ showhn h (Just hn) = do
+ whenConsole h $
+ setSGR [SetColor Foreground Dull Cyan]
putStr (hn ++ " ")
- setSGR []
+ whenConsole h $
+ setSGR []
warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
+warningMessage s = liftIO $ do
+ h <- mkMessageHandle
+ colorLine h Vivid Magenta $ "** warning: " ++ s
-colorLine :: ColorIntensity -> Color -> String -> IO ()
-colorLine intensity color msg = do
- setSGR [SetColor Foreground intensity color]
+errorMessage :: MonadIO m => String -> m a
+errorMessage s = liftIO $ do
+ h <- mkMessageHandle
+ colorLine h Vivid Red $ "** error: " ++ s
+ error "Cannot continue!"
+
+colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO ()
+colorLine h intensity color msg = do
+ whenConsole h $
+ setSGR [SetColor Foreground intensity color]
putStr msg
- setSGR []
+ whenConsole h $
+ setSGR []
-- Note this comes after the color is reset, so that
-- the color set and reset happen in the same line.
putStrLn ""
hFlush stdout
-errorMessage :: String -> IO a
-errorMessage s = do
- liftIO $ colorLine Vivid Red $ "** error: " ++ s
- error "Cannot continue!"
-
-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
debug :: [String] -> IO ()
debug = debugM "propellor" . unwords
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
new file mode 100644
index 00000000..99afb31f
--- /dev/null
+++ b/src/Propellor/Protocol.hs
@@ -0,0 +1,57 @@
+-- | 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.
+
+module Propellor.Protocol where
+
+import Data.List
+
+import Propellor
+
+data Stage = Ready | NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
+ deriving (Read, Show, Eq)
+
+type Marker = String
+type Marked = String
+
+statusMarker :: Marker
+statusMarker = "STATUS"
+
+privDataMarker :: String
+privDataMarker = "PRIVDATA "
+
+repoUrlMarker :: String
+repoUrlMarker = "REPOURL "
+
+gitPushMarker :: String
+gitPushMarker = "GITPUSH"
+
+toMarked :: Marker -> String -> String
+toMarked = (++)
+
+fromMarked :: Marker -> Marked -> Maybe String
+fromMarked marker s
+ | marker `isPrefixOf` s = Just $ drop (length marker) s
+ | otherwise = Nothing
+
+sendMarked :: Handle -> Marker -> String -> IO ()
+sendMarked h marker s = do
+ -- Prefix string with newline because sometimes a
+ -- incomplete line has been output, and the marker needs to
+ -- come at the start of a line.
+ hPutStrLn h ("\n" ++ toMarked marker s)
+ hFlush h
+
+getMarked :: Handle -> Marker -> IO (Maybe String)
+getMarked h marker = go =<< catchMaybeIO (hGetLine h)
+ where
+ go Nothing = return Nothing
+ go (Just l) = case fromMarked marker l of
+ Nothing -> getMarked h marker
+ Just v -> return (Just v)
+
+req :: Stage -> Marker -> (String -> IO ()) -> IO ()
+req stage marker a = do
+ sendMarked stdout statusMarker (show stage)
+ maybe noop a =<< getMarked stdin marker
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index b606cef2..72ccd228 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -28,6 +28,7 @@ module Propellor.Types
import Data.Monoid
import Control.Applicative
import System.Console.ANSI
+import System.Posix.Types
import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO
@@ -137,7 +138,6 @@ instance ActionResult Result where
data CmdLine
= Run HostName
| Spin HostName
- | Boot HostName
| Set PrivDataField Context
| Dump PrivDataField Context
| Edit PrivDataField Context
@@ -145,5 +145,7 @@ data CmdLine
| AddKey String
| Continue CmdLine
| Chain HostName
+ | Boot HostName
| Docker HostName
+ | GitPush Fd Fd
deriving (Read, Show, Eq)