summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2014-11-18 22:10:50 -0400
committerJoey Hess2014-11-18 22:13:13 -0400
commitdac6a874195a521714db48083b3222c2c8b41fa9 (patch)
tree9e67d33a06222e8787e51601229b53131ba3d2aa /src
parent1946b8df36c1d65ba46e01adcdcb5d6dda98f59a (diff)
broke out Server module
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/CmdLine.hs137
-rw-r--r--src/Propellor/Protocol.hs4
-rw-r--r--src/Propellor/Server.hs140
3 files changed, 153 insertions, 128 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ee563012..0ae79ac3 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -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
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index f8b706cc..68c2443b 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -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
diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs
new file mode 100644
index 00000000..1b31234b
--- /dev/null
+++ b/src/Propellor/Server.hs
@@ -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