From dac6a874195a521714db48083b3222c2c8b41fa9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Nov 2014 22:10:50 -0400 Subject: broke out Server module --- src/Propellor/CmdLine.hs | 137 +++------------------------------------------ src/Propellor/Protocol.hs | 4 ++ src/Propellor/Server.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 153 insertions(+), 128 deletions(-) create mode 100644 src/Propellor/Server.hs (limited to 'src') 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 -- cgit v1.2.3