Merge branch 'joeyconfig'
This commit is contained in:
commit
6df64ff653
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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`
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"]
|
||||||
|
-- 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 $ 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")
|
||||||
|
|
|
@ -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
|
||||||
|
whenConsole h $
|
||||||
setTitle "propellor: running"
|
setTitle "propellor: running"
|
||||||
showhn mhn
|
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
|
||||||
|
whenConsole h $
|
||||||
setSGR [SetColor Foreground Dull Cyan]
|
setSGR [SetColor Foreground Dull Cyan]
|
||||||
putStr (hn ++ " ")
|
putStr (hn ++ " ")
|
||||||
|
whenConsole h $
|
||||||
setSGR []
|
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
|
||||||
|
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]
|
setSGR [SetColor Foreground intensity color]
|
||||||
putStr msg
|
putStr msg
|
||||||
|
whenConsole h $
|
||||||
setSGR []
|
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
|
||||||
|
|
|
@ -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
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue