Merge branch 'joeyconfig'

This commit is contained in:
Joey Hess 2014-11-18 17:33:21 -04:00
commit 6df64ff653
10 changed files with 288 additions and 118 deletions

View File

@ -191,9 +191,9 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64"
& JoeySites.annexWebSite "/srv/git/downloads.git" & JoeySites.annexWebSite "/srv/git/downloads.git"
"downloads.kitenet.net" "downloads.kitenet.net"
"840760dc-08f0-11e2-8c61-576b7e66acfd" "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.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 & JoeySites.gitAnnexDistributor
& alias "tmp.kitenet.net" & alias "tmp.kitenet.net"
& JoeySites.annexWebSite "/srv/git/joey/tmp.git" & JoeySites.annexWebSite "/srv/git/joey/tmp.git"

8
debian/changelog vendored
View File

@ -1,5 +1,11 @@
propellor (0.9.3) UNRELEASED; urgency=medium 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. * Added prosody module, contributed by Félix Sipma.
* Can be used to configure tor hidden services. Thanks, 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 * 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. * Convert GpgKeyId to newtype.
* DigitalOcean.distroKernel property now reboots into the distribution * DigitalOcean.distroKernel property now reboots into the distribution
kernel when necessary. 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 -- Joey Hess <joeyh@debian.org> Mon, 10 Nov 2014 11:15:27 -0400

View File

@ -35,7 +35,7 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask
## quick start ## quick start
1. Get propellor installed 1. Get propellor installed on your laptop.
`cabal install propellor` `cabal install propellor`
or or
`apt-get install propellor` `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` 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 4. Run: `propellor --add-key $KEYID`, which will make propellor trust
your gpg key, and will sign your `~/.propellor` repository using it. your gpg key, and will sign your `~/.propellor` repository using it.
5. Push the git repository to a central server (github or your own): 5. Edit `~/.propellor/config.hs`, and add a host you want to manage.
`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.
You can start by not adding any properties, or only a few. You can start by not adding any properties, or only a few.
7. Pick a host and run: `propellor --spin $HOST` 6. Pick a host and run: `propellor --spin $HOST`
8. Now you have a simple propellor deployment, but it doesn't do 7. Now you have a simple propellor deployment, but it doesn't do
much to the host yet, besides installing propellor. much to the host yet, besides installing propellor.
So, edit `~/.propellor/config.hs` to configure the host (maybe 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. :) Repeat until happy and move on to the next host. :)
9. To move beyond manually running `propellor --spin` against hosts 8. Optionally, set up a [centralized git repository](https://propellor.branchable.com/centralized_git_repository/)
when you change their properties, add a property to your hosts so multiple hosts can be updated with a simple `git commit -S; git push`
like: `Cron.runPropellor "30 * * * *"` 9. Write some neat new properties and send patches!
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!
## debugging ## debugging

View File

@ -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`

View File

@ -1,5 +1,6 @@
Propellor's security model is that the hosts it's used to deploy are 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` 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 to connect to a remote host. And that one only because you have a ssh key

View File

@ -116,6 +116,7 @@ Library
Propellor.Gpg Propellor.Gpg
Propellor.SimpleSh Propellor.SimpleSh
Propellor.PrivData.Paths Propellor.PrivData.Paths
Propellor.Protocol
Propellor.Property.Docker.Shim Propellor.Property.Docker.Shim
Utility.Applicative Utility.Applicative
Utility.Data Utility.Data

View File

@ -11,8 +11,12 @@ import System.PosixCompat
import Control.Exception (bracket) import Control.Exception (bracket)
import System.Posix.IO import System.Posix.IO
import Data.Time.Clock.POSIX 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
import Propellor.Protocol
import Propellor.PrivData.Paths import Propellor.PrivData.Paths
import Propellor.Gpg import Propellor.Gpg
import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker as Docker
@ -42,6 +46,7 @@ processCmdLine = go =<< getArgs
go ("--help":_) = usage go ("--help":_) = usage
go ("--spin":h:[]) = return $ Spin h go ("--spin":h:[]) = return $ Spin h
go ("--boot":h:[]) = return $ Boot h go ("--boot":h:[]) = return $ Boot h
go ("--run":h:[]) = return $ Run h
go ("--add-key":k:[]) = return $ AddKey k go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump go ("--dump":f:c:[]) = withprivfield f c Dump
@ -52,6 +57,7 @@ processCmdLine = go =<< getArgs
Nothing -> errorMessage "--continue serialization failure" Nothing -> errorMessage "--continue serialization failure"
go ("--chain":h:[]) = return $ Chain h go ("--chain":h:[]) = return $ Chain h
go ("--docker":h:[]) = return $ Docker h go ("--docker":h:[]) = return $ Docker h
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go (h:[]) go (h:[])
| "--" `isPrefixOf` h = usage | "--" `isPrefixOf` h = usage
| otherwise = return $ Run h | otherwise = return $ Run h
@ -84,6 +90,7 @@ defaultMain hostlist = do
r <- runPropellor h $ ensureProperties $ hostProperties h r <- runPropellor h $ ensureProperties $ hostProperties h
putStrLn $ "\n" ++ show r putStrLn $ "\n" ++ show r
go _ (Docker hn) = Docker.chain hn 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@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn go False (Spin hn) = withhost hn $ spin hn
@ -91,7 +98,7 @@ defaultMain hostlist = do
( onlyProcess $ withhost hn mainProperties ( onlyProcess $ withhost hn mainProperties
, go True (Spin hn) , go True (Spin hn)
) )
go False (Boot hn) = onlyProcess $ withhost hn boot go False (Boot _) = onlyProcess boot
withhost :: HostName -> (Host -> IO ()) -> IO () withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
@ -135,7 +142,10 @@ getCurrentBranch = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
updateFirst :: CmdLine -> IO () -> IO () 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 branchref <- getCurrentBranch
let originbranch = "origin" </> branchref let originbranch = "origin" </> branchref
@ -179,37 +189,74 @@ updateFirst cmdline next = do
getCurrentGitSha1 :: String -> IO String getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] 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 :: HostName -> Host -> IO ()
spin hn hst = do spin hn hst = do
url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] 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 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 where
hostprivdata = show . filterPrivData hst <$> decryptPrivData hostprivdata = show . filterPrivData hst <$> decryptPrivData
go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do comm cacheparams privdata =
let finish = do withBothHandles createProcessSuccess
senddata toh "privdata" privDataMarker privdata (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 hClose toh
-- Display remaining output. -- Display remaining output.
void $ tryIO $ forever $ void $ tryIO $ forever $
showremote =<< hGetLine fromh showremote =<< hGetLine fromh
hClose fromh hClose fromh
status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)") dispatch Nothing = return ()
case status of
Ready -> finish
NeedGitClone -> do
hClose toh
hClose fromh
sendGitClone hn url
go cacheparams url privdata
user = "root@"++hn user = "root@"++hn
bootstrapcmd = shellWrap $ intercalate " ; " mkcmd = shellWrap . intercalate " ; "
bootstrapcmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]" [ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && " , "then " ++ intercalate " && "
[ "apt-get update" [ "apt-get update"
@ -224,24 +271,19 @@ spin hn hst = do
, "fi" , "fi"
] ]
getstatus :: Handle -> IO BootStrapStatus runcmd = mkcmd
getstatus h = do [ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
l <- hGetLine h
case readish =<< fromMarked statusMarker l of
Nothing -> do
showremote l
getstatus h
Just status -> return status
showremote s = putStrLn s showremote s = putStrLn s
senddata toh desc marker s = void $
actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do sendprivdata toh privdata = void $
sendMarked toh marker s actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True return True
-- Initial git clone, used for bootstrapping. -- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> String -> IO () sendGitClone :: HostName -> IO ()
sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch branch <- getCurrentBranch
cacheparams <- sshCachingParams hn cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id 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 checkout -b " ++ branch
, "git remote rm origin" , "git remote rm origin"
, "rm -f " ++ remotebundle , "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 -- Called "boot" for historical reasons, but what this really does is
deriving (Read, Show, Eq) -- update the privdata, repo url, and git repo over the ssh connection from the
-- client that ran propellor --spin.
type Marker = String boot :: IO ()
type Marked = String boot = do
req NeedRepoUrl repoUrlMarker setRepoUrl
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
makePrivDataDir makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $ req NeedPrivData privDataMarker $
fromMarked privDataMarker reply writeFileProtected privDataLocal
mainProperties h 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"
getUrl :: IO String -- Shim for git push over the propellor ssh channel.
getUrl = maybe nourl return =<< getM get urls -- 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]
getRepoUrl :: IO (Maybe String)
getRepoUrl = getM get urls
where where
urls = ["remote.deploy.url", "remote.origin.url"] urls = ["remote.deploy.url", "remote.origin.url"]
nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
get u = do get u = do
v <- catchMaybeIO $ v <- catchMaybeIO $
takeWhile (/= '\n') takeWhile (/= '\n')
@ -321,8 +375,7 @@ getUrl = maybe nourl return =<< getM get urls
checkDebugMode :: IO () checkDebugMode :: IO ()
checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
where where
go (Just s) go (Just "1") = do
| s == "1" = do
f <- setFormatter f <- setFormatter
<$> streamHandler stderr DEBUG <$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg") <*> pure (simpleLogFormatter "[$time] $msg")

View File

@ -8,6 +8,21 @@ import System.Log.Logger
import "mtl" Control.Monad.Reader import "mtl" Control.Monad.Reader
import Propellor.Types 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 -- | Shows a message while performing an action, with a colored status
-- display. -- display.
@ -21,46 +36,55 @@ actionMessageOn = actionMessage' . Just
actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do actionMessage' mhn desc a = do
liftIO $ do h <- liftIO mkMessageHandle
liftIO $ whenConsole h $ do
setTitle $ "propellor: " ++ desc setTitle $ "propellor: " ++ desc
hFlush stdout hFlush stdout
r <- a r <- a
liftIO $ do liftIO $ do
setTitle "propellor: running" whenConsole h $
showhn mhn setTitle "propellor: running"
showhn h mhn
putStr $ desc ++ " ... " putStr $ desc ++ " ... "
let (msg, intensity, color) = getActionResult r let (msg, intensity, color) = getActionResult r
colorLine intensity color msg colorLine h intensity color msg
hFlush stdout hFlush stdout
return r return r
where where
showhn Nothing = return () showhn _ Nothing = return ()
showhn (Just hn) = do showhn h (Just hn) = do
setSGR [SetColor Foreground Dull Cyan] whenConsole h $
setSGR [SetColor Foreground Dull Cyan]
putStr (hn ++ " ") putStr (hn ++ " ")
setSGR [] whenConsole h $
setSGR []
warningMessage :: MonadIO m => String -> m () 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 () errorMessage :: MonadIO m => String -> m a
colorLine intensity color msg = do errorMessage s = liftIO $ do
setSGR [SetColor Foreground intensity color] 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 putStr msg
setSGR [] whenConsole h $
setSGR []
-- Note this comes after the color is reset, so that -- Note this comes after the color is reset, so that
-- the color set and reset happen in the same line. -- the color set and reset happen in the same line.
putStrLn "" putStrLn ""
hFlush stdout 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 -- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
debug :: [String] -> IO () debug :: [String] -> IO ()
debug = debugM "propellor" . unwords debug = debugM "propellor" . unwords

57
src/Propellor/Protocol.hs Normal file
View File

@ -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

View File

@ -28,6 +28,7 @@ module Propellor.Types
import Data.Monoid import Data.Monoid
import Control.Applicative import Control.Applicative
import System.Console.ANSI import System.Console.ANSI
import System.Posix.Types
import "mtl" Control.Monad.Reader import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO import "MonadCatchIO-transformers" Control.Monad.CatchIO
@ -137,7 +138,6 @@ instance ActionResult Result where
data CmdLine data CmdLine
= Run HostName = Run HostName
| Spin HostName | Spin HostName
| Boot HostName
| Set PrivDataField Context | Set PrivDataField Context
| Dump PrivDataField Context | Dump PrivDataField Context
| Edit PrivDataField Context | Edit PrivDataField Context
@ -145,5 +145,7 @@ data CmdLine
| AddKey String | AddKey String
| Continue CmdLine | Continue CmdLine
| Chain HostName | Chain HostName
| Boot HostName
| Docker HostName | Docker HostName
| GitPush Fd Fd
deriving (Read, Show, Eq) deriving (Read, Show, Eq)