broke out Server module
This commit is contained in:
Joey Hess
parent
1946b8df36
commit
dac6a87419
|
|
@ -115,6 +115,7 @@ Library
|
|||
Propellor.CmdLine
|
||||
Propellor.Git
|
||||
Propellor.Gpg
|
||||
Propellor.Server
|
||||
Propellor.SimpleSh
|
||||
Propellor.Ssh
|
||||
Propellor.PrivData.Paths
|
||||
|
|
|
|||
|
|
@ -6,19 +6,15 @@ import System.Exit
|
|||
import System.PosixCompat
|
||||
import Control.Exception (bracket)
|
||||
import System.Posix.IO
|
||||
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 Propellor.Git
|
||||
import Propellor.Ssh
|
||||
import Propellor.Server
|
||||
import qualified Propellor.Property.Docker as Docker
|
||||
import qualified Propellor.Property.Docker.Shim as DockerShim
|
||||
import Utility.FileMode
|
||||
import Utility.SafeCommand
|
||||
|
||||
usage :: Handle -> IO ()
|
||||
|
|
@ -91,7 +87,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 _ (GitPush fin fout) = gitPushHelper 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
|
||||
|
|
@ -172,9 +168,6 @@ updateFirst' cmdline next = do
|
|||
, errorMessage "Propellor build failed!"
|
||||
)
|
||||
|
||||
-- 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 $ actionMessage "Git commit (signed)" $
|
||||
|
|
@ -187,8 +180,12 @@ spin hn hst = do
|
|||
boolSystem "git" [Param "push"]
|
||||
|
||||
cacheparams <- toCommand <$> sshCachingParams hn
|
||||
comm hn hst $ withBothHandles createProcessSuccess
|
||||
(proc "ssh" $ cacheparams ++ [user, bootstrapcmd])
|
||||
|
||||
-- Install, or update the remote propellor.
|
||||
updateServer hn hst $ withBothHandles createProcessSuccess
|
||||
(proc "ssh" $ cacheparams ++ [user, updatecmd])
|
||||
|
||||
-- And now we can run it.
|
||||
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
|
||||
error $ "remote propellor failed (running: " ++ runcmd ++")"
|
||||
where
|
||||
|
|
@ -196,7 +193,7 @@ spin hn hst = do
|
|||
|
||||
mkcmd = shellWrap . intercalate " ; "
|
||||
|
||||
bootstrapcmd = mkcmd
|
||||
updatecmd = mkcmd
|
||||
[ "if [ ! -d " ++ localdir ++ " ]"
|
||||
, "then " ++ intercalate " && "
|
||||
[ "apt-get update"
|
||||
|
|
@ -213,119 +210,3 @@ spin hn hst = do
|
|||
|
||||
runcmd = mkcmd
|
||||
[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
|
||||
|
||||
-- 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 "."
|
||||
]
|
||||
|
||||
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 ("Clone git repository to " ++ hn) $ do
|
||||
branch <- getCurrentBranch
|
||||
cacheparams <- sshCachingParams hn
|
||||
withTmpFile "propellor.git" $ \tmp _ -> allM id
|
||||
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
|
||||
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
|
||||
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
|
||||
]
|
||||
where
|
||||
remotebundle = "/usr/local/propellor.git"
|
||||
unpackcmd branch = shellWrap $ intercalate " && "
|
||||
[ "git clone " ++ remotebundle ++ " " ++ localdir
|
||||
, "cd " ++ localdir
|
||||
, "git checkout -b " ++ branch
|
||||
, "git remote rm origin"
|
||||
, "rm -f " ++ remotebundle
|
||||
]
|
||||
|
||||
-- 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
|
||||
|
|
|
|||
|
|
@ -2,6 +2,10 @@
|
|||
-- 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 passed through to be displayed.
|
||||
--
|
||||
-- Avoid making backwards-incompatible changes to this protocol,
|
||||
-- since propellor needs to use this protocol to update itself to new
|
||||
-- versions speaking newer versions of the protocol.
|
||||
|
||||
module Propellor.Protocol where
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,140 @@
|
|||
module Propellor.Server (
|
||||
update,
|
||||
updateServer,
|
||||
gitPushHelper
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import System.Exit
|
||||
import System.PosixCompat
|
||||
import System.Posix.IO
|
||||
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.Git
|
||||
import Propellor.Ssh
|
||||
import Utility.FileMode
|
||||
import Utility.SafeCommand
|
||||
|
||||
-- Update the privdata, repo url, and git repo over the ssh
|
||||
-- connection, talking the the user's local propellor instance which is
|
||||
-- running the updateServer
|
||||
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 "."
|
||||
]
|
||||
|
||||
-- The connect action should ssh to the remote host and run the provided
|
||||
-- calback action.
|
||||
updateServer :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
|
||||
updateServer 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
|
||||
updateServer 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 ("Clone git repository to " ++ hn) $ do
|
||||
branch <- getCurrentBranch
|
||||
cacheparams <- sshCachingParams hn
|
||||
withTmpFile "propellor.git" $ \tmp _ -> allM id
|
||||
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
|
||||
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
|
||||
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
|
||||
]
|
||||
where
|
||||
remotebundle = "/usr/local/propellor.git"
|
||||
unpackcmd branch = shellWrap $ intercalate " && "
|
||||
[ "git clone " ++ remotebundle ++ " " ++ localdir
|
||||
, "cd " ++ localdir
|
||||
, "git checkout -b " ++ branch
|
||||
, "git remote rm origin"
|
||||
, "rm -f " ++ remotebundle
|
||||
]
|
||||
|
||||
-- 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.
|
||||
gitPushHelper :: Fd -> Fd -> IO ()
|
||||
gitPushHelper 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
|
||||
Loading…
Reference in New Issue