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 ++++------------------------------------------- 1 file changed, 9 insertions(+), 128 deletions(-) (limited to 'src/Propellor/CmdLine.hs') 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 -- cgit v1.2.3